Cabal 3.10.3.0 → 3.12.0.0

raw patch · 148 files changed

+36982/−27637 lines, 148 filesdep −textdep ~Cabal-syntaxdep ~timesetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies removed: text

Dependency ranges changed: Cabal-syntax, time

API changes (from Hackage documentation)

Files

• Cabal.cabal +38/−5
• ChangeLog.md +3/−0
• LICENSE +1/−1
• README.md +2/−2
• Setup.hs +1/−0
• src/Distribution/Backpack/ComponentsGraph.hs +51/−43
• src/Distribution/Backpack/Configure.hs +358/−251
• src/Distribution/Backpack/ConfiguredComponent.hs +235/−192
• src/Distribution/Backpack/DescribeUnitId.hs +32/−21
• src/Distribution/Backpack/FullUnitId.hs +13/−12
• src/Distribution/Backpack/Id.hs +83/−72
• src/Distribution/Backpack/LinkedComponent.hs +301/−213
• src/Distribution/Backpack/MixLink.hs +168/−132
• src/Distribution/Backpack/ModSubst.hs +22/−22
• src/Distribution/Backpack/ModuleScope.hs +52/−49
• src/Distribution/Backpack/ModuleShape.hs +21/−20
• src/Distribution/Backpack/PreExistingComponent.hs +51/−39
• src/Distribution/Backpack/PreModuleShape.hs +18/−18
• src/Distribution/Backpack/ReadyComponent.hs +271/−235
• src/Distribution/Backpack/UnifyM.hs +311/−270
• src/Distribution/Compat/Async.hs +48/−30
• src/Distribution/Compat/CopyFile.hs +16/−14
• src/Distribution/Compat/Directory.hs +4/−5
• src/Distribution/Compat/Environment.hs +6/−5
• src/Distribution/Compat/FilePath.hs +4/−5
• src/Distribution/Compat/GetShortPathName.hs +6/−4
• src/Distribution/Compat/Internal/TempFile.hs +18/−13
• src/Distribution/Compat/Prelude/Internal.hs +3/−3
• src/Distribution/Compat/Process.hs +9/−7
• src/Distribution/Compat/ResponseFile.hs +27/−5
• src/Distribution/Compat/SnocList.hs +10/−9
• src/Distribution/Compat/Stack.hs +17/−15
• src/Distribution/Compat/Time.hs +27/−22
• src/Distribution/GetOpt.hs +201/−157
• src/Distribution/Lex.hs +32/−22
• src/Distribution/Make.hs +48/−43
• src/Distribution/PackageDescription/Check.hs +1084/−2939
• src/Distribution/PackageDescription/Check/Common.hs +149/−0
• src/Distribution/PackageDescription/Check/Conditional.hs +265/−0
• src/Distribution/PackageDescription/Check/Monad.hs +371/−0
• src/Distribution/PackageDescription/Check/Paths.hs +417/−0
• src/Distribution/PackageDescription/Check/Target.hs +1060/−0
• src/Distribution/PackageDescription/Check/Warning.hs +1473/−0
• src/Distribution/ReadE.hs +28/−20
• src/Distribution/Simple.hs +599/−386
• src/Distribution/Simple/Bench.hs +100/−82
• src/Distribution/Simple/Build.hs +1049/−829
• src/Distribution/Simple/Build/Inputs.hs +74/−0
• src/Distribution/Simple/Build/Macros.hs +58/−54
• src/Distribution/Simple/Build/Macros/Z.hs +1/−0
• src/Distribution/Simple/Build/PackageInfoModule.hs +20/−16
• src/Distribution/Simple/Build/PackageInfoModule/Z.hs +11/−11
• src/Distribution/Simple/Build/PathsModule.hs +96/−90
• src/Distribution/Simple/Build/PathsModule/Z.hs +1/−0
• src/Distribution/Simple/BuildPaths.hs +134/−105
• src/Distribution/Simple/BuildTarget.hs +1109/−1063
• src/Distribution/Simple/BuildToolDepends.hs +48/−27
• src/Distribution/Simple/CCompiler.hs +66/−52
• src/Distribution/Simple/Command.hs +557/−374
• src/Distribution/Simple/Compiler.hs +219/−189
• src/Distribution/Simple/Configure.hs +2694/−2138
• src/Distribution/Simple/ConfigureScript.hs +106/−77
• src/Distribution/Simple/Errors.hs +800/−0
• src/Distribution/Simple/Flag.hs +65/−40
• src/Distribution/Simple/GHC.hs +1014/−2185
• src/Distribution/Simple/GHC/Build.hs +140/−0
• src/Distribution/Simple/GHC/Build/ExtraSources.hs +242/−0
• src/Distribution/Simple/GHC/Build/Link.hs +663/−0
• src/Distribution/Simple/GHC/Build/Modules.hs +352/−0
• src/Distribution/Simple/GHC/Build/Utils.hs +217/−0
• src/Distribution/Simple/GHC/EnvironmentParser.hs +32/−22
• src/Distribution/Simple/GHC/ImplInfo.hs +105/−69
• src/Distribution/Simple/GHC/Internal.hs +875/−719
• src/Distribution/Simple/GHCJS.hs +2031/−1838
• src/Distribution/Simple/Glob.hs +73/−290
• src/Distribution/Simple/Glob/Internal.hs +497/−0
• src/Distribution/Simple/Haddock.hs +1235/−1036
• src/Distribution/Simple/HaskellSuite.hs +121/−82
• src/Distribution/Simple/Hpc.hs +126/−123
• src/Distribution/Simple/Install.hs +217/−157
• src/Distribution/Simple/InstallDirs.hs +284/−237
• src/Distribution/Simple/InstallDirs/Internal.hs +129/−96
• src/Distribution/Simple/LocalBuildInfo.hs +311/−228
• src/Distribution/Simple/PackageDescription.hs +71/−58
• src/Distribution/Simple/PackageIndex.hs +373/−311
• src/Distribution/Simple/PreProcess.hs +918/−837
• src/Distribution/Simple/PreProcess/Types.hs +114/−0
• src/Distribution/Simple/PreProcess/Unlit.hs +101/−91
• src/Distribution/Simple/Program.hs +121/−112
• src/Distribution/Simple/Program/Ar.hs +153/−120
• src/Distribution/Simple/Program/Builtin.hs +260/−230
• src/Distribution/Simple/Program/Db.hs +235/−239
• src/Distribution/Simple/Program/Find.hs +68/−59
• src/Distribution/Simple/Program/GHC.hs +911/−855
• src/Distribution/Simple/Program/HcPkg.hs +289/−265
• src/Distribution/Simple/Program/Hpc.hs +93/−64
• src/Distribution/Simple/Program/Internal.hs +21/−22
• src/Distribution/Simple/Program/Ld.hs +55/−41
• src/Distribution/Simple/Program/ResponseFile.hs +21/−15
• src/Distribution/Simple/Program/Run.hs +158/−138
• src/Distribution/Simple/Program/Script.hs +75/−75
• src/Distribution/Simple/Program/Strip.hs +42/−34
• src/Distribution/Simple/Program/Types.hs +92/−104
• src/Distribution/Simple/Register.hs +491/−359
• src/Distribution/Simple/Setup.hs +191/−2557
• src/Distribution/Simple/Setup/Benchmark.hs +131/−0
• src/Distribution/Simple/Setup/Build.hs +165/−0
• src/Distribution/Simple/Setup/Clean.hs +97/−0
• src/Distribution/Simple/Setup/Common.hs +372/−0
• src/Distribution/Simple/Setup/Config.hs +1064/−0
• src/Distribution/Simple/Setup/Copy.hs +153/−0
• src/Distribution/Simple/Setup/Global.hs +122/−0
• src/Distribution/Simple/Setup/Haddock.hs +606/−0
• src/Distribution/Simple/Setup/Hscolour.hs +157/−0
• src/Distribution/Simple/Setup/Install.hs +158/−0
• src/Distribution/Simple/Setup/Register.hs +195/−0
• src/Distribution/Simple/Setup/Repl.hs +205/−0
• src/Distribution/Simple/Setup/SDist.hs +113/−0
• src/Distribution/Simple/Setup/Test.hs +254/−0
• src/Distribution/Simple/ShowBuildInfo.hs +67/−51
• src/Distribution/Simple/SrcDist.hs +363/−310
• src/Distribution/Simple/Test.hs +146/−89
• src/Distribution/Simple/Test/ExeV10.hs +180/−131
• src/Distribution/Simple/Test/LibV09.hs +220/−173
• src/Distribution/Simple/Test/Log.hs +113/−86
• src/Distribution/Simple/UHC.hs +218/−149
• src/Distribution/Simple/UserHooks.hs +138/−149
• src/Distribution/Simple/Utils.hs +1869/−1620
• src/Distribution/TestSuite.hs +73/−66
• src/Distribution/Types/AnnotatedId.hs +15/−16
• src/Distribution/Types/ComponentInclude.hs +15/−15
• src/Distribution/Types/ComponentLocalBuildInfo.hs +96/−97
• src/Distribution/Types/DumpBuildInfo.hs +3/−2
• src/Distribution/Types/GivenComponent.hs +10/−9
• src/Distribution/Types/LocalBuildConfig.hs +226/−0
• src/Distribution/Types/LocalBuildInfo.hs +312/−180
• src/Distribution/Types/ParStrat.hs +24/−0
• src/Distribution/Types/TargetInfo.hs +24/−18
• src/Distribution/Utils/IOData.hs +51/−47
• src/Distribution/Utils/Json.hs +38/−33
• src/Distribution/Utils/LogProgress.hs +39/−37
• src/Distribution/Utils/MapAccum.hs +14/−8
• src/Distribution/Utils/NubList.hs +25/−28
• src/Distribution/Utils/Progress.hs +25/−22
• src/Distribution/Utils/UnionFind.hs +46/−44
• src/Distribution/Verbosity.hs +124/−107
• src/Distribution/Verbosity/Internal.hs +14/−12
• src/Distribution/ZinzaPrelude.hs +23/−22

@@ -1,7 +1,7 @@ cabal-version: 2.2 name:          Cabal-version:       3.10.3.0-copyright:     2003-2023, Cabal Development Team (see AUTHORS file)+version:       3.12.0.0+copyright:     2003-2024, Cabal Development Team (see AUTHORS file) license:       BSD-3-Clause license-file:  LICENSE author:        Cabal Development Team <cabal-devel@haskell.org>@@ -34,7 +34,7 @@   hs-source-dirs: src    build-depends:-    Cabal-syntax ^>= 3.10,+    Cabal-syntax ^>= 3.12,     array      >= 0.4.0.1  && < 0.6,     base       >= 4.9      && < 5,     bytestring >= 0.10.0.0 && < 0.13,@@ -44,7 +44,7 @@     filepath   >= 1.3.0.1  && < 1.6,     pretty     >= 1.1.1    && < 1.2,     process    >= 1.2.1.0  && < 1.7,-    time       >= 1.4.0.1  && < 1.13+    time       >= 1.4.0.1  && < 1.15    if os(windows)     build-depends: Win32 >= 2.3.0.0 && < 2.15@@ -59,6 +59,9 @@   if impl(ghc >= 8.0) && impl(ghc < 8.8)     ghc-options: -Wnoncanonical-monadfail-instances +  if impl(ghc >= 8.10)+    ghc-options: -Wunused-packages+   exposed-modules:     Distribution.Backpack.Configure     Distribution.Backpack.ComponentsGraph@@ -88,6 +91,7 @@     Distribution.Simple     Distribution.Simple.Bench     Distribution.Simple.Build+    Distribution.Simple.Build.Inputs     Distribution.Simple.Build.Macros     Distribution.Simple.Build.PackageInfoModule     Distribution.Simple.Build.PathsModule@@ -98,11 +102,13 @@     Distribution.Simple.Command     Distribution.Simple.Compiler     Distribution.Simple.Configure+    Distribution.Simple.Errors     Distribution.Simple.Flag     Distribution.Simple.GHC     Distribution.Simple.GHCJS     Distribution.Simple.Haddock     Distribution.Simple.Glob+    Distribution.Simple.Glob.Internal     Distribution.Simple.HaskellSuite     Distribution.Simple.Hpc     Distribution.Simple.Install@@ -112,6 +118,7 @@     Distribution.Simple.PackageDescription     Distribution.Simple.PackageIndex     Distribution.Simple.PreProcess+    Distribution.Simple.PreProcess.Types     Distribution.Simple.PreProcess.Unlit     Distribution.Simple.Program     Distribution.Simple.Program.Ar@@ -145,9 +152,11 @@     Distribution.Types.DumpBuildInfo     Distribution.Types.PackageName.Magic     Distribution.Types.ComponentLocalBuildInfo+    Distribution.Types.LocalBuildConfig     Distribution.Types.LocalBuildInfo     Distribution.Types.TargetInfo     Distribution.Types.GivenComponent+    Distribution.Types.ParStrat     Distribution.Utils.Json     Distribution.Utils.NubList     Distribution.Utils.Progress@@ -302,7 +311,6 @@     -- See also https://github.com/ekmett/transformers-compat/issues/35     transformers (>= 0.3      && < 0.4) || (>=0.4.1.0 && <0.7),     mtl           >= 2.1      && < 2.4,-    text         (>= 1.2.3.0  && < 1.3) || (>= 2.0 && < 2.2),     parsec        >= 3.1.13.0 && < 3.2    other-modules:@@ -319,13 +327,38 @@     Distribution.Compat.SnocList     Distribution.GetOpt     Distribution.Lex+    Distribution.PackageDescription.Check.Common+    Distribution.PackageDescription.Check.Conditional+    Distribution.PackageDescription.Check.Monad+    Distribution.PackageDescription.Check.Paths+    Distribution.PackageDescription.Check.Target+    Distribution.PackageDescription.Check.Warning     Distribution.Simple.Build.Macros.Z     Distribution.Simple.Build.PackageInfoModule.Z     Distribution.Simple.Build.PathsModule.Z+    Distribution.Simple.GHC.Build+    Distribution.Simple.GHC.Build.ExtraSources+    Distribution.Simple.GHC.Build.Link+    Distribution.Simple.GHC.Build.Modules+    Distribution.Simple.GHC.Build.Utils     Distribution.Simple.GHC.EnvironmentParser     Distribution.Simple.GHC.Internal     Distribution.Simple.GHC.ImplInfo     Distribution.Simple.ConfigureScript+    Distribution.Simple.Setup.Benchmark+    Distribution.Simple.Setup.Build+    Distribution.Simple.Setup.Clean+    Distribution.Simple.Setup.Common+    Distribution.Simple.Setup.Config+    Distribution.Simple.Setup.Copy+    Distribution.Simple.Setup.Global+    Distribution.Simple.Setup.Haddock+    Distribution.Simple.Setup.Hscolour+    Distribution.Simple.Setup.Install+    Distribution.Simple.Setup.Register+    Distribution.Simple.Setup.Repl+    Distribution.Simple.Setup.SDist+    Distribution.Simple.Setup.Test     Distribution.ZinzaPrelude     Paths_Cabal 

@@ -1,3 +1,6 @@+# 3.12.0.0 [Francesco Ariis](mailto:fa-ml@ariis.it) May 2024+* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.12.0.0.md+ # 3.10.3.0 [Hécate](mailto:hecate+github@glitchbra.in) January 2024 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.3.0.md 

@@ -1,4 +1,4 @@-Copyright (c) 2003-2023, Cabal Development Team.+Copyright (c) 2003-2024, Cabal Development Team. See the AUTHORS file for the full list of copyright holders.  See */LICENSE for the copyright holders of the subcomponents.

@@ -34,8 +34,8 @@ [Hackage]. You may have a favourite Cabal bug or limitation. Look at Cabal's [bug tracker]. Ensure that the problem is reported there and adequately described. Comment on the issue to report how much of a-problem the bug is for you. Subscribe to the issues's notifications to-discussed requirements and keep informed on progress. For feature+problem the bug is for you. Subscribe to the issue's notifications to+discuss requirements and keep informed on progress. For feature requests, it is helpful if there is a description of how you would expect to interact with the new feature. 

@@ -1,4 +1,5 @@ import Distribution.Simple+ main :: IO () main = defaultMain 

@@ -1,24 +1,24 @@ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ComponentsGraph (-    ComponentsGraph,-    ComponentsWithDeps,-    mkComponentsGraph,-    componentsGraphToList,-    dispComponentsWithDeps,-    componentCycleMsg-) where+module Distribution.Backpack.ComponentsGraph+  ( ComponentsGraph+  , ComponentsWithDeps+  , mkComponentsGraph+  , componentsGraphToList+  , dispComponentsWithDeps+  , componentCycleMsg+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () +import Distribution.Compat.Graph (Graph, Node (..))+import qualified Distribution.Compat.Graph as Graph+import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec-import Distribution.Compat.Graph (Graph, Node(..))-import qualified Distribution.Compat.Graph as Graph-import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Utils.Generic  import Distribution.Pretty (pretty)@@ -30,68 +30,76 @@  -- | A graph of source-level components by their source-level -- dependencies--- type ComponentsGraph = Graph (Node ComponentName Component)  -- | A list of components associated with the source level -- dependencies between them.--- type ComponentsWithDeps = [(Component, [ComponentName])]  -- | Pretty-print 'ComponentsWithDeps'.--- dispComponentsWithDeps :: ComponentsWithDeps -> Doc dispComponentsWithDeps graph =-    vcat [ hang (text "component" <+> pretty (componentName c)) 4-                (vcat [ text "dependency" <+> pretty cdep | cdep <- cdeps ])-         | (c, cdeps) <- graph ]+  vcat+    [ hang+      (text "component" <+> pretty (componentName c))+      4+      (vcat [text "dependency" <+> pretty cdep | cdep <- cdeps])+    | (c, cdeps) <- graph+    ]  -- | Create a 'Graph' of 'Component', or report a cycle if there is a -- problem.----mkComponentsGraph :: ComponentRequestedSpec-                  -> PackageDescription-                  -> Either [ComponentName] ComponentsGraph+mkComponentsGraph+  :: ComponentRequestedSpec+  -> PackageDescription+  -> Either [ComponentName] ComponentsGraph mkComponentsGraph enabled pkg_descr =-    let g = Graph.fromDistinctList-                           [ N c (componentName c) (componentDeps c)-                           | c <- pkgBuildableComponents pkg_descr-                           , componentEnabled enabled c ]-    in case Graph.cycles g of-          []     -> Right g-          ccycles -> Left  [ componentName c | N c _ _ <- concat ccycles ]+  let g =+        Graph.fromDistinctList+          [ N c (componentName c) (componentDeps c)+          | c <- pkgBuildableComponents pkg_descr+          , componentEnabled enabled c+          ]+   in case Graph.cycles g of+        [] -> Right g+        ccycles -> Left [componentName c | N c _ _ <- concat ccycles]   where     -- The dependencies for the given component     componentDeps component =-        toolDependencies ++ libDependencies+      toolDependencies ++ libDependencies       where         bi = componentBuildInfo component          toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi          libDependencies = do-            Dependency pkgname _ lns <- targetBuildDepends bi-            guard (pkgname == packageName pkg_descr)+          Dependency pkgname _ lns <- targetBuildDepends bi+          guard (pkgname == packageName pkg_descr) -            ln <- NES.toList lns-            return (CLibName ln)+          ln <- NES.toList lns+          return (CLibName ln)  -- | Given the package description and a 'PackageDescription' (used -- to determine if a package name is internal or not), sort the -- components in dependency order (fewest dependencies first).  This is -- NOT necessarily the build order (although it is in the absence of -- Backpack.)----componentsGraphToList :: ComponentsGraph-                      -> ComponentsWithDeps+componentsGraphToList+  :: ComponentsGraph+  -> ComponentsWithDeps componentsGraphToList =-    map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort+  map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort  -- | Error message when there is a cycle; takes the SCC of components. componentCycleMsg :: PackageIdentifier -> [ComponentName] -> Doc componentCycleMsg pn cnames =-    text "Components in the package" <+> pretty pn <+> text "depend on each other in a cyclic way:"-    $$-    text (intercalate " depends on "-            [ "'" ++ showComponentName cname ++ "'"-            | cname <- cnames ++ maybeToList (safeHead cnames) ])+  text "Components in the package"+    <+> pretty pn+    <+> text "depend on each other in a cyclic way:"+    $$ text+      ( intercalate+          " depends on "+          [ "'" ++ showComponentName cname ++ "'"+          | cname <- cnames ++ maybeToList (safeHead cnames)+          ]+      )

@@ -1,56 +1,60 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-}-{-# LANGUAGE NondecreasingIndentation #-}  -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst> -- -- WARNING: The contents of this module are HIGHLY experimental. -- We may refactor it under you.-module Distribution.Backpack.Configure (-    configureComponentLocalBuildInfos,-) where+module Distribution.Backpack.Configure+  ( configureComponentLocalBuildInfos+  ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()  import Distribution.Backpack-import Distribution.Backpack.FullUnitId-import Distribution.Backpack.PreExistingComponent+import Distribution.Backpack.ComponentsGraph import Distribution.Backpack.ConfiguredComponent+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.Id import Distribution.Backpack.LinkedComponent+import Distribution.Backpack.PreExistingComponent import Distribution.Backpack.ReadyComponent-import Distribution.Backpack.ComponentsGraph-import Distribution.Backpack.Id -import Distribution.Simple.Compiler-import Distribution.Package+import Distribution.Backpack.ModuleShape+import Distribution.Compat.Graph (Graph, IsNode (..))+import qualified Distribution.Compat.Graph as Graph+import Distribution.InstalledPackageInfo+  ( InstalledPackageInfo+  , emptyInstalledPackageInfo+  ) import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.InstalledPackageInfo (InstalledPackageInfo-                                         ,emptyInstalledPackageInfo)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.PackageDescription import Distribution.ModuleName-import Distribution.Simple.Setup as Setup+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Simple.Compiler+import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Types.AnnotatedId-import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ComponentInclude+import Distribution.Types.ComponentRequestedSpec import Distribution.Types.MungedPackageName-import Distribution.Verbosity-import qualified Distribution.Compat.Graph as Graph-import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Utils.LogProgress+import Distribution.Verbosity  import Data.Either-    ( lefts )-import qualified Data.Set as Set+  ( lefts+  ) import qualified Data.Map as Map+import qualified Data.Set as Set import Distribution.Pretty import Text.PrettyPrint @@ -59,144 +63,233 @@ ------------------------------------------------------------------------------  configureComponentLocalBuildInfos-    :: Verbosity-    -> Bool                   -- use_external_internal_deps-    -> ComponentRequestedSpec-    -> Bool                   -- deterministic-    -> Flag String            -- configIPID-    -> Flag ComponentId       -- configCID-    -> PackageDescription-    -> [PreExistingComponent]-    -> FlagAssignment         -- configConfigurationsFlags-    -> [(ModuleName, Module)] -- configInstantiateWith-    -> InstalledPackageIndex-    -> Compiler-    -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)+  :: Verbosity+  -> Bool -- use_external_internal_deps+  -> ComponentRequestedSpec+  -> Bool -- deterministic+  -> Flag String -- configIPID+  -> Flag ComponentId -- configCID+  -> PackageDescription+  -> ([PreExistingComponent], [PromisedComponent])+  -> FlagAssignment -- configConfigurationsFlags+  -> [(ModuleName, Module)] -- configInstantiateWith+  -> InstalledPackageIndex+  -> Compiler+  -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) configureComponentLocalBuildInfos-    verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr-    prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do+  verbosity+  use_external_internal_deps+  enabled+  deterministic+  ipid_flag+  cid_flag+  pkg_descr+  (prePkgDeps, promisedPkgDeps)+  flags+  instantiate_with+  installedPackageSet+  comp = do     -- NB: In single component mode, this returns a *single* component.     -- In this graph, the graph is NOT closed.     graph0 <- case mkComponentsGraph enabled pkg_descr of-                Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle)-                Right g -> return (componentsGraphToList g)-    infoProgress $ hang (text "Source component graph:") 4-                        (dispComponentsWithDeps graph0)+      Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle)+      Right g -> return (componentsGraphToList g)+    infoProgress $+      hang+        (text "Source component graph:")+        4+        (dispComponentsWithDeps graph0) -    let conf_pkg_map = Map.fromListWith Map.union-            [(pc_pkgname pkg,-                Map.singleton (pc_compname pkg)-                              (AnnotatedId {-                                ann_id = pc_cid pkg,-                                ann_pid = packageId pkg,-                                ann_cname = pc_compname pkg-                              }))-            | pkg <- prePkgDeps]-    graph1 <- toConfiguredComponents use_external_internal_deps-                    flagAssignment-                    deterministic ipid_flag cid_flag pkg_descr-                    conf_pkg_map (map fst graph0)-    infoProgress $ hang (text "Configured component graph:") 4-                        (vcat (map dispConfiguredComponent graph1))+    let conf_pkg_map =+          Map.fromListWith+            Map.union+            [ ( pc_pkgname pkg+              , Map.singleton+                  (pc_compname pkg)+                  ( AnnotatedId+                      { ann_id = pc_cid pkg+                      , ann_pid = packageId pkg+                      , ann_cname = pc_compname pkg+                      }+                  )+              )+            | pkg <- prePkgDeps+            ]+            `Map.union` Map.fromListWith+              Map.union+              [ (pkg, Map.singleton (ann_cname aid) aid)+              | PromisedComponent pkg aid <- promisedPkgDeps+              ]+    graph1 <-+      toConfiguredComponents+        use_external_internal_deps+        flags+        deterministic+        ipid_flag+        cid_flag+        pkg_descr+        conf_pkg_map+        (map fst graph0)+    infoProgress $+      hang+        (text "Configured component graph:")+        4+        (vcat (map dispConfiguredComponent graph1)) -    let shape_pkg_map = Map.fromList+    let shape_pkg_map =+          Map.fromList             [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg))-            | pkg <- prePkgDeps]+            | pkg <- prePkgDeps+            ]+            `Map.union` Map.fromList+              [ ( ann_id aid+                ,+                  ( DefiniteUnitId+                      ( unsafeMkDefUnitId+                          (mkUnitId (unComponentId (ann_id aid)))+                      )+                  , emptyModuleShape+                  )+                )+              | PromisedComponent _ aid <- promisedPkgDeps+              ]         uid_lookup def_uid-            | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid-            = FullUnitId (Installed.installedComponentId pkg)-                 (Map.fromList (Installed.instantiatedWith pkg))-            | otherwise = error ("uid_lookup: " ++ prettyShow uid)-          where uid = unDefUnitId def_uid-    graph2 <- toLinkedComponents verbosity uid_lookup-                    (package pkg_descr) shape_pkg_map graph1+          | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid =+              FullUnitId+                (Installed.installedComponentId pkg)+                (Map.fromList (Installed.instantiatedWith pkg))+          | otherwise = error ("uid_lookup: " ++ prettyShow uid)+          where+            uid = unDefUnitId def_uid+    graph2 <-+      toLinkedComponents+        verbosity+        (not (null promisedPkgDeps))+        uid_lookup+        (package pkg_descr)+        shape_pkg_map+        graph1      infoProgress $-        hang (text "Linked component graph:") 4-             (vcat (map dispLinkedComponent graph2))+      hang+        (text "Linked component graph:")+        4+        (vcat (map dispLinkedComponent graph2)) -    let pid_map = Map.fromList $+    let pid_map =+          Map.fromList $             [ (pc_uid pkg, pc_munged_id pkg)-            | pkg <- prePkgDeps] ++-            [ (Installed.installedUnitId pkg, mungedId pkg)-            | (_, Module uid _) <- instantiate_with-            , Just pkg <- [PackageIndex.lookupUnitId-                                installedPackageSet (unDefUnitId uid)] ]+            | pkg <- prePkgDeps+            ]+              ++ [ (Installed.installedUnitId pkg, mungedId pkg)+                 | (_, Module uid _) <- instantiate_with+                 , Just pkg <-+                    [ PackageIndex.lookupUnitId+                        installedPackageSet+                        (unDefUnitId uid)+                    ]+                 ]         subst = Map.fromList instantiate_with         graph3 = toReadyComponents pid_map subst graph2         graph4 = Graph.revTopSort (Graph.fromDistinctList graph3) -    infoProgress $ hang (text "Ready component graph:") 4-                        (vcat (map dispReadyComponent graph4))+    infoProgress $+      hang+        (text "Ready component graph:")+        4+        (vcat (map dispReadyComponent graph4)) -    toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4+    toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4  ------------------------------------------------------------------------------ -- ComponentLocalBuildInfo ------------------------------------------------------------------------------  toComponentLocalBuildInfos-    :: Compiler-    -> InstalledPackageIndex -- FULL set-    -> PackageDescription-    -> [PreExistingComponent] -- external package deps-    -> [ReadyComponent]-    -> LogProgress ([ComponentLocalBuildInfo],-                    InstalledPackageIndex) -- only relevant packages+  :: Compiler+  -> InstalledPackageIndex -- FULL set+  -> [PromisedComponent]+  -> PackageDescription+  -> [PreExistingComponent] -- external package deps+  -> [ReadyComponent]+  -> LogProgress+      ( [ComponentLocalBuildInfo]+      , InstalledPackageIndex -- only relevant packages+      ) toComponentLocalBuildInfos-    comp installedPackageSet pkg_descr externalPkgDeps graph = do+  comp+  installedPackageSet+  promisedPkgDeps+  pkg_descr+  externalPkgDeps+  graph = do     -- Check and make sure that every instantiated component exists.     -- We have to do this now, because prior to linking/instantiating     -- we don't actually know what the full set of 'UnitId's we need     -- are.-    let -- TODO: This is actually a bit questionable performance-wise,-        -- since we will pay for the ALL installed packages even if-        -- they are not related to what we are building.  This was true-        -- in the old configure code.-        external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)-        external_graph = Graph.fromDistinctList-                       . map Left-                       $ PackageIndex.allPackages installedPackageSet-        internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)-        internal_graph = Graph.fromDistinctList-                       . map Right-                       $ graph-        combined_graph = Graph.unionRight external_graph internal_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:-        ---        --      * We'll use it to do a consistency check so we're not depending-        --        on multiple versions of the same package (TODO: someday relax-        --        this for private dependencies.)  See right below.-        ---        --      * We'll pass it on in the LocalBuildInfo, where preprocessors-        --        and other things will incorrectly use it to determine what-        --        the include paths and everything should be.-        ---        packageDependsIndex = PackageIndex.fromList (lefts local_graph)-        fullIndex = Graph.fromDistinctList local_graph+    let+      -- TODO: This is actually a bit questionable performance-wise,+      -- since we will pay for the ALL installed packages even if+      -- they are not related to what we are building.  This was true+      -- in the old configure code.+      external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)+      external_graph =+        Graph.fromDistinctList+          . map Left+          $ PackageIndex.allPackages installedPackageSet+      internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)+      internal_graph =+        Graph.fromDistinctList+          . map Right+          $ graph+      combined_graph = Graph.unionRight external_graph internal_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:+      --+      --      * We'll use it to do a consistency check so we're not depending+      --        on multiple versions of the same package (TODO: someday relax+      --        this for private dependencies.)  See right below.+      --+      --      * We'll pass it on in the LocalBuildInfo, where preprocessors+      --        and other things will incorrectly use it to determine what+      --        the include paths and everything should be.+      --+      packageDependsIndex = PackageIndex.fromList (lefts local_graph)+      fullIndex = Graph.fromDistinctList local_graph+     case Graph.broken fullIndex of-        [] -> return ()-        broken ->-          -- TODO: ppr this-          dieProgress . text $-                "The following packages are broken because other"-             ++ " packages they depend on are missing. These broken "-             ++ "packages must be rebuilt before they can be used.\n"-             -- TODO: Undupe.-             ++ unlines [ "installed package "-                       ++ prettyShow (packageId pkg)-                       ++ " is broken due to missing package "-                       ++ intercalate ", " (map prettyShow deps)-                        | (Left pkg, deps) <- broken ]-             ++ unlines [ "planned package "-                       ++ prettyShow (packageId pkg)-                       ++ " is broken due to missing package "-                       ++ intercalate ", " (map prettyShow deps)-                        | (Right pkg, deps) <- broken ]+      [] -> return ()+      -- If there are promised dependencies, we don't know what the dependencies+      -- of these are and that can easily lead to a broken graph. So assume that+      -- any promised package is not broken (ie all its dependencies, transitively,+      -- will be there). That's a promise.+      broken+        | not (null promisedPkgDeps) -> return ()+        | otherwise ->+            -- TODO: ppr this+            dieProgress . text $+              "The following packages are broken because other"+                ++ " packages they depend on are missing. These broken "+                ++ "packages must be rebuilt before they can be used.\n"+                -- TODO: Undupe.+                ++ unlines+                  [ "installed package "+                    ++ prettyShow (packageId pkg)+                    ++ " is broken due to missing package "+                    ++ intercalate ", " (map prettyShow deps)+                  | (Left pkg, deps) <- broken+                  ]+                ++ unlines+                  [ "planned package "+                    ++ prettyShow (packageId pkg)+                    ++ " is broken due to missing package "+                    ++ intercalate ", " (map prettyShow deps)+                  | (Right pkg, deps) <- broken+                  ]      -- In this section, we'd like to look at the 'packageDependsIndex'     -- and see if we've picked multiple versions of the same@@ -213,25 +306,34 @@     --     -- TODO: This is probably wrong for Backpack     let pseudoTopPkg :: InstalledPackageInfo-        pseudoTopPkg = emptyInstalledPackageInfo {-            Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr),-            Installed.sourcePackageId = packageId pkg_descr,-            Installed.depends = map pc_uid externalPkgDeps-          }+        pseudoTopPkg =+          emptyInstalledPackageInfo+            { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr)+            , Installed.sourcePackageId = packageId pkg_descr+            , Installed.depends = map pc_uid externalPkgDeps+            }     case PackageIndex.dependencyInconsistencies-       . PackageIndex.insert pseudoTopPkg-       $ packageDependsIndex of+      . PackageIndex.insert pseudoTopPkg+      $ packageDependsIndex of       [] -> return ()       inconsistencies ->         warnProgress $-          hang (text "This package indirectly depends on multiple versions of the same" <+>-                text "package. This is very likely to cause a compile failure.") 2-               (vcat [ text "package" <+> pretty (packageName user) <+>-                       parens (pretty (installedUnitId user)) <+> text "requires" <+>-                       pretty inst-                     | (_dep_key, insts) <- inconsistencies-                     , (inst, users) <- insts-                     , user <- users ])+          hang+            ( text "This package indirectly depends on multiple versions of the same"+                <+> text "package. This is very likely to cause a compile failure."+            )+            2+            ( vcat+                [ text "package"+                  <+> pretty (packageName user)+                  <+> parens (pretty (installedUnitId user))+                  <+> text "requires"+                  <+> pretty inst+                | (_dep_key, insts) <- inconsistencies+                , (inst, users) <- insts+                , user <- users+                ]+            )     let clbis = mkLinkedComponentsLocalBuildInfo comp graph     -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)     return (clbis, packageDependsIndex)@@ -241,119 +343,124 @@ -- -- This conversion is lossy; we lose some invariants from ReadyComponent mkLinkedComponentsLocalBuildInfo-    :: Compiler-    -> [ReadyComponent]-    -> [ComponentLocalBuildInfo]+  :: Compiler+  -> [ReadyComponent]+  -> [ComponentLocalBuildInfo] mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs   where     internalUnits = Set.fromList (map rc_uid rcs)     isInternal x = Set.member x internalUnits     go rc =       case rc_component rc of-      CLib lib ->-        let convModuleExport (modname', (Module uid modname))-              | this_uid == unDefUnitId uid-              , modname' == modname-              = Installed.ExposedModule modname' Nothing-              | otherwise-              = Installed.ExposedModule modname'-                  (Just (OpenModule (DefiniteUnitId uid) modname))-            convOpenModuleExport (modname', modu@(OpenModule uid modname))-              | uid == this_open_uid-              , modname' == modname-              = Installed.ExposedModule modname' Nothing-              | otherwise-              = Installed.ExposedModule modname' (Just modu)-            convOpenModuleExport (_, OpenModuleVar _)-                = error "convOpenModuleExport: top-level modvar"-            exports =+        CLib lib ->+          let convModuleExport (modname', (Module uid modname))+                | this_uid == unDefUnitId uid+                , modname' == modname =+                    Installed.ExposedModule modname' Nothing+                | otherwise =+                    Installed.ExposedModule+                      modname'+                      (Just (OpenModule (DefiniteUnitId uid) modname))+              convOpenModuleExport (modname', modu@(OpenModule uid modname))+                | uid == this_open_uid+                , modname' == modname =+                    Installed.ExposedModule modname' Nothing+                | otherwise =+                    Installed.ExposedModule modname' (Just modu)+              convOpenModuleExport (_, OpenModuleVar _) =+                error "convOpenModuleExport: top-level modvar"+              exports =                 -- Loses invariants                 case rc_i rc of-                    Left indefc -> map convOpenModuleExport-                                 $ Map.toList (indefc_provides indefc)-                    Right instc -> map convModuleExport-                                 $ Map.toList (instc_provides instc)-            insts =+                  Left indefc ->+                    map convOpenModuleExport $+                      Map.toList (indefc_provides indefc)+                  Right instc ->+                    map convModuleExport $+                      Map.toList (instc_provides instc)+              insts =                 case rc_i rc of-                    Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ]-                    Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m')-                                   | (m, Module uid' m') <- instc_insts instc ]--            compat_name = MungedPackageName (packageName rc) (libName lib)-            compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid+                  Left indefc -> [(m, OpenModuleVar m) | m <- indefc_requires indefc]+                  Right instc ->+                    [ (m, OpenModule (DefiniteUnitId uid') m')+                    | (m, Module uid' m') <- instc_insts instc+                    ] -        in LibComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentInstantiatedWith = insts,-          componentIsIndefinite_ = is_indefinite,-          componentLocalName = cname,-          componentInternalDeps = internal_deps,-          componentExeDeps = exe_deps,-          componentIncludes = includes,-          componentExposedModules = exports,-          componentIsPublic = rc_public rc,-          componentCompatPackageKey = compat_key,-          componentCompatPackageName = compat_name-        }-      CFLib _ ->-        FLibComponentLocalBuildInfo {-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentLocalName = cname,-          componentPackageDeps = cpds,-          componentExeDeps = exe_deps,-          componentInternalDeps = internal_deps,-          componentIncludes = includes-        }-      CExe _ ->-        ExeComponentLocalBuildInfo {-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentLocalName = cname,-          componentPackageDeps = cpds,-          componentExeDeps = exe_deps,-          componentInternalDeps = internal_deps,-          componentIncludes = includes-        }-      CTest _ ->-        TestComponentLocalBuildInfo {-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentLocalName = cname,-          componentPackageDeps = cpds,-          componentExeDeps = exe_deps,-          componentInternalDeps = internal_deps,-          componentIncludes = includes-        }-      CBench _ ->-        BenchComponentLocalBuildInfo {-          componentUnitId = this_uid,-          componentComponentId = this_cid,-          componentLocalName = cname,-          componentPackageDeps = cpds,-          componentExeDeps = exe_deps,-          componentInternalDeps = internal_deps,-          componentIncludes = includes-        }-     where-      this_uid      = rc_uid rc-      this_open_uid = rc_open_uid rc-      this_cid      = rc_cid rc-      cname = componentName (rc_component rc)-      cpds = rc_depends rc-      exe_deps = map ann_id $ rc_exe_deps rc-      is_indefinite =-        case rc_i rc of+              compat_name = MungedPackageName (packageName rc) (libName lib)+              compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid+           in LibComponentLocalBuildInfo+                { componentPackageDeps = cpds+                , componentUnitId = this_uid+                , componentComponentId = this_cid+                , componentInstantiatedWith = insts+                , componentIsIndefinite_ = is_indefinite+                , componentLocalName = cname+                , componentInternalDeps = internal_deps+                , componentExeDeps = exe_deps+                , componentIncludes = includes+                , componentExposedModules = exports+                , componentIsPublic = rc_public rc+                , componentCompatPackageKey = compat_key+                , componentCompatPackageName = compat_name+                }+        CFLib _ ->+          FLibComponentLocalBuildInfo+            { componentUnitId = this_uid+            , componentComponentId = this_cid+            , componentLocalName = cname+            , componentPackageDeps = cpds+            , componentExeDeps = exe_deps+            , componentInternalDeps = internal_deps+            , componentIncludes = includes+            }+        CExe _ ->+          ExeComponentLocalBuildInfo+            { componentUnitId = this_uid+            , componentComponentId = this_cid+            , componentLocalName = cname+            , componentPackageDeps = cpds+            , componentExeDeps = exe_deps+            , componentInternalDeps = internal_deps+            , componentIncludes = includes+            }+        CTest _ ->+          TestComponentLocalBuildInfo+            { componentUnitId = this_uid+            , componentComponentId = this_cid+            , componentLocalName = cname+            , componentPackageDeps = cpds+            , componentExeDeps = exe_deps+            , componentInternalDeps = internal_deps+            , componentIncludes = includes+            }+        CBench _ ->+          BenchComponentLocalBuildInfo+            { componentUnitId = this_uid+            , componentComponentId = this_cid+            , componentLocalName = cname+            , componentPackageDeps = cpds+            , componentExeDeps = exe_deps+            , componentInternalDeps = internal_deps+            , componentIncludes = includes+            }+      where+        this_uid = rc_uid rc+        this_open_uid = rc_open_uid rc+        this_cid = rc_cid rc+        cname = componentName (rc_component rc)+        cpds = rc_depends rc+        exe_deps = map ann_id $ rc_exe_deps rc+        is_indefinite =+          case rc_i rc of             Left _ -> True             Right _ -> False-      includes =-        map (\ci -> (ci_id ci, ci_renaming ci)) $+        includes =+          map (\ci -> (ci_id ci, ci_renaming ci)) $             case rc_i rc of-                Left indefc ->-                    indefc_includes indefc-                Right instc ->-                    map (\ci -> ci { ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci) })-                        (instc_includes instc)-      internal_deps = filter isInternal (nodeNeighbors rc)+              Left indefc ->+                indefc_includes indefc+              Right instc ->+                map+                  (\ci -> ci{ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci)})+                  (instc_includes instc)+        internal_deps = filter isInternal (nodeNeighbors rc)

@@ -1,80 +1,68 @@ {-# LANGUAGE PatternGuards #-}--- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ConfiguredComponent (-    ConfiguredComponent(..),-    cc_name,-    cc_cid,-    cc_pkgid,-    toConfiguredComponent,-    toConfiguredComponents,-    dispConfiguredComponent, -    ConfiguredComponentMap,-    extendConfiguredComponentMap,--    -- TODO: Should go somewhere else-    newPackageDepsBehaviour-) where+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.ConfiguredComponent+  ( ConfiguredComponent (..)+  , cc_name+  , cc_cid+  , cc_pkgid+  , toConfiguredComponent+  , toConfiguredComponents+  , dispConfiguredComponent+  , ConfiguredComponentMap+  , extendConfiguredComponentMap+  -- TODO: Should go somewhere else+  , newPackageDepsBehaviour+  ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()  import Distribution.Backpack.Id  import Distribution.CabalSpecVersion-import Distribution.Types.AnnotatedId-import Distribution.Types.Dependency-import Distribution.Types.ExeDependency-import Distribution.Types.IncludeRenaming-import Distribution.Types.ComponentId-import Distribution.Types.PackageId-import Distribution.Types.PackageName-import Distribution.Types.Mixin-import Distribution.Types.ComponentName-import Distribution.Types.LibraryName-import Distribution.Types.ComponentInclude import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends-import Distribution.Simple.Setup as Setup+import Distribution.Simple.Flag (Flag) import Distribution.Simple.LocalBuildInfo+import Distribution.Types.AnnotatedId+import Distribution.Types.ComponentInclude+import Distribution.Utils.Generic import Distribution.Utils.LogProgress import Distribution.Utils.MapAccum-import Distribution.Utils.Generic  import Control.Monad+import qualified Data.Map as Map import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NonEmptySet-import qualified Data.Map as Map import Distribution.Pretty-import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$))+import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($$)) import qualified Text.PrettyPrint as PP  -- | A configured component, we know exactly what its 'ComponentId' is, -- and the 'ComponentId's of the things it depends on.-data ConfiguredComponent-    = ConfiguredComponent {-        -- | Unique identifier of component, plus extra useful info.-        cc_ann_id :: AnnotatedId ComponentId,-        -- | The fragment of syntax from the Cabal file describing this-        -- component.-        cc_component :: Component,-        -- | Is this the public library component of the package?-        -- (If we invoke Setup with an instantiation, this is the-        -- component the instantiation applies to.)-        -- Note that in one-component configure mode, this is-        -- always True, because any component is the "public" one.)-        cc_public :: Bool,-        -- | Dependencies on executables from @build-tools@ and-        -- @build-tool-depends@.-        cc_exe_deps :: [AnnotatedId ComponentId],-        -- | The mixins of this package, including both explicit (from-        -- the @mixins@ field) and implicit (from @build-depends@).  Not-        -- mix-in linked yet; component configuration only looks at-        -- 'ComponentId's.-        cc_includes :: [ComponentInclude ComponentId IncludeRenaming]-      }-+data ConfiguredComponent = ConfiguredComponent+  { cc_ann_id :: AnnotatedId ComponentId+  -- ^ Unique identifier of component, plus extra useful info.+  , cc_component :: Component+  -- ^ The fragment of syntax from the Cabal file describing this+  -- component.+  , cc_public :: Bool+  -- ^ Is this the public library component of the package?+  -- (If we invoke Setup with an instantiation, this is the+  -- component the instantiation applies to.)+  -- Note that in one-component configure mode, this is+  -- always True, because any component is the "public" one.)+  , cc_exe_deps :: [AnnotatedId ComponentId]+  -- ^ Dependencies on executables from @build-tools@ and+  -- @build-tool-depends@.+  , cc_includes :: [ComponentInclude ComponentId IncludeRenaming]+  -- ^ The mixins of this package, including both explicit (from+  -- the @mixins@ field) and implicit (from @build-depends@).  Not+  -- mix-in linked yet; component configuration only looks at+  -- 'ComponentId's.+  }  -- | Uniquely identifies a configured component. cc_cid :: ConfiguredComponent -> ComponentId@@ -93,110 +81,132 @@ -- | Pretty-print a 'ConfiguredComponent'. dispConfiguredComponent :: ConfiguredComponent -> Doc dispConfiguredComponent cc =-    hang (text "component" <+> pretty (cc_cid cc)) 4-         (vcat [ hsep $ [ text "include"-                        , pretty (ci_id incl), pretty (ci_renaming incl) ]-               | incl <- cc_includes cc-               ])+  hang+    (text "component" <+> pretty (cc_cid cc))+    4+    ( vcat+        [ hsep $+          [ text "include"+          , pretty (ci_id incl)+          , pretty (ci_renaming incl)+          ]+        | incl <- cc_includes cc+        ]+    )  -- | Construct a 'ConfiguredComponent', given that the 'ComponentId' -- and library/executable dependencies are known.  The primary -- work this does is handling implicit @backpack-include@ fields. mkConfiguredComponent-    :: PackageDescription-    -> ComponentId-    -> [AnnotatedId ComponentId] -- lib deps-    -> [AnnotatedId ComponentId] -- exe deps-    -> Component-    -> LogProgress ConfiguredComponent+  :: PackageDescription+  -> ComponentId+  -> [AnnotatedId ComponentId] -- lib deps+  -> [AnnotatedId ComponentId] -- exe deps+  -> Component+  -> LogProgress ConfiguredComponent mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do-    -- Resolve each @mixins@ into the actual dependency-    -- from @lib_deps@.-    explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do-        aid <- case Map.lookup (pn, CLibName ln) deps_map of-                Nothing ->-                    dieProgress $-                    text "Mix-in refers to non-existent library" <+>-                    quotes (pretty pn <<>> prettyLN ln) $$-                    text "(did you forget to add the package to build-depends?)"-                Just r  -> return r-        return ComponentInclude {-                ci_ann_id   = aid,-                ci_renaming = rns,-                ci_implicit = False-            }+  -- Resolve each @mixins@ into the actual dependency+  -- from @lib_deps@.+  explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do+    aid <- case Map.lookup (pn, CLibName ln) deps_map of+      Nothing ->+        dieProgress $+          text "Mix-in refers to non-existent library"+            <+> quotes (pretty pn <<>> prettyLN ln)+            $$ text "(did you forget to add the package to build-depends?)"+      Just r -> return r+    return+      ComponentInclude+        { ci_ann_id = aid+        , ci_renaming = rns+        , ci_implicit = False+        } -        -- Any @build-depends@ which is not explicitly mentioned in-        -- @backpack-include@ is converted into an "implicit" include.-    let used_explicitly = Set.fromList (map ci_id explicit_includes)-        implicit_includes-            = map (\aid -> ComponentInclude {-                                ci_ann_id = aid,-                                ci_renaming = defaultIncludeRenaming,-                                ci_implicit = True-                            })-            $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps+  -- Any @build-depends@ which is not explicitly mentioned in+  -- @backpack-include@ is converted into an "implicit" include.+  let used_explicitly = Set.fromList (map ci_id explicit_includes)+      implicit_includes =+        map+          ( \aid ->+              ComponentInclude+                { ci_ann_id = aid+                , ci_renaming = defaultIncludeRenaming+                , ci_implicit = True+                }+          )+          $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps -    return ConfiguredComponent {-            cc_ann_id = AnnotatedId {-                    ann_id = this_cid,-                    ann_pid = package pkg_descr,-                    ann_cname = componentName component-                },-            cc_component = component,-            cc_public = is_public,-            cc_exe_deps = exe_deps,-            cc_includes = explicit_includes ++ implicit_includes-        }+  return+    ConfiguredComponent+      { cc_ann_id =+          AnnotatedId+            { ann_id = this_cid+            , ann_pid = package pkg_descr+            , ann_cname = componentName component+            }+      , cc_component = component+      , cc_public = is_public+      , cc_exe_deps = exe_deps+      , cc_includes = explicit_includes ++ implicit_includes+      }   where     bi :: BuildInfo     bi = componentBuildInfo component      prettyLN :: LibraryName -> Doc-    prettyLN LMainLibName    = PP.empty+    prettyLN LMainLibName = PP.empty     prettyLN (LSubLibName n) = PP.colon <<>> pretty n      deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId)-    deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep)-                            | dep <- lib_deps ]+    deps_map =+      Map.fromList+        [ ((packageName dep, ann_cname dep), dep)+        | dep <- lib_deps+        ]      is_public = componentName component == CLibName LMainLibName  type ConfiguredComponentMap =-        Map PackageName (Map ComponentName (AnnotatedId ComponentId))+  Map PackageName (Map ComponentName (AnnotatedId ComponentId))  toConfiguredComponent-    :: PackageDescription-    -> ComponentId-    -> ConfiguredComponentMap-    -> ConfiguredComponentMap-    -> Component-    -> LogProgress ConfiguredComponent+  :: PackageDescription+  -> ComponentId+  -> ConfiguredComponentMap+  -> ConfiguredComponentMap+  -> Component+  -> LogProgress ConfiguredComponent toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do-    lib_deps <--        if newPackageDepsBehaviour pkg_descr-            then fmap concat $ forM (targetBuildDepends bi) $-                 \(Dependency name _ sublibs) -> do-                    pkg <- case Map.lookup name lib_dep_map of+  lib_deps <-+    if newPackageDepsBehaviour pkg_descr+      then fmap concat $+        forM (targetBuildDepends bi) $+          \(Dependency name _ sublibs) -> do+            case Map.lookup name lib_dep_map of+              Nothing ->+                dieProgress $+                  text "Dependency on unbuildable"+                    <+> text "package"+                    <+> pretty name+              Just pkg -> do+                -- Return all library components+                forM (NonEmptySet.toList sublibs) $ \lib ->+                  let comp = CLibName lib+                   in case Map.lookup comp pkg of                         Nothing ->-                            dieProgress $-                                text "Dependency on unbuildable" <+>-                                text "package" <+> pretty name-                        Just p -> return p-                    -- Return all library components-                    forM (NonEmptySet.toList sublibs) $ \lib ->-                        let comp = CLibName lib in-                        case Map.lookup comp pkg of-                            Nothing ->-                                dieProgress $-                                    text "Dependency on unbuildable" <+>-                                    text (showLibraryName lib) <+>-                                    text "from" <+> pretty name-                            Just v -> return v-            else return old_style_lib_deps-    mkConfiguredComponent-       pkg_descr this_cid-       lib_deps exe_deps component+                          dieProgress $+                            text "Dependency on unbuildable"+                              <+> text (showLibraryName lib)+                              <+> text "from"+                              <+> pretty name+                        Just v -> return v+      else return old_style_lib_deps+  mkConfiguredComponent+    pkg_descr+    this_cid+    lib_deps+    exe_deps+    component   where     bi = componentBuildInfo component     -- lib_dep_map contains a mix of internal and external deps.@@ -206,62 +216,84 @@     -- this is not supported by old-style deps behavior     -- because it would imply a cyclic dependency for the     -- library itself.-    old_style_lib_deps = [ e-                         | (pn, comp_map) <- Map.toList lib_dep_map-                         , pn /= packageName pkg_descr-                         , (cn, e) <- Map.toList comp_map-                         , cn == CLibName LMainLibName ]+    old_style_lib_deps =+      [ e+      | (pn, comp_map) <- Map.toList lib_dep_map+      , pn /= packageName pkg_descr+      , (cn, e) <- Map.toList comp_map+      , cn == CLibName LMainLibName+      ]     -- We have to nub here, because 'getAllToolDependencies' may return     -- duplicates (see #4986).  (NB: This is not needed for lib_deps,     -- since those elaborate into includes, for which there explicitly     -- may be multiple instances of a package)-    exe_deps = ordNub $+    exe_deps =+      ordNub $         [ exe         | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi-        -- The error suppression here is important, because in general+        , -- The error suppression here is important, because in general         -- we won't know about external dependencies (e.g., 'happy')         -- which the package is attempting to use (those deps are only         -- fed in when cabal-install uses this codepath.)         -- TODO: Let cabal-install request errors here-        , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map]+        Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map]         ]  -- | Also computes the 'ComponentId', and sets cc_public if necessary. -- This is Cabal-only; cabal-install won't use this. toConfiguredComponent'-    :: Bool -- use_external_internal_deps-    -> FlagAssignment-    -> PackageDescription-    -> Bool -- deterministic-    -> Flag String      -- configIPID (todo: remove me)-    -> Flag ComponentId -- configCID-    -> ConfiguredComponentMap-    -> Component-    -> LogProgress ConfiguredComponent-toConfiguredComponent' use_external_internal_deps flags-                pkg_descr deterministic ipid_flag cid_flag-                dep_map component = do-    cc <- toConfiguredComponent-                pkg_descr this_cid-                dep_map dep_map component-    return $ if use_external_internal_deps-                then cc { cc_public = True }-                else cc-  where-    -- TODO: pass component names to it too!-    this_cid = computeComponentId deterministic ipid_flag cid_flag-                (package pkg_descr) (componentName component) (Just (deps, flags))-    deps = [ ann_id aid | m <- Map.elems dep_map-                        , aid <- Map.elems m ]+  :: Bool -- use_external_internal_deps+  -> FlagAssignment+  -> PackageDescription+  -> Bool -- deterministic+  -> Flag String -- configIPID (todo: remove me)+  -> Flag ComponentId -- configCID+  -> ConfiguredComponentMap+  -> Component+  -> LogProgress ConfiguredComponent+toConfiguredComponent'+  use_external_internal_deps+  flags+  pkg_descr+  deterministic+  ipid_flag+  cid_flag+  dep_map+  component = do+    cc <-+      toConfiguredComponent+        pkg_descr+        this_cid+        dep_map+        dep_map+        component+    return $+      if use_external_internal_deps+        then cc{cc_public = True}+        else cc+    where+      -- TODO: pass component names to it too!+      this_cid =+        computeComponentId+          deterministic+          ipid_flag+          cid_flag+          (package pkg_descr)+          (componentName component)+          (Just (deps, flags))+      deps =+        [ ann_id aid | m <- Map.elems dep_map, aid <- Map.elems m+        ]  extendConfiguredComponentMap-    :: ConfiguredComponent-    -> ConfiguredComponentMap-    -> ConfiguredComponentMap+  :: ConfiguredComponent+  -> ConfiguredComponentMap+  -> ConfiguredComponentMap extendConfiguredComponentMap cc =-    Map.insertWith Map.union-        (pkgName (cc_pkgid cc))-        (Map.singleton (cc_name cc) (cc_ann_id cc))+  Map.insertWith+    Map.union+    (pkgName (cc_pkgid cc))+    (Map.singleton (cc_name cc) (cc_ann_id cc))  -- Compute the 'ComponentId's for a graph of 'Component's.  The -- list of internal components must be topologically sorted@@ -273,31 +305,42 @@ -- be used to configure a component that depends on one version of a package for -- a library and another version for a build-tool. toConfiguredComponents-    :: Bool -- use_external_internal_deps-    -> FlagAssignment-    -> Bool -- deterministic-    -> Flag String -- configIPID-    -> Flag ComponentId -- configCID-    -> PackageDescription-    -> ConfiguredComponentMap-    -> [Component]-    -> LogProgress [ConfiguredComponent]+  :: Bool -- use_external_internal_deps+  -> FlagAssignment+  -> Bool -- deterministic+  -> Flag String -- configIPID+  -> Flag ComponentId -- configCID+  -> PackageDescription+  -> ConfiguredComponentMap+  -> [Component]+  -> LogProgress [ConfiguredComponent] toConfiguredComponents-    use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr-    dep_map comps-    = fmap snd (mapAccumM go dep_map comps)-  where-    go m component = do-        cc <- toConfiguredComponent'-                        use_external_internal_deps flags pkg_descr-                        deterministic ipid_flag cid_flag-                        m component+  use_external_internal_deps+  flags+  deterministic+  ipid_flag+  cid_flag+  pkg_descr+  dep_map+  comps =+    fmap snd (mapAccumM go dep_map comps)+    where+      go m component = do+        cc <-+          toConfiguredComponent'+            use_external_internal_deps+            flags+            pkg_descr+            deterministic+            ipid_flag+            cid_flag+            m+            component         return (extendConfiguredComponentMap cc m, cc)  newPackageDepsBehaviourMinVersion :: CabalSpecVersion newPackageDepsBehaviourMinVersion = CabalSpecV1_8 - -- In older cabal versions, there was only one set of package dependencies for -- the whole package. In this version, we can have separate dependencies per -- target, but we only enable this behaviour if the minimum cabal version@@ -305,4 +348,4 @@ -- old behaviour. newPackageDepsBehaviour :: PackageDescription -> Bool newPackageDepsBehaviour pkg =-   specVersion pkg >= newPackageDepsBehaviourMinVersion+  specVersion pkg >= newPackageDepsBehaviourMinVersion

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types       #-}+{-# LANGUAGE Rank2Types #-}+ module Distribution.Backpack.DescribeUnitId where  import Distribution.Compat.Prelude@@ -36,26 +37,36 @@ -- | Print a Setup message stating (1) what operation we are doing, -- for (2) which component (with enough details to uniquely identify -- the build in question.)----setupMessage' :: Pretty a => Verbosity-             -> String            -- ^ Operation being done (capitalized), on:-             -> PackageIdentifier -- ^ Package-             -> ComponentName     -- ^ Component name-             -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available.-                                        -- Polymorphic to take-                                        -- 'OpenModule' or 'Module'-             -> IO ()+setupMessage'+  :: Pretty a+  => Verbosity+  -> String+  -- ^ Operation being done (capitalized), on:+  -> PackageIdentifier+  -- ^ Package+  -> ComponentName+  -- ^ Component name+  -> Maybe [(ModuleName, a)]+  -- ^ Instantiation, if available.+  -- Polymorphic to take+  -- 'OpenModule' or 'Module'+  -> IO () setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do-    noticeDoc verbosity $-      case mb_insts of-        Just insts | not (null insts) ->-          hang (msg_doc <+> text "instantiated with") 2-               (vcat [ pretty k <+> text "=" <+> pretty v-                     | (k,v) <- insts ]) $$-          for_doc-        _ ->-          msg_doc <+> for_doc-+  noticeDoc verbosity $+    case mb_insts of+      Just insts+        | not (null insts) ->+            hang+              (msg_doc <+> text "instantiated with")+              2+              ( vcat+                  [ pretty k <+> text "=" <+> pretty v+                  | (k, v) <- insts+                  ]+              )+              $$ for_doc+      _ ->+        msg_doc <+> for_doc   where     msg_doc = text msg <+> text (showComponentName cname)-    for_doc = text "for" <+> pretty pkgid <<>> text ".."+    for_doc = text "for" <+> pretty pkgid <<>> text "..."

@@ -1,26 +1,27 @@ {-# LANGUAGE DeriveGeneric #-}-module Distribution.Backpack.FullUnitId (-    FullUnitId(..),-    FullDb,-    expandOpenUnitId,-    expandUnitId-) where +module Distribution.Backpack.FullUnitId+  ( FullUnitId (..)+  , FullDb+  , expandOpenUnitId+  , expandUnitId+  ) where+ import Distribution.Backpack-import Distribution.Types.ComponentId import Distribution.Compat.Prelude+import Distribution.Types.ComponentId  -- Unlike OpenUnitId, which could direct to a UnitId. data FullUnitId = FullUnitId ComponentId OpenModuleSubst-    deriving (Show, Generic)+  deriving (Show, Generic)  type FullDb = DefUnitId -> FullUnitId  expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId-expandOpenUnitId _db (IndefFullUnitId cid subst)-    = FullUnitId cid subst-expandOpenUnitId db (DefiniteUnitId uid)-    = expandUnitId db uid+expandOpenUnitId _db (IndefFullUnitId cid subst) =+  FullUnitId cid subst+expandOpenUnitId db (DefiniteUnitId uid) =+  expandUnitId db uid  expandUnitId :: FullDb -> DefUnitId -> FullUnitId expandUnitId db uid = db uid

@@ -1,74 +1,86 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.Id(-    computeComponentId,-    computeCompatPackageKey,-) where+module Distribution.Backpack.Id+  ( computeComponentId+  , computeCompatPackageKey+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Types.UnqualComponentName-import Distribution.Simple.Compiler import Distribution.PackageDescription-import Distribution.Simple.Setup as Setup+import Distribution.Simple.Compiler+import Distribution.Simple.Flag (Flag (..)) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentId-import Distribution.Types.UnitId import Distribution.Types.MungedPackageName+import Distribution.Types.UnitId import Distribution.Utils.Base62 import Distribution.Version +import Distribution.Parsec (simpleParsec) import Distribution.Pretty-    ( prettyShow )-import Distribution.Parsec ( simpleParsec )+  ( prettyShow+  )  -- | This method computes a default, "good enough" 'ComponentId' -- for a package.  The intent is that cabal-install (or the user) will -- specify a more detailed IPID via the @--ipid@ flag if necessary. computeComponentId-    :: Bool -- deterministic mode-    -> Flag String-    -> Flag ComponentId-    -> PackageIdentifier-    -> ComponentName-    -- This is used by cabal-install's legacy codepath-    -> Maybe ([ComponentId], FlagAssignment)-    -> ComponentId+  :: Bool -- deterministic mode+  -> Flag String+  -> Flag ComponentId+  -> PackageIdentifier+  -> ComponentName+  -- This is used by cabal-install's legacy codepath+  -> Maybe ([ComponentId], FlagAssignment)+  -> ComponentId computeComponentId deterministic mb_ipid mb_cid pid cname mb_details =-    -- show is found to be faster than intercalate and then replacement of-    -- special character used in intercalating. We cannot simply hash by-    -- doubly concatenating list, as it just flatten out the nested list, so-    -- different sources can produce same hash-    let hash_suffix-            | Just (dep_ipids, flags) <- mb_details-            = "-" ++ hashToBase62+  -- show is found to be faster than intercalate and then replacement of+  -- special character used in intercalating. We cannot simply hash by+  -- doubly concatenating list, as it just flatten out the nested list, so+  -- different sources can produce same hash+  let hash_suffix+        | Just (dep_ipids, flags) <- mb_details =+            "-"+              ++ hashToBase62                 -- For safety, include the package + version here                 -- for GHC 7.10, where just the hash is used as                 -- the package key-                    (    prettyShow pid-                      ++ show dep_ipids-                      ++ show flags     )-            | otherwise = ""-        generated_base = prettyShow pid ++ hash_suffix-        explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env-                                                    (toPathTemplate cid0))-            -- Hack to reuse install dirs machinery-            -- NB: no real IPID available at this point-          where env = packageTemplateEnv pid (mkUnitId "")-        actual_base = case mb_ipid of-                        Flag ipid0 -> explicit_base ipid0-                        NoFlag | deterministic -> prettyShow pid-                               | otherwise     -> generated_base-    in case mb_cid of-          Flag cid -> cid-          NoFlag -> mkComponentId $ actual_base-                        ++ (case componentNameString cname of-                                Nothing -> ""-                                Just s -> "-" ++ unUnqualComponentName s)+                ( prettyShow pid+                    ++ show dep_ipids+                    ++ show flags+                )+        | otherwise = ""+      generated_base = prettyShow pid ++ hash_suffix+      explicit_base cid0 =+        fromPathTemplate+          ( InstallDirs.substPathTemplate+              env+              (toPathTemplate cid0)+          )+        where+          -- Hack to reuse install dirs machinery+          -- NB: no real IPID available at this point+          env = packageTemplateEnv pid (mkUnitId "")+      actual_base = case mb_ipid of+        Flag ipid0 -> explicit_base ipid0+        NoFlag+          | deterministic -> prettyShow pid+          | otherwise -> generated_base+   in case mb_cid of+        Flag cid -> cid+        NoFlag ->+          mkComponentId $+            actual_base+              ++ ( case componentNameString cname of+                    Nothing -> ""+                    Just s -> "-" ++ unUnqualComponentName s+                 )  -- | In GHC 8.0, the string we pass to GHC to use for symbol -- names for a package can be an arbitrary, IPID-compatible string.@@ -116,30 +128,29 @@ -- --      * For sub-components, we rehash the IPID into the correct format --        and pass that.--- computeCompatPackageKey-    :: Compiler-    -> MungedPackageName-    -> Version-    -> UnitId-    -> String+  :: Compiler+  -> MungedPackageName+  -> Version+  -> UnitId+  -> String computeCompatPackageKey comp pkg_name pkg_version uid-    | not (packageKeySupported comp || unitIdSupported comp)-    = prettyShow pkg_name ++ "-" ++ prettyShow pkg_version-    | not (unifiedIPIDRequired comp) =-        let str = unUnitId uid -- assume no Backpack support-            mb_verbatim_key-                = case simpleParsec str :: Maybe PackageId of-                    -- Something like 'foo-0.1', use it verbatim.-                    -- (NB: hash tags look like tags, so they are parsed,-                    -- so the extra equality check tests if a tag was dropped.)-                    Just pid0 | prettyShow pid0 == str -> Just str-                    _ -> Nothing-            mb_truncated_key-                = let cand = reverse (takeWhile isAlphaNum (reverse str))-                  in if length cand == 22 && all isAlphaNum cand-                        then Just cand-                        else Nothing-            rehashed_key = hashToBase62 str-        in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)-    | otherwise = prettyShow uid+  | not (packageKeySupported comp || unitIdSupported comp) =+      prettyShow pkg_name ++ "-" ++ prettyShow pkg_version+  | not (unifiedIPIDRequired comp) =+      let str = unUnitId uid -- assume no Backpack support+          mb_verbatim_key =+            case simpleParsec str :: Maybe PackageId of+              -- Something like 'foo-0.1', use it verbatim.+              -- (NB: hash tags look like tags, so they are parsed,+              -- so the extra equality check tests if a tag was dropped.)+              Just pid0 | prettyShow pid0 == str -> Just str+              _ -> Nothing+          mb_truncated_key =+            let cand = reverse (takeWhile isAlphaNum (reverse str))+             in if length cand == 22 && all isAlphaNum cand+                  then Just cand+                  else Nothing+          rehashed_key = hashToBase62 str+       in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)+  | otherwise = prettyShow uid

@@ -1,82 +1,76 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.LinkedComponent (-    LinkedComponent(..),-    lc_insts,-    lc_uid,-    lc_cid,-    lc_pkgid,-    toLinkedComponent,-    toLinkedComponents,-    dispLinkedComponent,-    LinkedComponentMap,-    extendLinkedComponentMap,-) where+module Distribution.Backpack.LinkedComponent+  ( LinkedComponent (..)+  , lc_insts+  , lc_uid+  , lc_cid+  , lc_pkgid+  , toLinkedComponent+  , toLinkedComponents+  , dispLinkedComponent+  , LinkedComponentMap+  , extendLinkedComponentMap+  ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()  import Distribution.Backpack-import Distribution.Backpack.FullUnitId import Distribution.Backpack.ConfiguredComponent+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.MixLink+import Distribution.Backpack.ModuleScope import Distribution.Backpack.ModuleShape import Distribution.Backpack.PreModuleShape-import Distribution.Backpack.ModuleScope import Distribution.Backpack.UnifyM-import Distribution.Backpack.MixLink import Distribution.Utils.MapAccum -import Distribution.Types.AnnotatedId-import Distribution.Types.ComponentName-import Distribution.Types.ModuleReexport-import Distribution.Types.ModuleRenaming-import Distribution.Types.IncludeRenaming-import Distribution.Types.ComponentInclude-import Distribution.Types.ComponentId-import Distribution.Types.PackageId+import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription-import Distribution.ModuleName import Distribution.Simple.LocalBuildInfo-import Distribution.Verbosity+import Distribution.Types.AnnotatedId+import Distribution.Types.ComponentInclude import Distribution.Utils.LogProgress+import Distribution.Verbosity -import qualified Data.Set as Set import qualified Data.Map as Map+import qualified Data.Set as Set import Distribution.Pretty (pretty)-import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes)+import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($+$))  -- | A linked component is a component that has been mix-in linked, at -- which point we have determined how all the dependencies of the -- component are explicitly instantiated (in the form of an OpenUnitId). -- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which -- is then instantiated into 'ReadyComponent'.-data LinkedComponent-    = LinkedComponent {-        -- | Uniquely identifies linked component-        lc_ann_id :: AnnotatedId ComponentId,-        -- | Corresponds to 'cc_component'.-        lc_component :: Component,-        -- | @build-tools@ and @build-tool-depends@ dependencies.-        -- Corresponds to 'cc_exe_deps'.-        lc_exe_deps :: [AnnotatedId OpenUnitId],-        -- | Is this the public library of a package?  Corresponds to-        -- 'cc_public'.-        lc_public :: Bool,-        -- | Corresponds to 'cc_includes', but (1) this does not contain-        -- includes of signature packages (packages with no exports),-        -- and (2) the 'ModuleRenaming' for requirements (stored in-        -- 'IncludeRenaming') has been removed, as it is reflected in-        -- 'OpenUnitId'.)-        lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming],-        -- | Like 'lc_includes', but this specifies includes on-        -- signature packages which have no exports.-        lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming],-        -- | The module shape computed by mix-in linking.  This is-        -- newly computed from 'ConfiguredComponent'-        lc_shape :: ModuleShape-      }+data LinkedComponent = LinkedComponent+  { lc_ann_id :: AnnotatedId ComponentId+  -- ^ Uniquely identifies linked component+  , lc_component :: Component+  -- ^ Corresponds to 'cc_component'.+  , lc_exe_deps :: [AnnotatedId OpenUnitId]+  -- ^ @build-tools@ and @build-tool-depends@ dependencies.+  -- Corresponds to 'cc_exe_deps'.+  , lc_public :: Bool+  -- ^ Is this the public library of a package?  Corresponds to+  -- 'cc_public'.+  , lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]+  -- ^ Corresponds to 'cc_includes', but (1) this does not contain+  -- includes of signature packages (packages with no exports),+  -- and (2) the 'ModuleRenaming' for requirements (stored in+  -- 'IncludeRenaming') has been removed, as it is reflected in+  -- 'OpenUnitId'.)+  , lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming]+  -- ^ Like 'lc_includes', but this specifies includes on+  -- signature packages which have no exports.+  , lc_shape :: ModuleShape+  -- ^ The module shape computed by mix-in linking.  This is+  -- newly computed from 'ConfiguredComponent'+  }  -- | Uniquely identifies a 'LinkedComponent'.  Corresponds to -- 'cc_cid'.@@ -96,94 +90,125 @@ -- | The instantiation of 'lc_uid'; this always has the invariant -- that it is a mapping from a module name @A@ to @<A>@ (the hole A). lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)]-lc_insts lc = [ (req, OpenModuleVar req)-              | req <- Set.toList (modShapeRequires (lc_shape lc)) ]+lc_insts lc =+  [ (req, OpenModuleVar req)+  | req <- Set.toList (modShapeRequires (lc_shape lc))+  ]  dispLinkedComponent :: LinkedComponent -> Doc dispLinkedComponent lc =-    hang (text "unit" <+> pretty (lc_uid lc)) 4 $-         vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl)-              | incl <- lc_includes lc ]-            $+$-         vcat [ text "signature include" <+> pretty (ci_id incl)-              | incl <- lc_sig_includes lc ]-            $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc))+  hang (text "unit" <+> pretty (lc_uid lc)) 4 $+    vcat+      [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl)+      | incl <- lc_includes lc+      ]+      $+$ vcat+        [ text "signature include" <+> pretty (ci_id incl)+        | incl <- lc_sig_includes lc+        ]+      $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc))  instance Package LinkedComponent where-    packageId = lc_pkgid+  packageId = lc_pkgid  toLinkedComponent-    :: Verbosity-    -> FullDb-    -> PackageId-    -> LinkedComponentMap-    -> ConfiguredComponent-    -> LogProgress LinkedComponent-toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {-    cc_ann_id = aid@AnnotatedId { ann_id = this_cid },-    cc_component = component,-    cc_exe_deps = exe_deps,-    cc_public = is_public,-    cc_includes = cid_includes-   } = do+  :: Verbosity+  -> Bool+  -- ^ Whether there are any "promised" package dependencies which we won't find already installed.+  -> FullDb+  -> PackageId+  -> LinkedComponentMap+  -> ConfiguredComponent+  -> LogProgress LinkedComponent+toLinkedComponent+  verbosity+  anyPromised+  db+  this_pid+  pkg_map+  ConfiguredComponent+    { cc_ann_id = aid@AnnotatedId{ann_id = this_cid}+    , cc_component = component+    , cc_exe_deps = exe_deps+    , cc_public = is_public+    , cc_includes = cid_includes+    } = do     let-        -- The explicitly specified requirements, provisions and-        -- reexports from the Cabal file.  These are only non-empty for-        -- libraries; everything else is trivial.-        (src_reqs      :: [ModuleName],-         src_provs     :: [ModuleName],-         src_reexports :: [ModuleReexport]) =-            case component of-                CLib lib -> (signatures lib,-                             exposedModules lib,-                             reexportedModules lib)-                _ -> ([], [], [])-        src_hidden = otherModules (componentBuildInfo component)+      -- The explicitly specified requirements, provisions and+      -- reexports from the Cabal file.  These are only non-empty for+      -- libraries; everything else is trivial.+      ( src_reqs :: [ModuleName]+        , src_provs :: [ModuleName]+        , src_reexports :: [ModuleReexport]+        ) =+          case component of+            CLib lib ->+              ( signatures lib+              , exposedModules lib+              , reexportedModules lib+              )+            _ -> ([], [], [])+      src_hidden = otherModules (componentBuildInfo component) -        -- Take each included ComponentId and resolve it into an-        -- *unlinked* unit identity.  We will use unification (relying-        -- on the ModuleShape) to resolve these into linked identities.-        unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]-        unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i-                            | ComponentInclude dep_aid rns i <- cid_includes ]+      -- Take each included ComponentId and resolve it into an+      -- \*unlinked* unit identity.  We will use unification (relying+      -- on the ModuleShape) to resolve these into linked identities.+      unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]+      unlinked_includes =+        [ ComponentInclude (fmap lookupUid dep_aid) rns i+        | ComponentInclude dep_aid rns i <- cid_includes+        ] -        lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)-        lookupUid cid = fromMaybe (error "linkComponent: lookupUid")-                                    (Map.lookup cid pkg_map)+      lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)+      lookupUid cid =+        fromMaybe+          (error "linkComponent: lookupUid")+          (Map.lookup cid pkg_map)      let orErr (Right x) = return x         orErr (Left [err]) = dieProgress err         orErr (Left errs) = do-            dieProgress (vcat (intersperse (text "") -- double newline!-                                [ hang (text "-") 2 err | err <- errs]))+          dieProgress+            ( vcat+                ( intersperse+                    (text "") -- double newline!+                    [hang (text "-") 2 err | err <- errs]+                )+            )      -- Pre-shaping-    let pre_shape = mixLinkPreModuleShape $-            PreModuleShape {-                preModShapeProvides = Set.fromList (src_provs ++ src_hidden),-                preModShapeRequires = Set.fromList src_reqs-            } : [ renamePreModuleShape (toPreModuleShape sh) rns-                | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ]-        reqs  = preModShapeRequires pre_shape-        insts = [ (req, OpenModuleVar req)-                | req <- Set.toList reqs ]+    let pre_shape =+          mixLinkPreModuleShape $+            PreModuleShape+              { preModShapeProvides = Set.fromList (src_provs ++ src_hidden)+              , preModShapeRequires = Set.fromList src_reqs+              }+              : [ renamePreModuleShape (toPreModuleShape sh) rns+                | ComponentInclude (AnnotatedId{ann_id = (_, sh)}) rns _ <- unlinked_includes+                ]+        reqs = preModShapeRequires pre_shape+        insts =+          [ (req, OpenModuleVar req)+          | req <- Set.toList reqs+          ]         this_uid = IndefFullUnitId this_cid . Map.fromList $ insts      -- OK, actually do unification     -- TODO: the unification monad might return errors, in which     -- case we have to deal.  Use monadic bind for now.-    (linked_shape0  :: ModuleScope,-     linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming],-     linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming])-      <- orErr $ runUnifyM verbosity this_cid db $ do+    ( linked_shape0 :: ModuleScope+      , linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]+      , linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]+      ) <-+      orErr $ runUnifyM verbosity this_cid db $ do         -- The unification monad is implemented using mutable         -- references.  Thus, we must convert our *pure* data         -- structures into mutable ones to perform unification.          let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s)             convertMod from m = do-                m_u <- convertModule (OpenModule this_uid m)-                return (Map.singleton m [WithSource (from m) m_u], Map.empty)+              m_u <- convertModule (OpenModule this_uid m)+              return (Map.singleton m [WithSource (from m) m_u], Map.empty)         -- Handle 'exposed-modules'         exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs         -- Handle 'other-modules'@@ -192,8 +217,8 @@         -- Handle 'signatures'         let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)             convertReq req = do-                req_u <- convertModule (OpenModuleVar req)-                return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u])+              req_u <- convertModule (OpenModuleVar req)+              return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u])         req_shapes_u <- traverse convertReq src_reqs          -- Handle 'mixins'@@ -201,22 +226,26 @@          failIfErrs -- Prevent error cascade         -- Mix-in link everything!  mixLink is the real workhorse.-        shape_u <- mixLink $ exposed_mod_shapes_u-                          ++ other_mod_shapes_u-                          ++ req_shapes_u-                          ++ incl_shapes_u+        shape_u <-+          mixLink $+            exposed_mod_shapes_u+              ++ other_mod_shapes_u+              ++ req_shapes_u+              ++ incl_shapes_u          -- src_reqs_u <- traverse convertReq src_reqs         -- Read out all the final results by converting back         -- into a pure representation.         let convertIncludeU (ComponentInclude dep_aid rns i) = do-                let component_name = pretty $ ann_cname dep_aid-                uid <- convertUnitIdU (ann_id dep_aid) component_name-                return (ComponentInclude {-                        ci_ann_id = dep_aid { ann_id = uid },-                        ci_renaming = rns,-                        ci_implicit = i-                    })+              let component_name = pretty $ ann_cname dep_aid+              uid <- convertUnitIdU (ann_id dep_aid) component_name+              return+                ( ComponentInclude+                    { ci_ann_id = dep_aid{ann_id = uid}+                    , ci_renaming = rns+                    , ci_implicit = i+                    }+                )          shape <- convertModuleScopeU shape_u         let (includes_u, sig_includes_u) = partitionEithers all_includes_u@@ -225,23 +254,26 @@         return (shape, incls, sig_incls)      let isNotLib (CLib _) = False-        isNotLib _        = True+        isNotLib _ = True     when (not (Set.null reqs) && isNotLib component) $-        dieProgress $-            hang (text "Non-library component has unfilled requirements:")-                4 (vcat [pretty req | req <- Set.toList reqs])+      dieProgress $+        hang+          (text "Non-library component has unfilled requirements:")+          4+          (vcat [pretty req | req <- Set.toList reqs])      -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg     -- won't allow it (since someone could directly synthesize     -- an 'InstalledPackageInfo' that violates abstraction.)     -- Though, maybe it should be relaxed?     let src_hidden_set = Set.fromList src_hidden-        linked_shape = linked_shape0 {-            modScopeProvides =+        linked_shape =+          linked_shape0+            { modScopeProvides =                 -- Would rather use withoutKeys but need BC                 Map.filterWithKey-                    (\k _ -> not (k `Set.member` src_hidden_set))-                    (modScopeProvides linked_shape0)+                  (\k _ -> not (k `Set.member` src_hidden_set))+                  (modScopeProvides linked_shape0)             }      -- OK, compute the reexports@@ -250,65 +282,102 @@     -- once.     let hdl :: [Either Doc a] -> LogProgress [a]         hdl es =-            case partitionEithers es of-                ([], rs) -> return rs-                (ls, _) ->-                    dieProgress $-                     hang (text "Problem with module re-exports:") 2-                        (vcat [hang (text "-") 2 l | l <- ls])+          case partitionEithers es of+            ([], rs) -> return rs+            (ls, _) ->+              dieProgress $+                hang+                  (text "Problem with module re-exports:")+                  2+                  (vcat [hang (text "-") 2 l | l <- ls])     reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do       case Map.lookup from (modScopeProvides linked_shape) of-        Just cands@(x0:xs0) -> do+        Just cands@(x0 : xs0) -> do           -- Make sure there is at least one candidate           (x, xs) <-             case mb_pn of               Just pn ->-                let matches_pn (FromMixins pn' _ _)     = pn == pn'+                let matches_pn (FromMixins pn' _ _) = pn == pn'                     matches_pn (FromBuildDepends pn' _) = pn == pn'                     matches_pn (FromExposedModules _) = pn == packageName this_pid-                    matches_pn (FromOtherModules _)   = pn == packageName this_pid-                    matches_pn (FromSignatures _)     = pn == packageName this_pid-                in case filter (matches_pn . getSource) cands of-                    (x1:xs1) -> return (x1, xs1)-                    _ -> Left (brokenReexportMsg reex)+                    matches_pn (FromOtherModules _) = pn == packageName this_pid+                    matches_pn (FromSignatures _) = pn == packageName this_pid+                 in case filter (matches_pn . getSource) cands of+                      (x1 : xs1) -> return (x1, xs1)+                      _ -> Left (brokenReexportMsg reex)               Nothing -> return (x0, xs0)           -- Test that all the candidates are consistent           case filter (\x' -> unWithSource x /= unWithSource x') xs of             [] -> return ()             _ -> Left $ ambiguousReexportMsg reex x xs-          return (to, unWithSource x)+          return (to, Just (unWithSource x))         _ ->-          Left (brokenReexportMsg reex)+          -- Can't resolve it right now.. carry on with the assumption it will be resolved+          -- dynamically later by an in-memory package which hasn't been installed yet.+          if anyPromised+            then return (to, Nothing)+            else -- But if nothing is promised, eagerly report an error, as we already know everything.+              Left (brokenReexportMsg reex)      -- TODO: maybe check this earlier; it's syntactically obvious.     let build_reexports m (k, v)-            | Map.member k m =-                dieProgress $ hsep-                    [ text "Module name ", pretty k, text " is exported multiple times." ]-            | otherwise = return (Map.insert k v m)-    provs <- foldM build_reexports Map.empty $-                -- TODO: doublecheck we have checked for-                -- src_provs duplicates already!-                [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++-                reexports_list+          | Map.member k m =+              dieProgress $+                hsep+                  [text "Module name ", pretty k, text " is exported multiple times."]+          | otherwise = return (Map.insert k v m)+    provs <-+      foldM build_reexports Map.empty $+        -- TODO: doublecheck we have checked for+        -- src_provs duplicates already!+        -- These are normal module exports.+        [(mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs]+          +++          -- These are reexports, which we managed to resolve to something in an external package.+          [(mn_new, om) | (mn_new, Just om) <- reexports_list]+          +++          -- These ones.. we didn't resolve but also we might not have to+          -- resolve them because they could come from a promised unit,+          -- which we don't know anything about yet. GHC will resolve+          -- these itself when it is dealing with the multi-session.+          -- These ones will not be built, registered and put+          -- into a package database, we only need them to make it as far+          -- as generating GHC options where the info will be used to+          -- pass the reexported-module option to GHC. +          -- We also know that in the case there are promised units that+          -- we will not be doing anything to do with backpack like+          -- unification etc..+          [ ( mod_name+            , OpenModule+                ( DefiniteUnitId+                    ( unsafeMkDefUnitId+                        (mkUnitId "fake")+                    )+                )+                mod_name+            )+          | (mod_name, Nothing) <- reexports_list+          ]+     let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape))      -- See Note Note [Signature package special case]     let (linked_includes, linked_sig_includes)-            | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, [])-            | otherwise     = (linked_includes0, linked_sig_includes0)+          | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, [])+          | otherwise = (linked_includes0, linked_sig_includes0) -    return $ LinkedComponent {-                lc_ann_id = aid,-                lc_component = component,-                lc_public = is_public,-                -- These must be executables-                lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps,-                lc_shape = final_linked_shape,-                lc_includes = linked_includes,-                lc_sig_includes = linked_sig_includes-           }+    return $+      LinkedComponent+        { lc_ann_id = aid+        , lc_component = component+        , lc_public = is_public+        , -- These must be executables+          lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps+        , lc_shape = final_linked_shape+        , lc_includes = linked_includes+        , lc_sig_includes = linked_sig_includes+        }  -- Note [Signature package special case] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -336,63 +405,82 @@ -- Handle mix-in linking for components.  In the absence of Backpack, -- every ComponentId gets converted into a UnitId by way of SimpleUnitId. toLinkedComponents-    :: Verbosity-    -> FullDb-    -> PackageId-    -> LinkedComponentMap-    -> [ConfiguredComponent]-    -> LogProgress [LinkedComponent]-toLinkedComponents verbosity db this_pid lc_map0 comps-   = fmap snd (mapAccumM go lc_map0 comps)- where-  go :: Map ComponentId (OpenUnitId, ModuleShape)-     -> ConfiguredComponent-     -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)-  go lc_map cc = do-    lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $-            toLinkedComponent verbosity db this_pid lc_map cc-    return (extendLinkedComponentMap lc lc_map, lc)+  :: Verbosity+  -> Bool+  -- ^ Whether there are any "promised" package dependencies which we won't+  -- find already installed.+  -> FullDb+  -> PackageId+  -> LinkedComponentMap+  -> [ConfiguredComponent]+  -> LogProgress [LinkedComponent]+toLinkedComponents verbosity anyPromised db this_pid lc_map0 comps =+  fmap snd (mapAccumM go lc_map0 comps)+  where+    go+      :: Map ComponentId (OpenUnitId, ModuleShape)+      -> ConfiguredComponent+      -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)+    go lc_map cc = do+      lc <-+        addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $+          toLinkedComponent verbosity anyPromised db this_pid lc_map cc+      return (extendLinkedComponentMap lc lc_map, lc)  type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) -extendLinkedComponentMap :: LinkedComponent-                         -> LinkedComponentMap-                         -> LinkedComponentMap+extendLinkedComponentMap+  :: LinkedComponent+  -> LinkedComponentMap+  -> LinkedComponentMap extendLinkedComponentMap lc m =-    Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m+  Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m  brokenReexportMsg :: ModuleReexport -> Doc brokenReexportMsg (ModuleReexport (Just pn) from _to) =-  vcat [ text "The package" <+> quotes (pretty pn)-       , text "does not export a module" <+> quotes (pretty from) ]+  vcat+    [ text "The package" <+> quotes (pretty pn)+    , text "does not export a module" <+> quotes (pretty from)+    ] brokenReexportMsg (ModuleReexport Nothing from _to) =-  vcat [ text "The module" <+> quotes (pretty from)-       , text "is not exported by any suitable package."-       , text "It occurs in neither the 'exposed-modules' of this package,"-       , text "nor any of its 'build-depends' dependencies." ]+  vcat+    [ text "The module" <+> quotes (pretty from)+    , text "is not exported by any suitable package."+    , text "It occurs in neither the 'exposed-modules' of this package,"+    , text "nor any of its 'build-depends' dependencies."+    ]  ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys =-  vcat [ text "Ambiguous reexport" <+> quotes (pretty from)-       , hang (text "It could refer to either:") 2-            (vcat (msg : msgs))-       , help_msg mb_pn ]+  vcat+    [ text "Ambiguous reexport" <+> quotes (pretty from)+    , hang+        (text "It could refer to either:")+        2+        (vcat (msg : msgs))+    , help_msg mb_pn+    ]   where-    msg  = text "  " <+> displayModuleWithSource y1+    msg = text "  " <+> displayModuleWithSource y1     msgs = [text "or" <+> displayModuleWithSource y | y <- ys]     help_msg Nothing =       -- TODO: This advice doesn't help if the ambiguous exports       -- come from a package named the same thing-      vcat [ text "The ambiguity can be resolved by qualifying the"-           , text "re-export with a package name."-           , text "The syntax is 'packagename:ModuleName [as NewName]'." ]+      vcat+        [ text "The ambiguity can be resolved by qualifying the"+        , text "re-export with a package name."+        , text "The syntax is 'packagename:ModuleName [as NewName]'."+        ]     -- Qualifying won't help that much.     help_msg (Just _) =-      vcat [ text "The ambiguity can be resolved by using the"-           , text "mixins field to rename one of the module"-           , text "names differently." ]-    displayModuleWithSource y-      = vcat [ quotes (pretty (unWithSource y))-             , text "brought into scope by" <+>-                dispModuleSource (getSource y)-             ]+      vcat+        [ text "The ambiguity can be resolved by using the"+        , text "mixins field to rename one of the module"+        , text "names differently."+        ]+    displayModuleWithSource y =+      vcat+        [ quotes (pretty (unWithSource y))+        , text "brought into scope by"+            <+> dispModuleSource (getSource y)+        ]

@@ -1,26 +1,27 @@ {-# LANGUAGE NondecreasingIndentation #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.MixLink (-    mixLink,-) where+module Distribution.Backpack.MixLink+  ( mixLink+  ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod)+import Prelude ()  import Distribution.Backpack-import Distribution.Backpack.UnifyM import Distribution.Backpack.FullUnitId import Distribution.Backpack.ModuleScope+import Distribution.Backpack.UnifyM -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Pretty import Distribution.Types.ComponentId+import qualified Distribution.Utils.UnionFind as UnionFind -import Text.PrettyPrint import Control.Monad-import qualified Data.Map as Map import qualified Data.Foldable as F+import qualified Data.Map as Map+import Text.PrettyPrint  ----------------------------------------------------------------------- -- Linking@@ -28,78 +29,98 @@ -- | Given to scopes of provisions and requirements, link them together. mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s) mixLink scopes = do-    let provs = Map.unionsWith (++) (map fst scopes)-        -- Invariant: any identically named holes refer to same mutable cell-        reqs  = Map.unionsWith (++) (map snd scopes)-        filled = Map.intersectionWithKey linkProvision provs reqs-    F.sequenceA_ filled-    let remaining = Map.difference reqs filled-    return (provs, remaining)+  let provs = Map.unionsWith (++) (map fst scopes)+      -- Invariant: any identically named holes refer to same mutable cell+      reqs = Map.unionsWith (++) (map snd scopes)+      filled = Map.intersectionWithKey linkProvision provs reqs+  F.sequenceA_ filled+  let remaining = Map.difference reqs filled+  return (provs, remaining)  -- | Link a list of possibly provided modules to a single -- requirement.  This applies a side-condition that all -- of the provided modules at the same name are *actually* -- the same module.-linkProvision :: ModuleName-              -> [ModuleWithSourceU s] -- provs-              -> [ModuleWithSourceU s] -- reqs-              -> UnifyM s [ModuleWithSourceU s]-linkProvision mod_name ret@(prov:provs) (req:reqs) = do-    -- TODO: coalesce all the non-unifying modules together-    forM_ provs $ \prov' -> do-        -- Careful: read it out BEFORE unifying, because the-        -- unification algorithm preemptively unifies modules-        mod  <- convertModuleU (unWithSource prov)-        mod' <- convertModuleU (unWithSource prov')-        r <- unify prov prov'-        case r of-            Just () -> return ()-            Nothing -> do-                addErr $-                  text "Ambiguous module" <+> quotes (pretty mod_name) $$-                  text "It could refer to" <+>-                    ( text "  " <+> (quotes (pretty mod)  $$ in_scope_by (getSource prov)) $$-                      text "or" <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) ) $$-                  link_doc+linkProvision+  :: ModuleName+  -> [ModuleWithSourceU s] -- provs+  -> [ModuleWithSourceU s] -- reqs+  -> UnifyM s [ModuleWithSourceU s]+linkProvision mod_name ret@(prov : provs) (req : reqs) = do+  -- TODO: coalesce all the non-unifying modules together+  forM_ provs $ \prov' -> do+    -- Careful: read it out BEFORE unifying, because the+    -- unification algorithm preemptively unifies modules     mod <- convertModuleU (unWithSource prov)-    req_mod <- convertModuleU (unWithSource req)-    self_cid <- fmap unify_self_cid getUnifEnv-    case mod of-      OpenModule (IndefFullUnitId cid _) _-        | cid == self_cid -> addErr $-            text "Cannot instantiate requirement" <+> quotes (pretty mod_name) <+>-                in_scope_by (getSource req) $$-            text "with locally defined module" <+> in_scope_by (getSource prov) $$-            text "as this would create a cyclic dependency, which GHC does not support." $$-            text "Try moving this module to a separate library, e.g.," $$-            text "create a new stanza: library 'sublib'."-      _ -> return ()-    r <- unify prov req+    mod' <- convertModuleU (unWithSource prov')+    r <- unify prov prov'     case r of-        Just () -> return ()-        Nothing -> do-            -- TODO: Record and report WHERE the bad constraint came from-            addErr $ text "Could not instantiate requirement" <+> quotes (pretty mod_name) $$-                     nest 4 (text "Expected:" <+> pretty mod $$-                             text "Actual:  " <+> pretty req_mod) $$-                     parens (text "This can occur if an exposed module of" <+>-                             text "a libraries shares a name with another module.") $$-                     link_doc-    return ret+      Just () -> return ()+      Nothing -> do+        addErr $+          text "Ambiguous module"+            <+> quotes (pretty mod_name)+            $$ text "It could refer to"+            <+> ( text "  "+                    <+> (quotes (pretty mod) $$ in_scope_by (getSource prov))+                    $$ text "or"+                    <+> (quotes (pretty mod') $$ in_scope_by (getSource prov'))+                )+            $$ link_doc+  mod <- convertModuleU (unWithSource prov)+  req_mod <- convertModuleU (unWithSource req)+  self_cid <- fmap unify_self_cid getUnifEnv+  case mod of+    OpenModule (IndefFullUnitId cid _) _+      | cid == self_cid ->+          addErr $+            text "Cannot instantiate requirement"+              <+> quotes (pretty mod_name)+              <+> in_scope_by (getSource req)+              $$ text "with locally defined module"+              <+> in_scope_by (getSource prov)+              $$ text "as this would create a cyclic dependency, which GHC does not support."+              $$ text "Try moving this module to a separate library, e.g.,"+              $$ text "create a new stanza: library 'sublib'."+    _ -> return ()+  r <- unify prov req+  case r of+    Just () -> return ()+    Nothing -> do+      -- TODO: Record and report WHERE the bad constraint came from+      addErr $+        text "Could not instantiate requirement"+          <+> quotes (pretty mod_name)+          $$ nest+            4+            ( text "Expected:"+                <+> pretty mod+                $$ text "Actual:  "+                <+> pretty req_mod+            )+          $$ parens+            ( text "This can occur if an exposed module of"+                <+> text "a libraries shares a name with another module."+            )+          $$ link_doc+  return ret   where-    unify s1 s2 = tryM $ addErrContext short_link_doc-                       $ unifyModule (unWithSource s1) (unWithSource s2)+    unify s1 s2 =+      tryM $+        addErrContext short_link_doc $+          unifyModule (unWithSource s1) (unWithSource s2)     in_scope_by s = text "brought into scope by" <+> dispModuleSource s     short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name)     link_doc = text "While filling requirements of" <+> reqs_doc     reqs_doc       | null reqs = dispModuleSource (getSource req)-      | otherwise =  (       text "   " <+> dispModuleSource (getSource req)  $$-                      vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs])+      | otherwise =+          ( text "   "+              <+> dispModuleSource (getSource req)+              $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs]+          ) linkProvision _ _ _ = error "linkProvision" -- ----------------------------------------------------------------------- -- The unification algorithm @@ -108,78 +129,93 @@  unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s () unifyUnitId uid1_u uid2_u-    | uid1_u == uid2_u = return ()-    | otherwise = do-        xuid1 <- liftST $ UnionFind.find uid1_u-        xuid2 <- liftST $ UnionFind.find uid2_u-        case (xuid1, xuid2) of-            (UnitIdThunkU u1, UnitIdThunkU u2)-                | u1 == u2  -> return ()-                | otherwise ->-                    failWith $ hang (text "Couldn't match unit IDs:") 4-                               (text "   " <+> pretty u1 $$-                                text "and" <+> pretty u2)-            (UnitIdThunkU uid1, UnitIdU _ cid2 insts2)-                -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u-            (UnitIdU _ cid1 insts1, UnitIdThunkU uid2)-                -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u-            (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2)-                -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u+  | uid1_u == uid2_u = return ()+  | otherwise = do+      xuid1 <- liftST $ UnionFind.find uid1_u+      xuid2 <- liftST $ UnionFind.find uid2_u+      case (xuid1, xuid2) of+        (UnitIdThunkU u1, UnitIdThunkU u2)+          | u1 == u2 -> return ()+          | otherwise ->+              failWith $+                hang+                  (text "Couldn't match unit IDs:")+                  4+                  ( text "   "+                      <+> pretty u1+                      $$ text "and"+                      <+> pretty u2+                  )+        (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) ->+          unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u+        (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) ->+          unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u+        (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) ->+          unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyThunkWith :: ComponentId-               -> Map ModuleName (ModuleU s)-               -> UnitIdU s-               -> DefUnitId-               -> UnitIdU s-               -> UnifyM s ()+unifyThunkWith+  :: ComponentId+  -> Map ModuleName (ModuleU s)+  -> UnitIdU s+  -> DefUnitId+  -> UnitIdU s+  -> UnifyM s () unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do-    db <- fmap unify_db getUnifEnv-    let FullUnitId cid2 insts2' = expandUnitId db uid2-    insts2 <- convertModuleSubst insts2'-    unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u+  db <- fmap unify_db getUnifEnv+  let FullUnitId cid2 insts2' = expandUnitId db uid2+  insts2 <- convertModuleSubst insts2'+  unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyInner :: ComponentId-           -> Map ModuleName (ModuleU s)-           -> UnitIdU s-           -> ComponentId-           -> Map ModuleName (ModuleU s)-           -> UnitIdU s-           -> UnifyM s ()+unifyInner+  :: ComponentId+  -> Map ModuleName (ModuleU s)+  -> UnitIdU s+  -> ComponentId+  -> Map ModuleName (ModuleU s)+  -> UnitIdU s+  -> UnifyM s () unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do-    when (cid1 /= cid2) $-        -- TODO: if we had a package identifier, could be an-        -- easier to understand error message.-        failWith $-            hang (text "Couldn't match component IDs:") 4-                 (text "   " <+> pretty cid1 $$-                  text "and" <+> pretty cid2)-    -- The KEY STEP which makes this a Huet-style unification-    -- algorithm.  (Also a payoff of using union-find.)-    -- We can build infinite unit IDs this way, which is necessary-    -- for support mutual recursion. NB: union keeps the SECOND-    -- descriptor, so we always arrange for a UnitIdThunkU to live-    -- there.-    liftST $ UnionFind.union uid1_u uid2_u-    F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2+  when (cid1 /= cid2) $+    -- TODO: if we had a package identifier, could be an+    -- easier to understand error message.+    failWith $+      hang+        (text "Couldn't match component IDs:")+        4+        ( text "   "+            <+> pretty cid1+            $$ text "and"+            <+> pretty cid2+        )+  -- The KEY STEP which makes this a Huet-style unification+  -- algorithm.  (Also a payoff of using union-find.)+  -- We can build infinite unit IDs this way, which is necessary+  -- for support mutual recursion. NB: union keeps the SECOND+  -- descriptor, so we always arrange for a UnitIdThunkU to live+  -- there.+  liftST $ UnionFind.union uid1_u uid2_u+  F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2  -- | Imperatively unify two modules. unifyModule :: ModuleU s -> ModuleU s -> UnifyM s () unifyModule mod1_u mod2_u-    | mod1_u == mod2_u = return ()-    | otherwise = do-        mod1 <- liftST $ UnionFind.find mod1_u-        mod2 <- liftST $ UnionFind.find mod2_u-        case (mod1, mod2) of-            (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u-            (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u-            (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do-                when (mod_name1 /= mod_name2) $-                    failWith $-                        hang (text "Cannot match module names") 4 $-                            text "   " <+> pretty mod_name1 $$-                            text "and" <+> pretty mod_name2-                -- NB: this is not actually necessary (because we'll-                -- detect loops eventually in 'unifyUnitId'), but it-                -- seems harmless enough-                liftST $ UnionFind.union mod1_u mod2_u-                unifyUnitId uid1 uid2+  | mod1_u == mod2_u = return ()+  | otherwise = do+      mod1 <- liftST $ UnionFind.find mod1_u+      mod2 <- liftST $ UnionFind.find mod2_u+      case (mod1, mod2) of+        (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u+        (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u+        (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do+          when (mod_name1 /= mod_name2) $+            failWith $+              hang (text "Cannot match module names") 4 $+                text "   "+                  <+> pretty mod_name1+                  $$ text "and"+                  <+> pretty mod_name2+          -- NB: this is not actually necessary (because we'll+          -- detect loops eventually in 'unifyUnitId'), but it+          -- seems harmless enough+          liftST $ UnionFind.union mod1_u mod2_u+          unifyUnitId uid1 uid2

@@ -5,13 +5,12 @@ -- applied to them. -- -- See also <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>--module Distribution.Backpack.ModSubst (-    ModSubst(..),-) where+module Distribution.Backpack.ModSubst+  ( ModSubst (..)+  ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod)+import Prelude ()  import Distribution.Backpack import Distribution.ModuleName@@ -21,32 +20,33 @@  -- | Applying module substitutions to semantic objects. class ModSubst a where-    -- In notation, substitution is postfix, which implies-    -- putting it on the right hand side, but for partial-    -- application it's more convenient to have it on the left-    -- hand side.-    modSubst :: OpenModuleSubst -> a -> a+  -- In notation, substitution is postfix, which implies+  -- putting it on the right hand side, but for partial+  -- application it's more convenient to have it on the left+  -- hand side.+  modSubst :: OpenModuleSubst -> a -> a  instance ModSubst OpenModule where-    modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name-    modSubst subst mod@(OpenModuleVar mod_name)-        | Just mod' <- Map.lookup mod_name subst = mod'-        | otherwise = mod+  modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name+  modSubst subst mod@(OpenModuleVar mod_name)+    | Just mod' <- Map.lookup mod_name subst = mod'+    | otherwise = mod  instance ModSubst OpenUnitId where-    modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts)-    modSubst _subst uid = uid+  modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts)+  modSubst _subst uid = uid  instance ModSubst (Set ModuleName) where-    modSubst subst reqs-        = Set.union (Set.difference reqs (Map.keysSet subst))-                    (openModuleSubstFreeHoles subst)+  modSubst subst reqs =+    Set.union+      (Set.difference reqs (Map.keysSet subst))+      (openModuleSubstFreeHoles subst)  -- Substitutions are functorial.  NB: this means that -- there is an @instance 'ModSubst' 'ModuleSubst'@! instance ModSubst a => ModSubst (Map k a) where-    modSubst subst = fmap (modSubst subst)+  modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst [a] where-    modSubst subst = fmap (modSubst subst)+  modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst (k, a) where-    modSubst subst (x,y) = (x, modSubst subst y)+  modSubst subst (x, y) = (x, modSubst subst y)

@@ -1,30 +1,31 @@+{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveFoldable #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ModuleScope (-    -- * Module scopes-    ModuleScope(..),-    ModuleProvides,-    ModuleRequires,-    ModuleSource(..),-    dispModuleSource,-    WithSource(..),-    unWithSource,-    getSource,-    ModuleWithSource,-    emptyModuleScope,-) where+module Distribution.Backpack.ModuleScope+  ( -- * Module scopes+    ModuleScope (..)+  , ModuleProvides+  , ModuleRequires+  , ModuleSource (..)+  , dispModuleSource+  , WithSource (..)+  , unWithSource+  , getSource+  , ModuleWithSource+  , emptyModuleScope+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  import Distribution.ModuleName-import Distribution.Types.IncludeRenaming-import Distribution.Types.PackageName+import Distribution.Pretty import Distribution.Types.ComponentName+import Distribution.Types.IncludeRenaming import Distribution.Types.LibraryName-import Distribution.Pretty+import Distribution.Types.PackageName  import Distribution.Backpack import Distribution.Backpack.ModSubst@@ -32,7 +33,6 @@ import qualified Data.Map as Map import Text.PrettyPrint - ----------------------------------------------------------------------- -- Module scopes @@ -60,17 +60,16 @@ -- Alternate strategy: go ahead and unify, and then if it is revealed -- that some requirements got filled "out-of-thin-air", error. - -- | A 'ModuleScope' describes the modules and requirements that -- are in-scope as we are processing a Cabal package.  Unlike -- a 'ModuleShape', there may be multiple modules in scope at -- the same 'ModuleName'; this is only an error if we attempt -- to use those modules to fill a requirement.  A 'ModuleScope' -- can influence the 'ModuleShape' via a reexport.-data ModuleScope = ModuleScope {-    modScopeProvides :: ModuleProvides,-    modScopeRequires :: ModuleRequires-    }+data ModuleScope = ModuleScope+  { modScopeProvides :: ModuleProvides+  , modScopeRequires :: ModuleRequires+  }  -- | An empty 'ModuleScope'. emptyModuleScope :: ModuleScope@@ -79,49 +78,53 @@ -- | Every 'Module' in scope at a 'ModuleName' is annotated with -- the 'PackageName' it comes from. type ModuleProvides = Map ModuleName [ModuleWithSource]+ -- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m type ModuleRequires = Map ModuleName [ModuleWithSource]+ -- TODO: consider newtping the two types above.  -- | Description of where a module participating in mixin linking came -- from. data ModuleSource-    = FromMixins         PackageName ComponentName IncludeRenaming-    | FromBuildDepends   PackageName ComponentName-    | FromExposedModules ModuleName-    | FromOtherModules   ModuleName-    | FromSignatures     ModuleName+  = FromMixins PackageName ComponentName IncludeRenaming+  | FromBuildDepends PackageName ComponentName+  | FromExposedModules ModuleName+  | FromOtherModules ModuleName+  | FromSignatures ModuleName+ -- We don't have line numbers, but if we did, we'd want to record that -- too  -- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg dispModuleSource :: ModuleSource -> Doc-dispModuleSource (FromMixins pn cn incls)-  = text "mixins:" <+> dispComponent pn cn <+> pretty incls-dispModuleSource (FromBuildDepends pn cn)-  = text "build-depends:" <+> dispComponent pn cn-dispModuleSource (FromExposedModules m)-  = text "exposed-modules:" <+> pretty m-dispModuleSource (FromOtherModules m)-  = text "other-modules:" <+> pretty m-dispModuleSource (FromSignatures m)-  = text "signatures:" <+> pretty m+dispModuleSource (FromMixins pn cn incls) =+  text "mixins:" <+> dispComponent pn cn <+> pretty incls+dispModuleSource (FromBuildDepends pn cn) =+  text "build-depends:" <+> dispComponent pn cn+dispModuleSource (FromExposedModules m) =+  text "exposed-modules:" <+> pretty m+dispModuleSource (FromOtherModules m) =+  text "other-modules:" <+> pretty m+dispModuleSource (FromSignatures m) =+  text "signatures:" <+> pretty m  -- Dependency dispComponent :: PackageName -> ComponentName -> Doc dispComponent pn cn =-    -- NB: This syntax isn't quite the source syntax, but it-    -- should be clear enough.  To do source syntax, we'd-    -- need to know what the package we're linking is.-    case cn of-        CLibName LMainLibName -> pretty pn-        CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn-        -- Case below shouldn't happen-        _ -> pretty pn <+> parens (pretty cn)+  -- NB: This syntax isn't quite the source syntax, but it+  -- should be clear enough.  To do source syntax, we'd+  -- need to know what the package we're linking is.+  case cn of+    CLibName LMainLibName -> pretty pn+    CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn+    -- Case below shouldn't happen+    _ -> pretty pn <+> parens (pretty cn)  -- | An 'OpenModule', annotated with where it came from in a Cabal file. data WithSource a = WithSource ModuleSource a-    deriving (Functor, Foldable, Traversable)+  deriving (Functor, Foldable, Traversable)+ unWithSource :: WithSource a -> a unWithSource (WithSource _ x) = x getSource :: WithSource a -> ModuleSource@@ -129,4 +132,4 @@ type ModuleWithSource = WithSource OpenModule  instance ModSubst a => ModSubst (WithSource a) where-    modSubst subst (WithSource s m) = WithSource s (modSubst subst m)+  modSubst subst (WithSource s m) = WithSource s (modSubst subst m)

@@ -1,21 +1,22 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ModuleShape (-    -- * Module shapes-    ModuleShape(..),-    emptyModuleShape,-    shapeInstalledPackage,-) where+module Distribution.Backpack.ModuleShape+  ( -- * Module shapes+    ModuleShape (..)+  , emptyModuleShape+  , shapeInstalledPackage+  ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod)+import Prelude () -import Distribution.ModuleName import Distribution.InstalledPackageInfo as IPI+import Distribution.ModuleName -import Distribution.Backpack.ModSubst import Distribution.Backpack+import Distribution.Backpack.ModSubst  import qualified Data.Map as Map import qualified Data.Set as Set@@ -26,18 +27,18 @@ -- | A 'ModuleShape' describes the provisions and requirements of -- a library.  We can extract a 'ModuleShape' from an -- 'InstalledPackageInfo'.-data ModuleShape = ModuleShape {-    modShapeProvides :: OpenModuleSubst,-    modShapeRequires :: Set ModuleName-    }-    deriving (Eq, Show, Generic, Typeable)+data ModuleShape = ModuleShape+  { modShapeProvides :: OpenModuleSubst+  , modShapeRequires :: Set ModuleName+  }+  deriving (Eq, Show, Generic, Typeable)  instance Binary ModuleShape instance Structured ModuleShape  instance ModSubst ModuleShape where-    modSubst subst (ModuleShape provs reqs)-        = ModuleShape (modSubst subst provs) (modSubst subst reqs)+  modSubst subst (ModuleShape provs reqs) =+    ModuleShape (modSubst subst provs) (modSubst subst reqs)  -- | The default module shape, with no provisions and no requirements. emptyModuleShape :: ModuleShape@@ -78,7 +79,7 @@     uid = installedOpenUnitId ipi     provs = map shapeExposedModule (IPI.exposedModules ipi)     reqs = requiredSignatures ipi-    shapeExposedModule (IPI.ExposedModule mod_name Nothing)-        = (mod_name, OpenModule uid mod_name)-    shapeExposedModule (IPI.ExposedModule mod_name (Just mod))-        = (mod_name, mod)+    shapeExposedModule (IPI.ExposedModule mod_name Nothing) =+      (mod_name, OpenModule uid mod_name)+    shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) =+      (mod_name, mod)

@@ -1,59 +1,70 @@ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.PreExistingComponent (-    PreExistingComponent(..),-    ipiToPreExistingComponent,-) where+module Distribution.Backpack.PreExistingComponent+  ( PreExistingComponent (..)+  , PromisedComponent (..)+  , ipiToPreExistingComponent+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import Distribution.Backpack.ModuleShape import Distribution.Backpack-import Distribution.Types.ComponentId-import Distribution.Types.MungedPackageId-import Distribution.Types.PackageId-import Distribution.Types.UnitId-import Distribution.Types.ComponentName-import Distribution.Types.PackageName+import Distribution.Backpack.ModuleShape import Distribution.Package+import Distribution.Types.ComponentName+import Distribution.Types.MungedPackageId  import qualified Data.Map as Map-import qualified Distribution.InstalledPackageInfo as Installed import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.Types.AnnotatedId +-- | A /promised/ component.+--+-- These components are promised to @configure@ but are not yet built.+--+-- In other words this is 'PreExistingComponent' which doesn't yet exist.+data PromisedComponent = PromisedComponent+  { pr_pkgname :: PackageName+  , pr_cid :: AnnotatedId ComponentId+  }++instance Package PromisedComponent where+  packageId = packageId . pr_cid+ -- | Stripped down version of 'LinkedComponent' for things -- we don't need to know how to build.-data PreExistingComponent-    = PreExistingComponent {-        -- | The actual name of the package. This may DISAGREE with 'pc_pkgid'-        -- for internal dependencies: e.g., an internal component @lib@ may be-        -- munged to @z-pkg-z-lib@, but we still want to use it when we see-        -- @lib@ in @build-depends@-        pc_pkgname :: PackageName,-        -- | The actual name of the component.-        pc_compname :: ComponentName,-        pc_munged_id :: MungedPackageId,-        pc_uid   :: UnitId,-        pc_cid   :: ComponentId,-        pc_open_uid :: OpenUnitId,-        pc_shape :: ModuleShape-    }+data PreExistingComponent = PreExistingComponent+  { pc_pkgname :: PackageName+  -- ^ The actual name of the package. This may DISAGREE with 'pc_pkgid'+  -- for internal dependencies: e.g., an internal component @lib@ may be+  -- munged to @z-pkg-z-lib@, but we still want to use it when we see+  -- @lib@ in @build-depends@+  , pc_compname :: ComponentName+  -- ^ The actual name of the component.+  , pc_munged_id :: MungedPackageId+  , pc_uid :: UnitId+  , pc_cid :: ComponentId+  , pc_open_uid :: OpenUnitId+  , pc_shape :: ModuleShape+  }  -- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', -- which was brought into scope under the 'PackageName' (important for -- a package qualified reference.) ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent ipiToPreExistingComponent ipi =-    PreExistingComponent {-        pc_pkgname = packageName ipi,-        pc_compname = CLibName $ Installed.sourceLibName ipi,-        pc_munged_id = mungedId ipi,-        pc_uid   = Installed.installedUnitId ipi,-        pc_cid   = Installed.installedComponentId ipi,-        pc_open_uid =-            IndefFullUnitId (Installed.installedComponentId ipi)-                            (Map.fromList (Installed.instantiatedWith ipi)),-        pc_shape = shapeInstalledPackage ipi+  PreExistingComponent+    { pc_pkgname = packageName ipi+    , pc_compname = CLibName $ Installed.sourceLibName ipi+    , pc_munged_id = mungedId ipi+    , pc_uid = Installed.installedUnitId ipi+    , pc_cid = Installed.installedComponentId ipi+    , pc_open_uid =+        IndefFullUnitId+          (Installed.installedComponentId ipi)+          (Map.fromList (Installed.instantiatedWith ipi))+    , pc_shape = shapeInstalledPackage ipi     }  instance HasMungedPackageId PreExistingComponent where@@ -61,7 +72,8 @@  instance Package PreExistingComponent where   packageId pec = PackageIdentifier (pc_pkgname pec) v-    where MungedPackageId _ v = pc_munged_id pec+    where+      MungedPackageId _ v = pc_munged_id pec  instance HasUnitId PreExistingComponent where   installedUnitId = pc_uid

@@ -1,38 +1,38 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Backpack.PreModuleShape (-    PreModuleShape(..),-    toPreModuleShape,-    renamePreModuleShape,-    mixLinkPreModuleShape,-) where+module Distribution.Backpack.PreModuleShape+  ( PreModuleShape (..)+  , toPreModuleShape+  , renamePreModuleShape+  , mixLinkPreModuleShape+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import qualified Data.Set as Set import qualified Data.Map as Map+import qualified Data.Set as Set  import Distribution.Backpack.ModuleShape+import Distribution.ModuleName import Distribution.Types.IncludeRenaming import Distribution.Types.ModuleRenaming-import Distribution.ModuleName -data PreModuleShape = PreModuleShape {-        preModShapeProvides :: Set ModuleName,-        preModShapeRequires :: Set ModuleName-    }-    deriving (Eq, Show, Generic)+data PreModuleShape = PreModuleShape+  { preModShapeProvides :: Set ModuleName+  , preModShapeRequires :: Set ModuleName+  }+  deriving (Eq, Show, Generic)  toPreModuleShape :: ModuleShape -> PreModuleShape toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs  renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) =-    PreModuleShape-        (Set.fromList (mapMaybe prov_fn (Set.toList provs)))-        (Set.map req_fn reqs)+  PreModuleShape+    (Set.fromList (mapMaybe prov_fn (Set.toList provs)))+    (Set.map req_fn reqs)   where     prov_fn = interpModuleRenaming prov_rn     req_fn k = fromMaybe k (interpModuleRenaming req_rn k)@@ -41,4 +41,4 @@ mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs)   where     provs = Set.unions (map preModShapeProvides shapes)-    reqs  = Set.unions (map preModShapeRequires shapes)+    reqs = Set.unions (map preModShapeRequires shapes)

@@ -1,186 +1,199 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies #-}+ -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.ReadyComponent (-    ReadyComponent(..),-    InstantiatedComponent(..),-    IndefiniteComponent(..),-    rc_depends,-    rc_uid,-    rc_pkgid,-    dispReadyComponent,-    toReadyComponents,-) where+module Distribution.Backpack.ReadyComponent+  ( ReadyComponent (..)+  , InstantiatedComponent (..)+  , IndefiniteComponent (..)+  , rc_depends+  , rc_uid+  , rc_pkgid+  , dispReadyComponent+  , toReadyComponents+  ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>))+import Prelude ()  import Distribution.Backpack import Distribution.Backpack.LinkedComponent import Distribution.Backpack.ModuleShape +import Distribution.Compat.Graph (IsNode (..)) import Distribution.Types.AnnotatedId-import Distribution.Types.ModuleRenaming import Distribution.Types.Component-import Distribution.Types.ComponentInclude import Distribution.Types.ComponentId+import Distribution.Types.ComponentInclude import Distribution.Types.ComponentName-import Distribution.Types.PackageId-import Distribution.Types.PackageName.Magic-import Distribution.Types.UnitId-import Distribution.Compat.Graph (IsNode(..))+import Distribution.Types.Library+import Distribution.Types.LibraryName import Distribution.Types.Module+import Distribution.Types.ModuleRenaming import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName-import Distribution.Types.Library-import Distribution.Types.LibraryName+import Distribution.Types.PackageId+import Distribution.Types.PackageName.Magic+import Distribution.Types.UnitId  import Distribution.ModuleName import Distribution.Package import Distribution.Simple.Utils  import Control.Monad-import Text.PrettyPrint import qualified Data.Map as Map import qualified Data.Set as Set+import Text.PrettyPrint -import Distribution.Version import Distribution.Pretty+import Distribution.Version  -- | A 'ReadyComponent' is one that we can actually generate build -- products for.  We have a ready component for the typecheck-only -- products of every indefinite package, as well as a ready component -- for every way these packages can be fully instantiated.----data ReadyComponent-    = ReadyComponent {-        rc_ann_id       :: AnnotatedId UnitId,-        -- | The 'OpenUnitId' for this package.  At the moment, this-        -- is used in only one case, which is to determine if an-        -- export is of a module from this library (indefinite-        -- libraries record these exports as 'OpenModule');-        -- 'rc_open_uid' can be conveniently used to test for-        -- equality, whereas 'UnitId' cannot always be used in this-        -- case.-        rc_open_uid     :: OpenUnitId,-        -- | Corresponds to 'lc_cid'.  Invariant: if 'rc_open_uid'-        -- records a 'ComponentId', it coincides with this one.-        rc_cid          :: ComponentId,-        -- | Corresponds to 'lc_component'.-        rc_component    :: Component,-        -- | Corresponds to 'lc_exe_deps'.-        -- Build-tools don't participate in mix-in linking.-        -- (but what if they could?)-        rc_exe_deps     :: [AnnotatedId UnitId],-        -- | Corresponds to 'lc_public'.-        rc_public       :: Bool,-        -- | Extra metadata depending on whether or not this is an-        -- indefinite library (typechecked only) or an instantiated-        -- component (can be compiled).-        rc_i            :: Either IndefiniteComponent InstantiatedComponent-    }+data ReadyComponent = ReadyComponent+  { rc_ann_id :: AnnotatedId UnitId+  , rc_open_uid :: OpenUnitId+  -- ^ The 'OpenUnitId' for this package.  At the moment, this+  -- is used in only one case, which is to determine if an+  -- export is of a module from this library (indefinite+  -- libraries record these exports as 'OpenModule');+  -- 'rc_open_uid' can be conveniently used to test for+  -- equality, whereas 'UnitId' cannot always be used in this+  -- case.+  , rc_cid :: ComponentId+  -- ^ Corresponds to 'lc_cid'.  Invariant: if 'rc_open_uid'+  -- records a 'ComponentId', it coincides with this one.+  , rc_component :: Component+  -- ^ Corresponds to 'lc_component'.+  , rc_exe_deps :: [AnnotatedId UnitId]+  -- ^ Corresponds to 'lc_exe_deps'.+  -- Build-tools don't participate in mix-in linking.+  -- (but what if they could?)+  , rc_public :: Bool+  -- ^ Corresponds to 'lc_public'.+  , rc_i :: Either IndefiniteComponent InstantiatedComponent+  -- ^ Extra metadata depending on whether or not this is an+  -- indefinite library (typechecked only) or an instantiated+  -- component (can be compiled).+  }  -- | The final, string 'UnitId' that will uniquely identify -- the compilation products of this component.-rc_uid          :: ReadyComponent -> UnitId+rc_uid :: ReadyComponent -> UnitId rc_uid = ann_id . rc_ann_id  -- | Corresponds to 'lc_pkgid'.-rc_pkgid        :: ReadyComponent -> PackageId+rc_pkgid :: ReadyComponent -> PackageId rc_pkgid = ann_pid . rc_ann_id  -- | An 'InstantiatedComponent' is a library which is fully instantiated -- (or, possibly, has no requirements at all.)-data InstantiatedComponent-    = InstantiatedComponent {-        -- | How this library was instantiated.-        instc_insts    :: [(ModuleName, Module)],-        -- | Dependencies induced by 'instc_insts'.  These are recorded-        -- here because there isn't a convenient way otherwise to get-        -- the 'PackageId' we need to fill 'componentPackageDeps' as needed.-        instc_insts_deps :: [(UnitId, MungedPackageId)],-        -- | The modules exported/reexported by this library.-        instc_provides :: Map ModuleName Module,-        -- | The dependencies which need to be passed to the compiler-        -- to bring modules into scope.  These always refer to installed-        -- fully instantiated libraries.-        instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]-    }+data InstantiatedComponent = InstantiatedComponent+  { instc_insts :: [(ModuleName, Module)]+  -- ^ How this library was instantiated.+  , instc_insts_deps :: [(UnitId, MungedPackageId)]+  -- ^ Dependencies induced by 'instc_insts'.  These are recorded+  -- here because there isn't a convenient way otherwise to get+  -- the 'PackageId' we need to fill 'componentPackageDeps' as needed.+  , instc_provides :: Map ModuleName Module+  -- ^ The modules exported/reexported by this library.+  , instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]+  -- ^ The dependencies which need to be passed to the compiler+  -- to bring modules into scope.  These always refer to installed+  -- fully instantiated libraries.+  }  -- | An 'IndefiniteComponent' is a library with requirements -- which we will typecheck only.-data IndefiniteComponent-    = IndefiniteComponent {-        -- | The requirements of the library.-        indefc_requires :: [ModuleName],-        -- | The modules exported/reexported by this library.-        indefc_provides :: Map ModuleName OpenModule,-        -- | The dependencies which need to be passed to the compiler-        -- to bring modules into scope.  These are 'OpenUnitId' because-        -- these may refer to partially instantiated libraries.-        indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]-    }+data IndefiniteComponent = IndefiniteComponent+  { indefc_requires :: [ModuleName]+  -- ^ The requirements of the library.+  , indefc_provides :: Map ModuleName OpenModule+  -- ^ The modules exported/reexported by this library.+  , indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]+  -- ^ The dependencies which need to be passed to the compiler+  -- to bring modules into scope.  These are 'OpenUnitId' because+  -- these may refer to partially instantiated libraries.+  }  -- | Compute the dependencies of a 'ReadyComponent' that should -- be recorded in the @depends@ field of 'InstalledPackageInfo'. rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] rc_depends rc = ordNub $-    case rc_i rc of-        Left indefc ->-            map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci))-                (indefc_includes indefc)-        Right instc ->-            map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci))-                (instc_includes instc)-              ++ instc_insts_deps instc+  case rc_i rc of+    Left indefc ->+      map+        (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci))+        (indefc_includes indefc)+    Right instc ->+      map+        (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci))+        (instc_includes instc)+        ++ instc_insts_deps instc   where     toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId     toMungedPackageId ci =-        computeCompatPackageId-            (ci_pkgid ci)-            (case ci_cname ci of-                CLibName name -> name-                _ -> error $ prettyShow (rc_cid rc) ++-                        " depends on non-library " ++ prettyShow (ci_id ci))+      computeCompatPackageId+        (ci_pkgid ci)+        ( case ci_cname ci of+            CLibName name -> name+            _ ->+              error $+                prettyShow (rc_cid rc)+                  ++ " depends on non-library "+                  ++ prettyShow (ci_id ci)+        )  -- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is -- a library. rc_munged_id :: ReadyComponent -> MungedPackageId rc_munged_id rc =-    computeCompatPackageId-        (rc_pkgid rc)-        (case rc_component rc of-            CLib lib -> libName lib-            _ -> error "rc_munged_id: not library")+  computeCompatPackageId+    (rc_pkgid rc)+    ( case rc_component rc of+        CLib lib -> libName lib+        _ -> error "rc_munged_id: not library"+    )  instance Package ReadyComponent where-    packageId = rc_pkgid+  packageId = rc_pkgid  instance HasUnitId ReadyComponent where-    installedUnitId = rc_uid+  installedUnitId = rc_uid  instance IsNode ReadyComponent where-    type Key ReadyComponent = UnitId-    nodeKey = rc_uid-    nodeNeighbors rc =-      (case rc_i rc of-        Right inst | [] <- instc_insts inst-                   -> []-                   | otherwise-                   -> [newSimpleUnitId (rc_cid rc)]-        _ -> []) ++-      ordNub (map fst (rc_depends rc)) ++-      map ann_id (rc_exe_deps rc)+  type Key ReadyComponent = UnitId+  nodeKey = rc_uid+  nodeNeighbors rc =+    ( case rc_i rc of+        Right inst+          | [] <- instc_insts inst ->+              []+          | otherwise ->+              [newSimpleUnitId (rc_cid rc)]+        _ -> []+    )+      ++ ordNub (map fst (rc_depends rc))+      ++ map ann_id (rc_exe_deps rc)  dispReadyComponent :: ReadyComponent -> Doc dispReadyComponent rc =-    hang (text (case rc_i rc of-                    Left  _ -> "indefinite"-                    Right _ -> "definite")-            <+> pretty (nodeKey rc)-            {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $-        vcat [ text "depends" <+> pretty uid-             | uid <- nodeNeighbors rc ]+  hang+    ( text+        ( case rc_i rc of+            Left _ -> "indefinite"+            Right _ -> "definite"+        )+        <+> pretty (nodeKey rc)+        {- <+> dispModSubst (Map.fromList (lc_insts lc)) -}+    )+    4+    $ vcat+      [ text "depends" <+> pretty uid+      | uid <- nodeNeighbors rc+      ]  -- | The state of 'InstM'; a mapping from 'UnitId's to their -- ready component, or @Nothing@ if its an external@@ -189,22 +202,25 @@  -- | A state monad for doing instantiations (can't use actual -- State because that would be an extra dependency.)-newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) }+newtype InstM a = InstM {runInstM :: InstS -> (a, InstS)}  instance Functor InstM where-    fmap f (InstM m) = InstM $ \s -> let (x, s') = m s-                                     in (f x, s')+  fmap f (InstM m) = InstM $ \s ->+    let (x, s') = m s+     in (f x, s')  instance Applicative InstM where-    pure a = InstM $ \s -> (a, s)-    InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s-                                            (x', s'') = x s'-                                        in (f' x', s'')+  pure a = InstM $ \s -> (a, s)+  InstM f <*> InstM x = InstM $ \s ->+    let (f', s') = f s+        (x', s'') = x s'+     in (f' x', s'')  instance Monad InstM where-    return = pure-    InstM m >>= f = InstM $ \s -> let (x, s') = m s-                                  in runInstM (f x) s'+  return = pure+  InstM m >>= f = InstM $ \s ->+    let (x, s') = m s+     in runInstM (f x) s'  -- | Given a list of 'LinkedComponent's, expand the module graph -- so that we have an instantiated graph containing all of the@@ -222,27 +238,30 @@ -- -- We also call 'improveUnitId' during this process, so that fully -- instantiated components are given 'HashedUnitId'.--- toReadyComponents-    :: Map UnitId MungedPackageId-    -> Map ModuleName Module -- subst for the public component-    -> [LinkedComponent]-    -> [ReadyComponent]-toReadyComponents pid_map subst0 comps-    = catMaybes (Map.elems ready_map)+  :: Map UnitId MungedPackageId+  -> Map ModuleName Module -- subst for the public component+  -> [LinkedComponent]+  -> [ReadyComponent]+toReadyComponents pid_map subst0 comps =+  catMaybes (Map.elems ready_map)   where-    cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ]+    cmap = Map.fromList [(lc_cid lc, lc) | lc <- comps] -    instantiateUnitId :: ComponentId -> Map ModuleName Module-                      -> InstM DefUnitId+    instantiateUnitId+      :: ComponentId+      -> Map ModuleName Module+      -> InstM DefUnitId     instantiateUnitId cid insts = InstM $ \s ->-        case Map.lookup uid s of-            Nothing ->-                -- Knot tied-                let (r, s') = runInstM (instantiateComponent uid cid insts)-                                       (Map.insert uid r s)-                in (def_uid, Map.insert uid r s')-            Just _ -> (def_uid, s)+      case Map.lookup uid s of+        Nothing ->+          -- Knot tied+          let (r, s') =+                runInstM+                  (instantiateComponent uid cid insts)+                  (Map.insert uid r s)+           in (def_uid, Map.insert uid r s')+        Just _ -> (def_uid, s)       where         -- The mkDefUnitId here indicates that we assume         -- that Cabal handles unit id hash allocation.@@ -252,125 +271,142 @@         uid = unDefUnitId def_uid      instantiateComponent-        :: UnitId -> ComponentId -> Map ModuleName Module-        -> InstM (Maybe ReadyComponent)+      :: UnitId+      -> ComponentId+      -> Map ModuleName Module+      -> InstM (Maybe ReadyComponent)     instantiateComponent uid cid insts       | Just lc <- Map.lookup cid cmap = do-            provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc))-            -- NB: lc_sig_includes is omitted here, because we don't-            -- need them to build-            includes <- forM (lc_includes lc) $ \ci -> do-                uid' <- substUnitId insts (ci_id ci)-                return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) }-            exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc)-            s <- InstM $ \s -> (s, s)-            let getDep (Module dep_def_uid _)-                    | let dep_uid = unDefUnitId dep_def_uid+          provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc))+          -- NB: lc_sig_includes is omitted here, because we don't+          -- need them to build+          includes <- forM (lc_includes lc) $ \ci -> do+            uid' <- substUnitId insts (ci_id ci)+            return ci{ci_ann_id = fmap (const uid') (ci_ann_id ci)}+          exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc)+          s <- InstM $ \s -> (s, s)+          let getDep (Module dep_def_uid _)+                | let dep_uid = unDefUnitId dep_def_uid =                     -- Lose DefUnitId invariant for rc_depends-                    = [(dep_uid,-                          fromMaybe err_pid $-                            Map.lookup dep_uid pid_map <|>-                            fmap rc_munged_id (join (Map.lookup dep_uid s)))]-                  where-                    err_pid = MungedPackageId-                        (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName)-                        (mkVersion [0])-                instc = InstantiatedComponent {-                            instc_insts = Map.toList insts,-                            instc_insts_deps = concatMap getDep (Map.elems insts),-                            instc_provides = provides,-                            instc_includes = includes-                            -- NB: there is no dependency on the-                            -- indefinite version of this instantiated package here,-                            -- as (1) it doesn't go in depends in the-                            -- IPI: it's not a run time dep, and (2)-                            -- we don't have to tell GHC about it, it-                            -- will match up the ComponentId-                            -- automatically-                        }-            return $ Just ReadyComponent {-                    rc_ann_id       = (lc_ann_id lc) { ann_id = uid },-                    rc_open_uid     = DefiniteUnitId (unsafeMkDefUnitId uid),-                    rc_cid          = lc_cid lc,-                    rc_component    = lc_component lc,-                    rc_exe_deps     = exe_deps,-                    rc_public       = lc_public lc,-                    rc_i            = Right instc-                   }+                    [+                      ( dep_uid+                      , fromMaybe err_pid $+                          Map.lookup dep_uid pid_map+                            <|> fmap rc_munged_id (join (Map.lookup dep_uid s))+                      )+                    ]+                where+                  err_pid =+                    MungedPackageId+                      (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName)+                      (mkVersion [0])+              instc =+                InstantiatedComponent+                  { instc_insts = Map.toList insts+                  , instc_insts_deps = concatMap getDep (Map.elems insts)+                  , instc_provides = provides+                  , instc_includes = includes+                  -- NB: there is no dependency on the+                  -- indefinite version of this instantiated package here,+                  -- as (1) it doesn't go in depends in the+                  -- IPI: it's not a run time dep, and (2)+                  -- we don't have to tell GHC about it, it+                  -- will match up the ComponentId+                  -- automatically+                  }+          return $+            Just+              ReadyComponent+                { rc_ann_id = (lc_ann_id lc){ann_id = uid}+                , rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid)+                , rc_cid = lc_cid lc+                , rc_component = lc_component lc+                , rc_exe_deps = exe_deps+                , rc_public = lc_public lc+                , rc_i = Right instc+                }       | otherwise = return Nothing      substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId     substUnitId _ (DefiniteUnitId uid) =-        return uid+      return uid     substUnitId subst (IndefFullUnitId cid insts) = do-        insts' <- substSubst subst insts-        instantiateUnitId cid insts'+      insts' <- substSubst subst insts+      instantiateUnitId cid insts'      -- NB: NOT composition-    substSubst :: Map ModuleName Module-               -> Map ModuleName OpenModule-               -> InstM (Map ModuleName Module)+    substSubst+      :: Map ModuleName Module+      -> Map ModuleName OpenModule+      -> InstM (Map ModuleName Module)     substSubst subst insts = traverse (substModule subst) insts      substModule :: Map ModuleName Module -> OpenModule -> InstM Module     substModule subst (OpenModuleVar mod_name)-        | Just m <- Map.lookup mod_name subst = return m-        | otherwise = error "substModule: non-closing substitution"+      | Just m <- Map.lookup mod_name subst = return m+      | otherwise = error "substModule: non-closing substitution"     substModule subst (OpenModule uid mod_name) = do-        uid' <- substUnitId subst uid-        return (Module uid' mod_name)+      uid' <- substUnitId subst uid+      return (Module uid' mod_name) -    substExeDep :: Map ModuleName Module-                -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId)+    substExeDep+      :: Map ModuleName Module+      -> AnnotatedId OpenUnitId+      -> InstM (AnnotatedId UnitId)     substExeDep insts exe_aid = do-        exe_uid' <- substUnitId insts (ann_id exe_aid)-        return exe_aid { ann_id = unDefUnitId exe_uid' }+      exe_uid' <- substUnitId insts (ann_id exe_aid)+      return exe_aid{ann_id = unDefUnitId exe_uid'}      indefiniteUnitId :: ComponentId -> InstM UnitId     indefiniteUnitId cid = do-        let uid = newSimpleUnitId cid-        r <- indefiniteComponent uid cid-        InstM $ \s -> (uid, Map.insert uid r s)+      let uid = newSimpleUnitId cid+      r <- indefiniteComponent uid cid+      InstM $ \s -> (uid, Map.insert uid r s)      indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent)     indefiniteComponent uid cid       | Just lc <- Map.lookup cid cmap = do-            -- We're going to process includes, in case some of them-            -- are fully definite even without any substitution.  We-            -- want to build those too; see #5634.-            inst_includes <- forM (lc_includes lc) $ \ci ->-                if Set.null (openUnitIdFreeHoles (ci_id ci))-                    then do uid' <- substUnitId Map.empty (ci_id ci)-                            return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) }-                    else return ci-            exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc)-            let indefc = IndefiniteComponent {-                        indefc_requires = map fst (lc_insts lc),-                        indefc_provides = modShapeProvides (lc_shape lc),-                        indefc_includes = inst_includes ++ lc_sig_includes lc-                    }-            return $ Just ReadyComponent {-                    rc_ann_id       = (lc_ann_id lc) { ann_id = uid },-                    rc_cid          = lc_cid lc,-                    rc_open_uid     = lc_uid lc,-                    rc_component    = lc_component lc,-                    -- It's always fully built-                    rc_exe_deps     = exe_deps,-                    rc_public       = lc_public lc,-                    rc_i            = Left indefc+          -- We're going to process includes, in case some of them+          -- are fully definite even without any substitution.  We+          -- want to build those too; see #5634.+          inst_includes <- forM (lc_includes lc) $ \ci ->+            if Set.null (openUnitIdFreeHoles (ci_id ci))+              then do+                uid' <- substUnitId Map.empty (ci_id ci)+                return $ ci{ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci)}+              else return ci+          exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc)+          let indefc =+                IndefiniteComponent+                  { indefc_requires = map fst (lc_insts lc)+                  , indefc_provides = modShapeProvides (lc_shape lc)+                  , indefc_includes = inst_includes ++ lc_sig_includes lc+                  }+          return $+            Just+              ReadyComponent+                { rc_ann_id = (lc_ann_id lc){ann_id = uid}+                , rc_cid = lc_cid lc+                , rc_open_uid = lc_uid lc+                , rc_component = lc_component lc+                , -- It's always fully built+                  rc_exe_deps = exe_deps+                , rc_public = lc_public lc+                , rc_i = Left indefc                 }       | otherwise = return Nothing      ready_map = snd $ runInstM work Map.empty      work-        -- Top-level instantiation per subst0-        | not (Map.null subst0)-        , [lc] <- filter lc_public (Map.elems cmap)-        = do _ <- instantiateUnitId (lc_cid lc) subst0-             return ()-        | otherwise-        = forM_ (Map.elems cmap) $ \lc ->+      -- Top-level instantiation per subst0+      | not (Map.null subst0)+      , [lc] <- filter lc_public (Map.elems cmap) =+          do+            _ <- instantiateUnitId (lc_cid lc) subst0+            return ()+      | otherwise =+          forM_ (Map.elems cmap) $ \lc ->             if null (lc_insts lc)-                then instantiateUnitId (lc_cid lc) Map.empty >> return ()-                else indefiniteUnitId (lc_cid lc) >> return ()+              then instantiateUnitId (lc_cid lc) Map.empty >> return ()+              else indefiniteUnitId (lc_cid lc) >> return ()

@@ -1,163 +1,163 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}--- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>-module Distribution.Backpack.UnifyM (-    -- * Unification monad-    UnifyM,-    runUnifyM,-    failWith,-    addErr,-    failIfErrs,-    tryM,-    addErrContext,-    addErrContextM,-    liftST, -    UnifEnv(..),-    getUnifEnv,+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>+module Distribution.Backpack.UnifyM+  ( -- * Unification monad+    UnifyM+  , runUnifyM+  , failWith+  , addErr+  , failIfErrs+  , tryM+  , addErrContext+  , addErrContextM+  , liftST+  , UnifEnv (..)+  , getUnifEnv      -- * Modules and unit IDs-    ModuleU,-    ModuleU'(..),-    convertModule,-    convertModuleU,--    UnitIdU,-    UnitIdU'(..),-    convertUnitId,-    convertUnitIdU,--    ModuleSubstU,-    convertModuleSubstU,-    convertModuleSubst,--    ModuleScopeU,-    emptyModuleScopeU,-    convertModuleScopeU,--    ModuleWithSourceU,--    convertInclude,-    convertModuleProvides,-    convertModuleProvidesU,--) where+  , ModuleU+  , ModuleU' (..)+  , convertModule+  , convertModuleU+  , UnitIdU+  , UnitIdU' (..)+  , convertUnitId+  , convertUnitIdU+  , ModuleSubstU+  , convertModuleSubstU+  , convertModuleSubst+  , ModuleScopeU+  , emptyModuleScopeU+  , convertModuleScopeU+  , ModuleWithSourceU+  , convertInclude+  , convertModuleProvides+  , convertModuleProvidesU+  ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod)+import Prelude () -import Distribution.Backpack.ModuleShape-import Distribution.Backpack.ModuleScope-import Distribution.Backpack.ModSubst-import Distribution.Backpack.FullUnitId import Distribution.Backpack+import Distribution.Backpack.FullUnitId+import Distribution.Backpack.ModSubst+import Distribution.Backpack.ModuleScope+import Distribution.Backpack.ModuleShape -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription import Distribution.Pretty-import Distribution.Types.ComponentInclude import Distribution.Types.AnnotatedId+import Distribution.Types.ComponentInclude+import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.Verbosity -import Data.STRef-import Data.Traversable import Control.Monad.ST-import qualified Data.Map as Map-import qualified Data.Set as Set import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import Data.STRef+import qualified Data.Set as Set+import Data.Traversable import Text.PrettyPrint  -- TODO: more detailed trace output on high verbosity would probably -- be appreciated by users debugging unification errors.  Collect -- some good examples! -data ErrMsg = ErrMsg {-        err_msg :: Doc,-        err_ctx :: [Doc]-    }+data ErrMsg = ErrMsg+  { err_msg :: Doc+  , err_ctx :: [Doc]+  } type MsgDoc = Doc  renderErrMsg :: ErrMsg -> MsgDoc-renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } =-    msg $$ vcat ctx+renderErrMsg ErrMsg{err_msg = msg, err_ctx = ctx} =+  msg $$ vcat ctx  -- | The unification monad, this monad encapsulates imperative -- unification.-newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) }+newtype UnifyM s a = UnifyM {unUnifyM :: UnifEnv s -> ST s (Maybe a)}  -- | Run a computation in the unification monad. runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a-runUnifyM verbosity self_cid db m-    = runST $ do i    <- newSTRef 0-                 hmap <- newSTRef Map.empty-                 errs <- newSTRef []-                 mb_r <- unUnifyM m UnifEnv {-                            unify_uniq = i,-                            unify_reqs = hmap,-                            unify_self_cid = self_cid,-                            unify_verbosity = verbosity,-                            unify_ctx = [],-                            unify_db = db,-                            unify_errs = errs }-                 final_errs <- readSTRef errs-                 case mb_r of-                    Just x | null final_errs -> return (Right x)-                    _ -> return (Left (map renderErrMsg (reverse final_errs)))+runUnifyM verbosity self_cid db m =+  runST $ do+    i <- newSTRef 0+    hmap <- newSTRef Map.empty+    errs <- newSTRef []+    mb_r <-+      unUnifyM+        m+        UnifEnv+          { unify_uniq = i+          , unify_reqs = hmap+          , unify_self_cid = self_cid+          , unify_verbosity = verbosity+          , unify_ctx = []+          , unify_db = db+          , unify_errs = errs+          }+    final_errs <- readSTRef errs+    case mb_r of+      Just x | null final_errs -> return (Right x)+      _ -> return (Left (map renderErrMsg (reverse final_errs)))+ -- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'.  type ErrCtx s = MsgDoc  -- | The unification environment.-data UnifEnv s = UnifEnv {-        -- | A supply of unique integers to label 'UnitIdU'-        -- cells.  This is used to determine loops in unit-        -- identifiers (which can happen with mutual recursion.)-        unify_uniq :: UnifRef s UnitIdUnique,-        -- | The set of requirements in scope.  When-        -- a provision is brought into scope, we unify with-        -- the requirement at the same module name to fill it.-        -- This mapping grows monotonically.-        unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)),-        -- | Component id of the unit we're linking.  We use this-        -- to detect if we fill a requirement with a local module,-        -- which in principle should be OK but is not currently-        -- supported by GHC.-        unify_self_cid :: ComponentId,-        -- | How verbose the error message should be-        unify_verbosity :: Verbosity,-        -- | The error reporting context-        unify_ctx :: [ErrCtx s],-        -- | The package index for expanding unit identifiers-        unify_db :: FullDb,-        -- | Accumulated errors-        unify_errs :: UnifRef s [ErrMsg]-    }+data UnifEnv s = UnifEnv+  { unify_uniq :: UnifRef s UnitIdUnique+  -- ^ A supply of unique integers to label 'UnitIdU'+  -- cells.  This is used to determine loops in unit+  -- identifiers (which can happen with mutual recursion.)+  , unify_reqs :: UnifRef s (Map ModuleName (ModuleU s))+  -- ^ The set of requirements in scope.  When+  -- a provision is brought into scope, we unify with+  -- the requirement at the same module name to fill it.+  -- This mapping grows monotonically.+  , unify_self_cid :: ComponentId+  -- ^ Component id of the unit we're linking.  We use this+  -- to detect if we fill a requirement with a local module,+  -- which in principle should be OK but is not currently+  -- supported by GHC.+  , unify_verbosity :: Verbosity+  -- ^ How verbose the error message should be+  , unify_ctx :: [ErrCtx s]+  -- ^ The error reporting context+  , unify_db :: FullDb+  -- ^ The package index for expanding unit identifiers+  , unify_errs :: UnifRef s [ErrMsg]+  -- ^ Accumulated errors+  }  instance Functor (UnifyM s) where-    fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m)+  fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m)  instance Applicative (UnifyM s) where-    pure = UnifyM . pure . pure . pure-    UnifyM f <*> UnifyM x = UnifyM $ \r -> do-        f' <- f r-        case f' of+  pure = UnifyM . pure . pure . pure+  UnifyM f <*> UnifyM x = UnifyM $ \r -> do+    f' <- f r+    case f' of+      Nothing -> return Nothing+      Just f'' -> do+        x' <- x r+        case x' of           Nothing -> return Nothing-          Just f'' -> do-              x' <- x r-              case x' of-                  Nothing -> return Nothing-                  Just x'' -> return (Just (f'' x''))+          Just x'' -> return (Just (f'' x''))  instance Monad (UnifyM s) where-    return = pure-    UnifyM m >>= f = UnifyM $ \r -> do-        x <- m r-        case x of-            Nothing -> return Nothing-            Just x' -> unUnifyM (f x') r+  return = pure+  UnifyM m >>= f = UnifyM $ \r -> do+    x <- m r+    case x of+      Nothing -> return Nothing+      Just x' -> unUnifyM (f x') r  -- | Lift a computation from 'ST' monad to 'UnifyM' monad. -- Internal use only.@@ -166,32 +166,35 @@  addErr :: MsgDoc -> UnifyM s () addErr msg = do-    env <- getUnifEnv-    let err = ErrMsg {-                err_msg = msg,-                err_ctx = unify_ctx env-              }-    liftST $ modifySTRef (unify_errs env) (\errs -> err:errs)+  env <- getUnifEnv+  let err =+        ErrMsg+          { err_msg = msg+          , err_ctx = unify_ctx env+          }+  liftST $ modifySTRef (unify_errs env) (\errs -> err : errs)  failWith :: MsgDoc -> UnifyM s a failWith msg = do-    addErr msg-    failM+  addErr msg+  failM  failM :: UnifyM s a failM = UnifyM $ \_ -> return Nothing  failIfErrs :: UnifyM s () failIfErrs = do-    env <- getUnifEnv-    errs <- liftST $ readSTRef (unify_errs env)-    when (not (null errs)) failM+  env <- getUnifEnv+  errs <- liftST $ readSTRef (unify_errs env)+  when (not (null errs)) failM  tryM :: UnifyM s a -> UnifyM s (Maybe a) tryM m =-    UnifyM (\env -> do+  UnifyM+    ( \env -> do         mb_r <- unUnifyM m env-        return (Just mb_r))+        return (Just mb_r)+    )  {- otherFail :: ErrMsg -> UnifyM s a@@ -236,8 +239,7 @@ -- | Add a message to the error context.  It may make monadic queries. addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a addErrContextM ctx m =-    UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r }-+  UnifyM $ \r -> unUnifyM m r{unify_ctx = ctx : unify_ctx r}  ----------------------------------------------------------------------- -- The "unifiable" variants of the data types@@ -251,13 +253,13 @@  -- | Contents of a mutable 'ModuleU' reference. data ModuleU' s-    = ModuleU (UnitIdU s) ModuleName-    | ModuleVarU ModuleName+  = ModuleU (UnitIdU s) ModuleName+  | ModuleVarU ModuleName  -- | Contents of a mutable 'UnitIdU' reference. data UnitIdU' s-    = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))-    | UnitIdThunkU DefUnitId+  = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))+  | UnitIdThunkU DefUnitId  -- | A mutable version of 'Module' which can be imperatively unified. type ModuleU s = UnionFind.Point s (ModuleU' s)@@ -273,7 +275,6 @@ -- participate in unification! type UnitIdUnique = Int - ----------------------------------------------------------------------- -- Conversion to the unifiable data types @@ -286,7 +287,7 @@  extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s extendMuEnv (m, i) x =-    (IntMap.insert (i + 1) x m, i + 1)+  (IntMap.insert (i + 1) x m, i + 1)  {- lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s@@ -308,37 +309,42 @@ --     @hole:A@ binders. --   * @MuEnv@ - the environment for mu-binders. -convertUnitId' :: MuEnv s-               -> OpenUnitId-               -> UnifyM s (UnitIdU s)+convertUnitId'+  :: MuEnv s+  -> OpenUnitId+  -> UnifyM s (UnitIdU s) -- TODO: this could be more lazy if we know there are no internal -- references convertUnitId' _ (DefiniteUnitId uid) =-    liftST $ UnionFind.fresh (UnitIdThunkU uid)+  liftST $ UnionFind.fresh (UnitIdThunkU uid) convertUnitId' stk (IndefFullUnitId cid insts) = do-    fs <- fmap unify_uniq getUnifEnv-    x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later-    insts_u <- for insts $ convertModule' (extendMuEnv stk x)-    u <- readUnifRef fs-    writeUnifRef fs (u+1)-    y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)-    liftST $ UnionFind.union x y-    return y+  fs <- fmap unify_uniq getUnifEnv+  x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later+  insts_u <- for insts $ convertModule' (extendMuEnv stk x)+  u <- readUnifRef fs+  writeUnifRef fs (u + 1)+  y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)+  liftST $ UnionFind.union x y+  return y+ -- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) -convertModule' :: MuEnv s-               -> OpenModule -> UnifyM s (ModuleU s)+convertModule'+  :: MuEnv s+  -> OpenModule+  -> UnifyM s (ModuleU s) convertModule' _stk (OpenModuleVar mod_name) = do-    hmap <- fmap unify_reqs getUnifEnv-    hm <- readUnifRef hmap-    case Map.lookup mod_name hm of-        Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name)-                      writeUnifRef hmap (Map.insert mod_name mod hm)-                      return mod-        Just mod -> return mod+  hmap <- fmap unify_reqs getUnifEnv+  hm <- readUnifRef hmap+  case Map.lookup mod_name hm of+    Nothing -> do+      mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name)+      writeUnifRef hmap (Map.insert mod_name mod hm)+      return mod+    Just mod -> return mod convertModule' stk (OpenModule uid mod_name) = do-    uid_u <- convertUnitId' stk uid-    liftST $ UnionFind.fresh (ModuleU uid_u mod_name)+  uid_u <- convertUnitId' stk uid+  liftST $ UnionFind.fresh (ModuleU uid_u mod_name)  convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) convertUnitId = convertUnitId' emptyMuEnv@@ -346,8 +352,6 @@ convertModule :: OpenModule -> UnifyM s (ModuleU s) convertModule = convertModule' emptyMuEnv -- ----------------------------------------------------------------------- -- Substitutions @@ -380,9 +384,9 @@  lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int lookupMooEnv (m, i) k =-    case IntMap.lookup k m of-        Nothing -> Nothing-        Just v -> Just (i-v) -- de Bruijn indexize+  case IntMap.lookup k m of+    Nothing -> Nothing+    Just v -> Just (i - v) -- de Bruijn indexize  -- The workhorse functions @@ -390,34 +394,36 @@ -- | Otherwise returns a list of signatures instantiated by given `UnitIdU`. convertUnitIdU' :: MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId convertUnitIdU' stk uid_u required_mod_name = do-    x <- liftST $ UnionFind.find uid_u-    case x of-        UnitIdThunkU uid -> return $ DefiniteUnitId uid-        UnitIdU u cid insts_u ->-            case lookupMooEnv stk u of-                Just _ ->-                    let mod_names = Map.keys insts_u-                    in failWithMutuallyRecursiveUnitsError required_mod_name mod_names-                Nothing -> do-                    insts <- for insts_u $ convertModuleU' (extendMooEnv stk u)-                    return $ IndefFullUnitId cid insts+  x <- liftST $ UnionFind.find uid_u+  case x of+    UnitIdThunkU uid -> return $ DefiniteUnitId uid+    UnitIdU u cid insts_u ->+      case lookupMooEnv stk u of+        Just _ ->+          let mod_names = Map.keys insts_u+           in failWithMutuallyRecursiveUnitsError required_mod_name mod_names+        Nothing -> do+          insts <- for insts_u $ convertModuleU' (extendMooEnv stk u)+          return $ IndefFullUnitId cid insts  convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule convertModuleU' stk mod_u = do-    mod <- liftST $ UnionFind.find mod_u-    case mod of-        ModuleVarU mod_name -> return (OpenModuleVar mod_name)-        ModuleU uid_u mod_name -> do-            uid <- convertUnitIdU' stk uid_u (pretty mod_name)-            return (OpenModule uid mod_name)+  mod <- liftST $ UnionFind.find mod_u+  case mod of+    ModuleVarU mod_name -> return (OpenModuleVar mod_name)+    ModuleU uid_u mod_name -> do+      uid <- convertUnitIdU' stk uid_u (pretty mod_name)+      return (OpenModule uid mod_name)  failWithMutuallyRecursiveUnitsError :: Doc -> [ModuleName] -> UnifyM s a failWithMutuallyRecursiveUnitsError required_mod_name mod_names =-    let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names in-    failWith $-        text "Cannot instantiate requirement" <+> quotes required_mod_name $$-        text "Ensure \"build-depends:\" doesn't include any library with signatures:" <+> sigsList $$-        text "as this creates a cyclic dependency, which GHC does not support."+  let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names+   in failWith $+        text "Cannot instantiate requirement"+          <+> quotes required_mod_name+          $$ text "Ensure \"build-depends:\" doesn't include any library with signatures:"+          <+> sigsList+          $$ text "as this creates a cyclic dependency, which GHC does not support."  -- Helper functions @@ -431,11 +437,12 @@ emptyModuleScopeU :: ModuleScopeU s emptyModuleScopeU = (Map.empty, Map.empty) - -- | The mutable counterpart of 'ModuleScope'. type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s)+ -- | The mutable counterpart of 'ModuleProvides' type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s]+ type ModuleRequiresU s = ModuleProvidesU s type ModuleWithSourceU s = WithSource (ModuleU s) @@ -447,33 +454,41 @@   where     pn = pkgName (ci_pkgid ci)     pp_pn =-        case ci_cname ci of-            CLibName LMainLibName -> pretty pn-            CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn-            -- Shouldn't happen-            cn -> pretty pn <+> parens (pretty cn)+      case ci_cname ci of+        CLibName LMainLibName -> pretty pn+        CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn+        -- Shouldn't happen+        cn -> pretty pn <+> parens (pretty cn)  -- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do -- unification on it. convertInclude-    :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming-    -> UnifyM s (ModuleScopeU s,-                 Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -}-                        (ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -})-convertInclude ci@(ComponentInclude {-                    ci_ann_id = AnnotatedId {-                            ann_id = (uid, ModuleShape provs reqs),-                            ann_pid = pid,-                            ann_cname = compname-                        },-                    ci_renaming = incl@(IncludeRenaming prov_rns req_rns),-                    ci_implicit = implicit-               }) = addErrContext (text "In" <+> ci_msg ci) $ do+  :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming+  -> UnifyM+      s+      ( ModuleScopeU s+      , Either+          (ComponentInclude (UnitIdU s) ModuleRenaming {- normal -})+          (ComponentInclude (UnitIdU s) ModuleRenaming {- sig -})+      )+convertInclude+  ci@( ComponentInclude+        { ci_ann_id =+          AnnotatedId+            { ann_id = (uid, ModuleShape provs reqs)+            , ann_pid = pid+            , ann_cname = compname+            }+        , ci_renaming = incl@(IncludeRenaming prov_rns req_rns)+        , ci_implicit = implicit+        }+      ) = addErrContext (text "In" <+> ci_msg ci) $ do     let pn = packageName pid-        the_source | implicit-                   = FromBuildDepends pn compname-                   | otherwise-                   = FromMixins pn compname incl+        the_source+          | implicit =+              FromBuildDepends pn compname+          | otherwise =+              FromMixins pn compname incl         source = WithSource the_source      -- Suppose our package has two requirements A and B, and@@ -498,27 +513,31 @@       case req_rns of         DefaultRenaming -> return []         HidingRenaming _ -> do-            -- Not valid here for requires!-            addErr $ text "Unsupported syntax" <+>-                     quotes (text "requires hiding (...)")-            return []+          -- Not valid here for requires!+          addErr $+            text "Unsupported syntax"+              <+> quotes (text "requires hiding (...)")+          return []         ModuleRenaming rns -> return rns      let req_rename_listmap :: Map ModuleName [ModuleName]         req_rename_listmap =-            Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ]+          Map.fromListWith (++) [(k, [v]) | (k, v) <- req_rename_list]     req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 ->       case vs0 of-        []  -> error "req_rename"+        [] -> error "req_rename"         [v] -> return v-        v:vs -> do addErr $-                    text "Conflicting renamings of requirement" <+> quotes (pretty k) $$-                    text "Renamed to: " <+> vcat (map pretty (v:vs))-                   return v+        v : vs -> do+          addErr $+            text "Conflicting renamings of requirement"+              <+> quotes (pretty k)+              $$ text "Renamed to: "+              <+> vcat (map pretty (v : vs))+          return v      let req_rename_fn k = case Map.lookup k req_rename of-                            Nothing -> k-                            Just v  -> v+          Nothing -> k+          Just v -> v      -- Requirement substitution.     --@@ -533,19 +552,25 @@     -- mappings.     --     --      A -> X      ==>     X -> <X>, B -> <B>-    reqs_u <- convertModuleRequires . Map.fromList $-                [ (k, [source (OpenModuleVar k)])-                | k <- map req_rename_fn (Set.toList reqs)-                ]+    reqs_u <-+      convertModuleRequires . Map.fromList $+        [ (k, [source (OpenModuleVar k)])+        | k <- map req_rename_fn (Set.toList reqs)+        ]      -- Report errors if there were unused renamings     let leftover = Map.keysSet req_rename `Set.difference` reqs     unless (Set.null leftover) $-        addErr $-            hang (text "The" <+> text (showComponentName compname) <+>-                  text "from package" <+> quotes (pretty pid)-                  <+> text "does not require:") 4-                 (vcat (map pretty (Set.toList leftover)))+      addErr $+        hang+          ( text "The"+              <+> text (showComponentName compname)+              <+> text "from package"+              <+> quotes (pretty pid)+              <+> text "does not require:"+          )+          4+          (vcat (map pretty (Set.toList leftover)))      -- Provision computation is more complex.     -- For example, if we have:@@ -569,56 +594,72 @@     -- Importantly, overlapping rename targets get accumulated     -- together.  It's not an (immediate) error.     (pre_prov_scope, prov_rns') <--        case prov_rns of-            DefaultRenaming -> return (Map.toList provs, prov_rns)-            HidingRenaming hides ->-                let hides_set = Set.fromList hides-                in let r = [ (k,v)-                           | (k,v) <- Map.toList provs-                           , not (k `Set.member` hides_set) ]-                   -- GHC doesn't understand hiding, so expand it out!-                   in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r))-            ModuleRenaming rns -> do-              r <- sequence-                [ case Map.lookup from provs of-                    Just m -> return (to, m)-                    Nothing -> failWith $-                        text "Package" <+> quotes (pretty pid) <+>-                        text "does not expose the module" <+> quotes (pretty from)-                | (from, to) <- rns ]-              return (r, prov_rns)-    let prov_scope = modSubst req_subst-                   $ Map.fromListWith (++)-                   [ (k, [source v])-                   | (k, v) <- pre_prov_scope ]+      case prov_rns of+        DefaultRenaming -> return (Map.toList provs, prov_rns)+        HidingRenaming hides ->+          let hides_set = Set.fromList hides+           in let r =+                    [ (k, v)+                    | (k, v) <- Map.toList provs+                    , not (k `Set.member` hides_set)+                    ]+               in -- GHC doesn't understand hiding, so expand it out!+                  return (r, ModuleRenaming (map ((\x -> (x, x)) . fst) r))+        ModuleRenaming rns -> do+          r <-+            sequence+              [ case Map.lookup from provs of+                Just m -> return (to, m)+                Nothing ->+                  failWith $+                    text "Package"+                      <+> quotes (pretty pid)+                      <+> text "does not expose the module"+                      <+> quotes (pretty from)+              | (from, to) <- rns+              ]+          return (r, prov_rns)+    let prov_scope =+          modSubst req_subst $+            Map.fromListWith+              (++)+              [ (k, [source v])+              | (k, v) <- pre_prov_scope+              ]      provs_u <- convertModuleProvides prov_scope      -- TODO: Assert that provs_u is empty if provs was empty-    return ((provs_u, reqs_u),-                -- NB: We test that requirements is not null so that-                -- users can create packages with zero module exports-                -- that cause some C library to linked in, etc.-                (if Map.null provs && not (Set.null reqs)-                    then Right -- is sig-                    else Left) (ComponentInclude {-                                    ci_ann_id = AnnotatedId {-                                            ann_id = uid_u,-                                            ann_pid = pid,-                                            ann_cname = compname-                                        },-                                    ci_renaming = prov_rns',-                                    ci_implicit = ci_implicit ci-                                    }))+    return+      ( (provs_u, reqs_u)+      , -- NB: We test that requirements is not null so that+        -- users can create packages with zero module exports+        -- that cause some C library to linked in, etc.+        ( if Map.null provs && not (Set.null reqs)+            then Right -- is sig+            else Left+        )+          ( ComponentInclude+              { ci_ann_id =+                  AnnotatedId+                    { ann_id = uid_u+                    , ann_pid = pid+                    , ann_cname = compname+                    }+              , ci_renaming = prov_rns'+              , ci_implicit = ci_implicit ci+              }+          )+      )  -- | Convert a 'ModuleScopeU' to a 'ModuleScope'. convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope convertModuleScopeU (provs_u, reqs_u) = do-    provs <- convertModuleProvidesU provs_u-    reqs  <- convertModuleRequiresU reqs_u-    -- TODO: Test that the requirements are still free. If they-    -- are not, they got unified, and that's dodgy at best.-    return (ModuleScope provs reqs)+  provs <- convertModuleProvidesU provs_u+  reqs <- convertModuleRequiresU reqs_u+  -- TODO: Test that the requirements are still free. If they+  -- are not, they got unified, and that's dodgy at best.+  return (ModuleScope provs reqs)  -- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)

@@ -1,5 +1,6 @@-{-# LANGUAGE CPP                #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+ -- | 'Async', yet using 'MVar's. -- -- Adopted from @async@ library@@ -7,24 +8,38 @@ -- Licensed under BSD-3-Clause -- -- @since 3.2.0.0----module Distribution.Compat.Async (-    AsyncM,-    withAsync, waitCatch,-    wait, asyncThreadId,-    cancel, uninterruptibleCancel, AsyncCancelled (..),+module Distribution.Compat.Async+  ( AsyncM+  , withAsync+  , waitCatch+  , wait+  , asyncThreadId+  , cancel+  , uninterruptibleCancel+  , AsyncCancelled (..)+     -- * Cabal extras-    withAsyncNF,-    ) where+  , withAsyncNF+  ) where -import Control.Concurrent      (ThreadId, forkIO)+import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)-import Control.DeepSeq         (NFData, force)+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)+  ( 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)@@ -33,9 +48,9 @@ -- | 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)+  -- ^ 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@@ -52,12 +67,12 @@ -- 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+withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF)+  where     evaluateNF = evaluate . force  withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b@@ -68,7 +83,8 @@   mask $ \restore -> do     t <- doFork $ try (restore action) >>= putMVar var     let a = Async t var-    r <- restore (inner a) `catchAll` \e -> do+    r <-+      restore (inner a) `catchAll` \e -> do         uninterruptibleCancel a         throwIO e     uninterruptibleCancel a@@ -79,21 +95,19 @@ -- 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+  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)@@ -123,15 +137,18 @@ {-# INLINE cancel #-} cancel :: AsyncM a -> IO () cancel a@(Async t _) = do-    throwTo t AsyncCancelled-    void (waitCatch a)+  throwTo t AsyncCancelled+  void (waitCatch a)  -- | The exception thrown by `cancel` to terminate a thread. data AsyncCancelled = AsyncCancelled-  deriving (Show, Eq+  deriving+    ( Show+    , Eq     , Typeable     ) +{- FOURMOLU_DISABLE -} instance Exception AsyncCancelled where #if MIN_VERSION_base(4,7,0)   -- wraps in SomeAsyncException@@ -139,6 +156,7 @@   fromException = asyncExceptionFromException   toException = asyncExceptionToException #endif+{- FOURMOLU_ENABLE -}  -- | Cancel an asynchronous action --

@@ -1,18 +1,19 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-}-module Distribution.Compat.CopyFile (-  copyFile,-  copyFileChanged,-  filesEqual,-  copyOrdinaryFile,-  copyExecutableFile,-  setFileOrdinary,-  setFileExecutable,-  setDirOrdinary,++module Distribution.Compat.CopyFile+  ( copyFile+  , copyFileChanged+  , filesEqual+  , copyOrdinaryFile+  , copyExecutableFile+  , setFileOrdinary+  , setFileExecutable+  , setDirOrdinary   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  #ifndef mingw32_HOST_OS import Distribution.Compat.Internal.TempFile@@ -66,7 +67,7 @@ #endif /* mingw32_HOST_OS */  copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()-copyOrdinaryFile   src dest = copyFile src dest >> setFileOrdinary   dest+copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest  setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()@@ -93,7 +94,7 @@ copyFile fromFPath toFPath =   copy     `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))-    where+  where #ifndef mingw32_HOST_OS       copy = withBinaryFile fromFPath ReadMode $ \hFrom ->              bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->@@ -239,8 +240,9 @@ filesEqual f1 f2 = do   ex1 <- doesFileExist f1   ex2 <- doesFileExist f2-  if not (ex1 && ex2) then return False else-    withBinaryFile f1 ReadMode $ \h1 ->+  if not (ex1 && ex2)+    then return False+    else withBinaryFile f1 ReadMode $ \h1 ->       withBinaryFile f2 ReadMode $ \h2 -> do         s1 <- hFileSize h1         s2 <- hFileSize h2

@@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-}  module Distribution.Compat.Directory-( listDirectory-, makeAbsolute-, doesPathExist-) where+  ( listDirectory+  , makeAbsolute+  , doesPathExist+  ) where  #if MIN_VERSION_directory(1,2,7) import System.Directory as Dir hiding (doesPathExist)@@ -46,4 +46,3 @@     else doesFileExist path  #endif-

@@ -3,16 +3,15 @@ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Environment-       ( getEnvironment, lookupEnv, setEnv, unsetEnv )-       where+module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv)+where +import Distribution.Compat.Prelude import Prelude () import qualified Prelude-import Distribution.Compat.Prelude -import qualified System.Environment as System import System.Environment (lookupEnv, unsetEnv)+import qualified System.Environment as System  import Distribution.Compat.Stack @@ -61,6 +60,7 @@  where   _ = callStack -- TODO: attach CallStack to exception +{- FOURMOLU_DISABLE -} # if defined(i386_HOST_ARCH) #  define WINDOWS_CCONV stdcall # elif defined(x86_64_HOST_ARCH)@@ -83,3 +83,4 @@ foreign import ccall unsafe "setenv"    c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt #endif /* mingw32_HOST_OS */+{- FOURMOLU_ENABLE -}

@@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-}- {-# OPTIONS_GHC -fno-warn-unused-imports #-}  module Distribution.Compat.FilePath-( isExtensionOf-, stripExtension-) where+  ( isExtensionOf+  , stripExtension+  ) where -import Data.List ( isSuffixOf, stripPrefix )+import Data.List (isSuffixOf, stripPrefix) import System.FilePath  #if !MIN_VERSION_filepath(1,4,2)

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-}  -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Compat.GetShortPathName --@@ -8,12 +9,11 @@ -- Portability :  Windows-only -- -- Win32 API 'GetShortPathName' function.--module Distribution.Compat.GetShortPathName ( getShortPathName )-    where+module Distribution.Compat.GetShortPathName (getShortPathName)+where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  #ifdef mingw32_HOST_OS @@ -22,6 +22,7 @@ import System.Win32          (LPCTSTR, LPTSTR, DWORD) import Foreign.Marshal.Array (allocaArray) +{- FOURMOLU_DISABLE -} #ifdef x86_64_HOST_ARCH #define WINAPI ccall #else@@ -57,3 +58,4 @@ getShortPathName path = return path  #endif+{- FOURMOLU_ENABLE -}

@@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-}-module Distribution.Compat.Internal.TempFile (-  openTempFile,-  openBinaryTempFile,-  openNewBinaryFile,-  createTempDirectory,++module Distribution.Compat.Internal.TempFile+  ( openTempFile+  , openBinaryTempFile+  , openNewBinaryFile+  , createTempDirectory   ) where  import Distribution.Compat.Exception -import System.FilePath        ((</>))+import System.FilePath ((</>)) -import System.IO              (Handle, openTempFile, openBinaryTempFile)+import System.IO (Handle, openBinaryTempFile, openTempFile) #if defined(__IO_MANAGER_WINIO__) import System.IO              (openBinaryTempFileWithDefaultPermissions) #else@@ -23,8 +24,8 @@                                o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY) #endif +import System.IO.Error (isAlreadyExistsError) import System.Posix.Internals (c_getpid)-import System.IO.Error        (isAlreadyExistsError)  #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) import System.Directory       ( createDirectory )@@ -33,7 +34,9 @@ #endif  -- ------------------------------------------------------------+ -- * temporary files+ -- ------------------------------------------------------------  -- This is here for Haskell implementations that do not come with@@ -46,9 +49,10 @@ -- Windows when the new IO manager is used. openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) openNewBinaryFile dir template = do-  -- This method can't be used under WINIO. Also the current implementation has-  -- thread safety issues depending on which GHC is used.  On newer GHC's let's-  -- use the built in one.++-- This method can't be used under WINIO. Also the current implementation has+-- thread safety issues depending on which GHC is used.  On newer GHC's let's+-- use the built in one. #if defined(__IO_MANAGER_WINIO__)   openBinaryTempFileWithDefaultPermissions dir template #else@@ -126,8 +130,9 @@       r <- tryIO $ mkPrivateDir dirpath       case r of         Right _ -> return dirpath-        Left  e | isAlreadyExistsError e -> findTempName (x+1)-                | otherwise              -> ioError e+        Left e+          | isAlreadyExistsError e -> findTempName (x + 1)+          | otherwise -> ioError e  mkPrivateDir :: String -> IO () #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)

@@ -7,8 +7,8 @@ -- for @Setup.hs@ scripts since its API is /not/ -- stable. module Distribution.Compat.Prelude.Internal-    {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-}-    ( module Distribution.Compat.Prelude-    ) where+  {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-}+  ( module Distribution.Compat.Prelude+  ) where  import Distribution.Compat.Prelude

@@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-}-module Distribution.Compat.Process (-    -- * Redefined functions-    proc,++module Distribution.Compat.Process+  ( -- * Redefined functions+    proc+     -- * Additions-    enableProcessJobs,-    ) where+  , enableProcessJobs+  ) where -import           System.Process (CreateProcess)+import System.Process (CreateProcess) import qualified System.Process as Process  #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)@@ -58,4 +60,4 @@ -- | 'System.Process.proc' with process jobs enabled when appropriate, -- and defaulting 'delegate_ctlc' to 'True'. proc :: FilePath -> [String] -> CreateProcess-proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_ctlc = True }+proc path args = enableProcessJobs (Process.proc path args){Process.delegate_ctlc = True}

@@ -1,9 +1,11 @@-{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}  -- Compatibility layer for GHC.ResponseFile -- Implementation from base 4.12.0 is used. -- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE-module Distribution.Compat.ResponseFile (expandResponse) where+module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where  import Distribution.Compat.Prelude import Prelude ()@@ -13,7 +15,7 @@ import System.IO.Error  #if MIN_VERSION_base(4,12,0)-import GHC.ResponseFile (unescapeArgs)+import GHC.ResponseFile (unescapeArgs, escapeArgs) #else  unescapeArgs :: String -> [String]@@ -47,8 +49,28 @@         | '"'  == c              = go cs DblQ  False a     as         | otherwise              = go cs NoneQ False (c:a) as +escapeArgs :: [String] -> String+escapeArgs = unlines . map escapeArg++escapeArg :: String -> String+escapeArg = reverse . foldl' escape []++escape :: String -> Char -> String+escape cs c+  |    isSpace c+    || '\\' == c+    || '\'' == c+    || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result+  | otherwise    = c:cs+ #endif +-- | The arg file / response file parser.+--+-- This is not a well-documented capability, and is a bit eccentric+-- (try @cabal \@foo \@bar@ to see what that does), but is crucial+-- for allowing complex arguments to cabal and cabal-install when+-- using command prompts with strongly-limited argument length. expandResponse :: [String] -> IO [String] expandResponse = go recursionLimit "."   where@@ -56,11 +78,11 @@      go :: Int -> FilePath -> [String] -> IO [String]     go n dir-      | n >= 0    = fmap concat . traverse (expand n dir)+      | n >= 0 = fmap concat . traverse (expand n dir)       | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure      expand :: Int -> FilePath -> String -> IO [String]-    expand n dir arg@('@':f) = readRecursively n (dir </> f) `catchIOError` (const $ print "?" >> return [arg])+    expand n dir arg@('@' : f) = readRecursively n (dir </> f) `catchIOError` const (print "?" >> return [arg])     expand _n _dir x = return [x]      readRecursively :: Int -> FilePath -> IO [String]

@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Compat.SnocList -- License     :  BSD3@@ -8,14 +9,14 @@ -- Portability :  portable -- -- A very reversed list. Has efficient `snoc`-module Distribution.Compat.SnocList (-    SnocList,-    runSnocList,-    snoc,-) where+module Distribution.Compat.SnocList+  ( SnocList+  , runSnocList+  , snoc+  ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  newtype SnocList a = SnocList [a] @@ -26,8 +27,8 @@ runSnocList (SnocList xs) = reverse xs  instance Semigroup (SnocList a) where-    SnocList xs <> SnocList ys = SnocList (ys <> xs)+  SnocList xs <> SnocList ys = SnocList (ys <> xs)  instance Monoid (SnocList a) where-    mempty = SnocList []-    mappend = (<>)+  mempty = SnocList []+  mappend = (<>)

@@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ImplicitParams #-}-module Distribution.Compat.Stack (-    WithCallStack,-    CallStack,-    annotateCallStackIO,-    withFrozenCallStack,-    withLexicalCallStack,-    callStack,-    prettyCallStack,-    parentSrcLocPrefix-) where+{-# LANGUAGE RankNTypes #-} +module Distribution.Compat.Stack+  ( WithCallStack+  , CallStack+  , annotateCallStackIO+  , withFrozenCallStack+  , withLexicalCallStack+  , callStack+  , prettyCallStack+  , parentSrcLocPrefix+  ) where+ import System.IO.Error  #ifdef MIN_VERSION_base@@ -106,8 +107,9 @@ annotateCallStackIO :: WithCallStack (IO a -> IO a) annotateCallStackIO = modifyIOError f   where-    f ioe = ioeSetErrorString ioe-          . wrapCallStack-          $ ioeGetErrorString ioe+    f ioe =+      ioeSetErrorString ioe+        . wrapCallStack+        $ ioeGetErrorString ioe     wrapCallStack s =-        prettyCallStack callStack ++ "\n" ++ s+      prettyCallStack callStack ++ "\n" ++ s

@@ -1,32 +1,33 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}  module Distribution.Compat.Time-       ( ModTime(..) -- Needed for testing-       , getModTime, getFileAge, getCurTime-       , posixSecondsToModTime-       , calibrateMtimeChangeDelay )-       where+  ( ModTime (..) -- Needed for testing+  , getModTime+  , getFileAge+  , getCurTime+  , posixSecondsToModTime+  , calibrateMtimeChangeDelay+  )+where -import Prelude () import Distribution.Compat.Prelude+import Prelude () -import System.Directory ( getModificationTime )+import System.Directory (getModificationTime) -import Distribution.Simple.Utils ( withTempDirectory )-import Distribution.Verbosity ( silent )+import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Verbosity (silent)  import System.FilePath -import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime )-import Data.Time             ( diffUTCTime, getCurrentTime )-import Data.Time.Clock.POSIX ( posixDayLength )-+import Data.Time (diffUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength)  #if defined mingw32_HOST_OS @@ -57,7 +58,7 @@ -- | 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, Generic, Bounded, Eq, Ord, Typeable)+  deriving (Binary, Generic, Bounded, Eq, Ord, Typeable)  instance Structured ModTime @@ -101,6 +102,7 @@ #endif       return $! ModTime (qwTime :: Word64) +{- FOURMOLU_DISABLE -} #ifdef x86_64_HOST_ARCH #define CALLCONV ccall #else@@ -138,9 +140,10 @@ extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)  #endif+{- FOURMOLU_ENABLE -}  windowsTick, secToUnixEpoch :: Word64-windowsTick    = 10000000+windowsTick = 10000000 secToUnixEpoch = 11644473600  -- | Convert POSIX seconds to ModTime.@@ -150,8 +153,10 @@  -- | Convert 'POSIXTime' to 'ModTime'. posixTimeToModTime :: POSIXTime -> ModTime-posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision-                       + (secToUnixEpoch * windowsTick)+posixTimeToModTime p =+  ModTime $+    ceiling (p * 1e7) -- 100 ns precision+      + (secToUnixEpoch * windowsTick)  -- | Return age of given file in days. getFileAge :: FilePath -> IO Double@@ -174,15 +179,15 @@ calibrateMtimeChangeDelay =   withTempDirectory silent "." "calibration-" $ \dir -> do     let fileName = dir </> "probe"-    mtimes <- for [1..25] $ \(i::Int) -> time $ do+    mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do       writeFile fileName $ show i       t0 <- getModTime fileName       let spin j = do-            writeFile fileName $ show (i,j)+            writeFile fileName $ show (i, j)             t1 <- getModTime fileName             unless (t0 < t1) (spin $ j + 1)-      spin (0::Int)-    let mtimeChange  = maximum mtimes+      spin (0 :: Int)+    let mtimeChange = maximum mtimes         mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2     return (mtimeChange, mtimeChange')   where

@@ -1,4 +1,8 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TupleSections #-}+ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.GetOpt -- Copyright   :  (c) Sven Panne 2002-2005@@ -20,78 +24,84 @@ -- * Parsing of option arguments is allowed to fail. -- -- * 'ReturnInOrder' argument order is removed.----{-# LANGUAGE TupleSections #-}-{-# LANGUAGE NamedFieldPuns #-}-module Distribution.GetOpt (-   -- * GetOpt-   getOpt, getOpt',-   usageInfo,-   ArgOrder(..),-   OptDescr(..),-   ArgDescr(..),+module Distribution.GetOpt+  ( -- * GetOpt+    getOpt+  , getOpt'+  , usageInfo+  , ArgOrder (..)+  , OptDescr (..)+  , ArgDescr (..) -   -- * Example-   -- | See "System.Console.GetOpt" for examples-) where+    -- * Example -import Prelude ()+    -- | See "System.Console.GetOpt" for examples+  ) where+ import Distribution.Compat.Prelude+import Prelude ()  -- | What to do with options following non-options data ArgOrder a-  = RequireOrder                -- ^ no option processing after first non-option-  | Permute                     -- ^ freely intersperse options and non-options+  = -- | no option processing after first non-option+    RequireOrder+  | -- | freely intersperse options and non-options+    Permute -data OptDescr a =              -- description of a single options:-   Option [Char]                --    list of short option characters-          [String]              --    list of long option strings (without "--")-          (ArgDescr a)          --    argument descriptor-          String                --    explanation of option for user+data OptDescr a -- description of a single options:+  = Option+      [Char] --    list of short option characters+      [String] --    list of long option strings (without "--")+      (ArgDescr a) --    argument descriptor+      String --    explanation of option for user  instance Functor OptDescr where-    fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c+  fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c  -- | Describes whether an option takes an argument or not, and if so -- how the argument is parsed to a value of type @a@. -- -- Compared to System.Console.GetOpt, we allow for parse errors. data ArgDescr a-   = NoArg                   a                       -- ^   no argument expected-   | ReqArg (String       -> Either String a) String -- ^   option requires argument-   | OptArg (Maybe String -> Either String a) String -- ^   optional argument+  = -- |   no argument expected+    NoArg a+  | -- |   option requires argument+    ReqArg (String -> Either String a) String+  | -- |   optional argument+    OptArg String (Maybe String -> Either String a) String  instance Functor ArgDescr where-    fmap f (NoArg a)    = NoArg (f a)-    fmap f (ReqArg g s) = ReqArg (fmap f . g) s-    fmap f (OptArg g s) = OptArg (fmap f . g) s+  fmap f (NoArg a) = NoArg (f a)+  fmap f (ReqArg g s) = ReqArg (fmap f . g) s+  fmap f (OptArg dv g s) = OptArg dv (fmap f . g) s -data OptKind a                -- kind of cmd line arg (internal use only):-   = Opt       a                --    an option-   | UnreqOpt  String           --    an un-recognized option-   | NonOpt    String           --    a non-option-   | EndOfOpts                  --    end-of-options marker (i.e. "--")-   | OptErr    String           --    something went wrong...+data OptKind a -- kind of cmd line arg (internal use only):+  = Opt a --    an option+  | UnreqOpt String --    an un-recognized option+  | NonOpt String --    a non-option+  | EndOfOpts --    end-of-options marker (i.e. "--")+  | OptErr String --    something went wrong... -data OptHelp = OptHelp {-      optNames :: String,-      optHelp :: String-    }+data OptHelp = OptHelp+  { optNames :: String+  , optHelp :: String+  }  -- | Return a string describing the usage of a command, derived from -- the header (first argument) and the options described by the -- second argument.-usageInfo :: String                    -- header-          -> [OptDescr a]              -- option descriptors-          -> String                    -- nicely formatted description of options+usageInfo+  :: String -- header+  -> [OptDescr a] -- option descriptors+  -> String -- nicely formatted description of options usageInfo header optDescr = unlines (header : table)   where     options = flip map optDescr $ \(Option sos los ad d) ->       OptHelp         { optNames =-          intercalate ", " $-            map (fmtShort ad) sos ++-            map (fmtLong  ad) (take 1 los)+            intercalate ", " $+              map (fmtShort ad) sos+                ++ map (fmtLong ad) (take 1 los)         , optHelp = d         } @@ -103,8 +113,9 @@       OptHelp{optNames, optHelp} <- options       let wrappedHelp = wrapText descolWidth optHelp       if length optNames >= maxOptNameWidth-        then [" " ++ optNames] ++-             renderColumns [] wrappedHelp+        then+          [" " ++ optNames]+            ++ renderColumns [] wrappedHelp         else renderColumns [optNames] wrappedHelp      renderColumns :: [String] -> [String] -> [String]@@ -112,146 +123,179 @@       (x, y) <- zipDefault "" "" xs ys       return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y -    padTo n x  = take n (x ++ repeat ' ')+    padTo n x = take n (x ++ repeat ' ') -zipDefault :: a -> b -> [a] -> [b] -> [(a,b)]-zipDefault _  _  []     []     = []-zipDefault _  bd (a:as) []     = (a,bd) : map (,bd) as-zipDefault ad _  []     (b:bs) = (ad,b) : map (ad,) bs-zipDefault ad bd (a:as) (b:bs) = (a,b)  : zipDefault ad bd as bs+zipDefault :: a -> b -> [a] -> [b] -> [(a, b)]+zipDefault _ _ [] [] = []+zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as+zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs+zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs +-- | Pretty printing of short options.+-- * With required arguments can be given as:+--    @-w PATH or -wPATH (but not -w=PATH)@+--   This is dislayed as:+--    @-w PATH or -wPATH@+-- * With optional but default arguments can be given as:+--    @-j or -jNUM (but not -j=NUM or -j NUM)@+--   This is dislayed as:+--    @-j[NUM]@ fmtShort :: ArgDescr a -> Char -> String-fmtShort (NoArg  _   ) so = "-" ++ [so]-fmtShort (ReqArg _  _) so = "-" ++ [so]-fmtShort (OptArg _  _) so = "-" ++ [so]-  -- unlike upstream GetOpt we omit the arg name for short options+fmtShort (NoArg _) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so =+  let opt = "-" ++ [so]+   in opt ++ " " ++ ad ++ " or " ++ opt ++ ad+fmtShort (OptArg _ _ ad) so =+  let opt = "-" ++ [so]+   in opt ++ "[" ++ ad ++ "]" +-- | Pretty printing of long options.+-- * With required arguments can be given as:+--    @--with-compiler=PATH (but not --with-compiler PATH)@+--   This is dislayed as:+--    @--with-compiler=PATH@+-- * With optional but default arguments can be given as:+--    @--jobs or --jobs=NUM (but not --jobs NUM)@+--   This is dislayed as:+--    @--jobs[=NUM]@ fmtLong :: ArgDescr a -> String -> String-fmtLong (NoArg  _   ) lo = "--" ++ lo-fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad-fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"+fmtLong (NoArg _) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo =+  let opt = "--" ++ lo+   in opt ++ "=" ++ ad+fmtLong (OptArg _ _ ad) lo =+  let opt = "--" ++ lo+   in opt ++ "[=" ++ ad ++ "]"  wrapText :: Int -> String -> [String] wrapText width = map unwords . wrap 0 [] . words-  where wrap :: Int -> [String] -> [String] -> [[String]]-        wrap 0   []   (w:ws)-          | length w + 1 > width-          = wrap (length w) [w] ws-        wrap col line (w:ws)-          | col + length w + 1 > width-          = reverse line : wrap 0 [] (w:ws)-        wrap col line (w:ws)-          = let col' = col + length w + 1-             in wrap col' (w:line) ws-        wrap _ []   [] = []-        wrap _ line [] = [reverse line]--{-|-Process the command-line, and return the list of values that matched-(and those that didn\'t). The arguments are:--* The order requirements (see 'ArgOrder')--* The option descriptions (see 'OptDescr')--* The actual command line arguments (presumably got from-  'System.Environment.getArgs').+  where+    wrap :: Int -> [String] -> [String] -> [[String]]+    wrap 0 [] (w : ws)+      | length w + 1 > width =+          wrap (length w) [w] ws+    wrap col line (w : ws)+      | col + length w + 1 > width =+          reverse line : wrap 0 [] (w : ws)+    wrap col line (w : ws) =+      let col' = col + length w + 1+       in wrap col' (w : line) ws+    wrap _ [] [] = []+    wrap _ line [] = [reverse line] -'getOpt' returns a triple consisting of the option arguments, a list-of non-options, and a list of error messages.--}-getOpt :: ArgOrder a                   -- non-option handling-       -> [OptDescr a]                 -- option descriptors-       -> [String]                     -- the command-line arguments-       -> ([a],[String],[String])      -- (options,non-options,error messages)-getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)-   where (os,xs,us,es) = getOpt' ordering optDescr args+-- |+-- Process the command-line, and return the list of values that matched+-- (and those that didn\'t). The arguments are:+--+-- * The order requirements (see 'ArgOrder')+--+-- * The option descriptions (see 'OptDescr')+--+-- * The actual command line arguments (presumably got from+--   'System.Environment.getArgs').+--+-- 'getOpt' returns a triple consisting of the option arguments, a list+-- of non-options, and a list of error messages.+getOpt+  :: ArgOrder a -- non-option handling+  -> [OptDescr a] -- option descriptors+  -> [String] -- the command-line arguments+  -> ([a], [String], [String]) -- (options,non-options,error messages)+getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us)+  where+    (os, xs, us, es) = getOpt' ordering optDescr args -{-|-This is almost the same as 'getOpt', but returns a quadruple-consisting of the option arguments, a list of non-options, a list of-unrecognized options, and a list of error messages.--}-getOpt' :: ArgOrder a                         -- non-option handling-        -> [OptDescr a]                       -- option descriptors-        -> [String]                           -- the command-line arguments-        -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)-getOpt' _        _        []         =  ([],[],[],[])-getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering-   where procNextOpt (Opt o)      _                 = (o:os,xs,us,es)-         procNextOpt (UnreqOpt u) _                 = (os,xs,u:us,es)-         procNextOpt (NonOpt x)   RequireOrder      = ([],x:rest,[],[])-         procNextOpt (NonOpt x)   Permute           = (os,x:xs,us,es)-         procNextOpt EndOfOpts    RequireOrder      = ([],rest,[],[])-         procNextOpt EndOfOpts    Permute           = ([],rest,[],[])-         procNextOpt (OptErr e)   _                 = (os,xs,us,e:es)+-- |+-- This is almost the same as 'getOpt', but returns a quadruple+-- consisting of the option arguments, a list of non-options, a list of+-- unrecognized options, and a list of error messages.+getOpt'+  :: ArgOrder a -- non-option handling+  -> [OptDescr a] -- option descriptors+  -> [String] -- the command-line arguments+  -> ([a], [String], [String], [String]) -- (options,non-options,unrecognized,error messages)+getOpt' _ _ [] = ([], [], [], [])+getOpt' ordering optDescr (arg : args) = procNextOpt opt ordering+  where+    procNextOpt (Opt o) _ = (o : os, xs, us, es)+    procNextOpt (UnreqOpt u) _ = (os, xs, u : us, es)+    procNextOpt (NonOpt x) RequireOrder = ([], x : rest, [], [])+    procNextOpt (NonOpt x) Permute = (os, x : xs, us, es)+    procNextOpt EndOfOpts RequireOrder = ([], rest, [], [])+    procNextOpt EndOfOpts Permute = ([], rest, [], [])+    procNextOpt (OptErr e) _ = (os, xs, us, e : es) -         (opt,rest) = getNext arg args optDescr-         (os,xs,us,es) = getOpt' ordering optDescr rest+    (opt, rest) = getNext arg args optDescr+    (os, xs, us, es) = getOpt' ordering optDescr rest  -- take a look at the next cmd line arg and decide what to do with it-getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])-getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)-getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr-getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr-getNext a            rest _        = (NonOpt a,rest)+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])+getNext ('-' : '-' : []) rest _ = (EndOfOpts, rest)+getNext ('-' : '-' : xs) rest optDescr = longOpt xs rest optDescr+getNext ('-' : x : xs) rest optDescr = shortOpt x xs rest optDescr+getNext a rest _ = (NonOpt a, rest)  -- handle long option-longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) longOpt ls rs optDescr = long ads arg rs-   where (opt,arg) = break (=='=') ls-         getWith p = [ o  | o@(Option _ xs _ _) <- optDescr-                          , isJust (find (p opt) xs)]-         exact     = getWith (==)-         options   = if null exact then getWith isPrefixOf else exact-         ads       = [ ad | Option _ _ ad _ <- options ]-         optStr    = "--" ++ opt-         fromRes   = fromParseResult optStr+  where+    (opt, arg) = break (== '=') ls+    getWith p =+      [ o | o@(Option _ xs _ _) <- optDescr, isJust (find (p opt) xs)+      ]+    exact = getWith (==)+    options = if null exact then getWith isPrefixOf else exact+    ads = [ad | Option _ _ ad _ <- options]+    optStr = "--" ++ opt+    fromRes = fromParseResult optStr -         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)-         long [NoArg  a  ] []       rest     = (Opt a,rest)-         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)-         long [ReqArg _ d] []       []       = (errReq d optStr,[])-         long [ReqArg f _] []       (r:rest) = (fromRes (f r),rest)-         long [ReqArg f _] ('=':xs) rest     = (fromRes (f xs),rest)-         long [OptArg f _] []       rest     = (fromRes (f Nothing),rest)-         long [OptArg f _] ('=':xs) rest     = (fromRes (f (Just xs)),rest)-         long _            _        rest     = (UnreqOpt ("--"++ls),rest)+    long (_ : _ : _) _ rest = (errAmbig options optStr, rest)+    long [NoArg a] [] rest = (Opt a, rest)+    long [NoArg _] ('=' : _) rest = (errNoArg optStr, rest)+    long [ReqArg _ d] [] [] = (errReq d optStr, [])+    long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest)+    long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest)+    long [OptArg _ f _] [] rest = (fromRes (f Nothing), rest)+    long [OptArg _ f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest)+    long _ _ rest = (UnreqOpt ("--" ++ ls), rest)  -- handle short option-shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String]) shortOpt y ys rs optDescr = short ads ys rs-  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]-        ads     = [ ad | Option _ _ ad _ <- options ]-        optStr  = '-':[y]-        fromRes = fromParseResult optStr+  where+    options = [o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s]+    ads = [ad | Option _ _ ad _ <- options]+    optStr = '-' : [y]+    fromRes = fromParseResult optStr -        short (_:_:_)        _  rest     = (errAmbig options optStr,rest)-        short (NoArg  a  :_) [] rest     = (Opt a,rest)-        short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)-        short (ReqArg _ d:_) [] []       = (errReq d optStr,[])-        short (ReqArg f _:_) [] (r:rest) = (fromRes (f r),rest)-        short (ReqArg f _:_) xs rest     = (fromRes (f xs),rest)-        short (OptArg f _:_) [] rest     = (fromRes (f Nothing),rest)-        short (OptArg f _:_) xs rest     = (fromRes (f (Just xs)),rest)-        short []             [] rest     = (UnreqOpt optStr,rest)-        short []             xs rest     = (UnreqOpt (optStr++xs),rest)-        -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)-        -- Apparently this was part of the change so that flags that are-        -- not recognised as global flags are passed on to the sub-command.-        -- But why was no equivalent change required for longOpt? So could-        -- this change go upstream?+    short (_ : _ : _) _ rest = (errAmbig options optStr, rest)+    short (NoArg a : _) [] rest = (Opt a, rest)+    short (NoArg a : _) xs rest = (Opt a, ('-' : xs) : rest)+    short (ReqArg _ d : _) [] [] = (errReq d optStr, [])+    short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest)+    short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest)+    short (OptArg _ f _ : _) [] rest = (fromRes (f Nothing), rest)+    short (OptArg _ f _ : _) xs rest = (fromRes (f (Just xs)), rest)+    short [] [] rest = (UnreqOpt optStr, rest)+    short [] xs rest = (UnreqOpt (optStr ++ xs), rest) +-- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)+-- Apparently this was part of the change so that flags that are+-- not recognised as global flags are passed on to the sub-command.+-- But why was no equivalent change required for longOpt? So could+-- this change go upstream?+ fromParseResult :: String -> Either String a -> OptKind a fromParseResult optStr res = case res of-  Right x   -> Opt x-  Left  err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n")+  Right x -> Opt x+  Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n")  -- miscellaneous error formatting  errAmbig :: [OptDescr a] -> String -> OptKind b errAmbig ods optStr = OptErr (usageInfo header ods)-   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"+  where+    header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"  errReq :: String -> String -> OptKind a errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")

@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+ -- | -- Module      :  Distribution.Lex -- Copyright   :  Ben Gamari 2015-2019@@ -7,34 +8,43 @@ -- Portability :  portable -- -- This module contains a simple lexer supporting quoted strings--module Distribution.Lex (-        tokenizeQuotedWords- ) where+module Distribution.Lex+  ( tokenizeQuotedWords+  ) where -import Prelude ()-import Distribution.Compat.Prelude import Distribution.Compat.DList+import Distribution.Compat.Prelude+import Prelude () +-- | A simple parser supporting quoted strings.+--+-- Please be aware that this will only split strings when seeing whitespace+-- outside of quotation marks, i.e, @"foo\"bar baz\"qux quux"@ will be+-- converted to @["foobar bazqux", "quux"]@.+--+-- This behavior can be useful when parsing text like+-- @"ghc-options: -Wl,\"some option with spaces\""@, for instance. tokenizeQuotedWords :: String -> [String] tokenizeQuotedWords = filter (not . null) . go False mempty   where-    go :: Bool        -- ^ in quoted region-       -> DList Char  -- ^ accumulator-       -> String      -- ^ string to be parsed-       -> [String]    -- ^ parse result+    go+      :: Bool+      -- \^ in quoted region+      -> DList Char+      -- \^ accumulator+      -> String+      -- \^ string to be parsed+      -> [String]+    -- \^ parse result     go _ accum []       | [] <- accum' = []-      | otherwise    = [accum']-      where accum' = runDList accum--    go False  accum (c:cs)+      | otherwise = [accum']+      where+        accum' = runDList accum+    go False accum (c : cs)       | isSpace c = runDList accum : go False mempty cs-      | c == '"'  = go True accum cs--    go True   accum (c:cs)-      | c == '"'  = go False accum cs--    go quoted accum (c:cs)-                  = go quoted (accum `mappend` singleton c) cs-+      | c == '"' = go True accum cs+    go True accum (c : cs)+      | c == '"' = go False accum cs+    go quoted accum (c : cs) =+      go quoted (accum `mappend` singleton c) cs

@@ -2,6 +2,11 @@ {-# LANGUAGE RankNTypes #-}  -----------------------------------------------------------------------------++--                      copy :+--                              $(MAKE) install prefix=$(destdir)/$(prefix) \+--                                              bindir=$(destdir)/$(bindir) \+ -- | -- Module      :  Distribution.Make -- Copyright   :  Martin Sj&#xF6;gren 2004@@ -51,32 +56,28 @@ -- [UnregisterCmd] We assume there is an @unregister@ target. -- -- [HaddockCmd] We assume there is a @docs@ or @doc@ target.-----                      copy :---                              $(MAKE) install prefix=$(destdir)/$(prefix) \---                                              bindir=$(destdir)/$(bindir) \--module Distribution.Make (-        module Distribution.Package,-        License(..), Version,-        defaultMain, defaultMainArgs+module Distribution.Make+  ( module Distribution.Package+  , License (..)+  , Version+  , defaultMain+  , defaultMainArgs   ) where -import Prelude () import Distribution.Compat.Prelude+import Prelude ()  -- local import Distribution.Package+import Distribution.Simple.Command import Distribution.Simple.Program import Distribution.Simple.Setup-import Distribution.Simple.Command  import Distribution.Simple.Utils  import Distribution.License-import Distribution.Version import Distribution.Pretty+import Distribution.Version  import System.Environment (getArgs, getProgName) @@ -87,20 +88,21 @@ defaultMainArgs = defaultMainHelper  defaultMainHelper :: [String] -> IO ()-defaultMainHelper args =-  case commandsRun (globalCommand commands) commands args of-    CommandHelp   help                 -> printHelp help-    CommandList   opts                 -> printOptionsList opts-    CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (flags, commandParse)  ->+defaultMainHelper args = do+  command <- commandsRun (globalCommand commands) commands args+  case command of+    CommandHelp help -> printHelp help+    CommandList opts -> printOptionsList opts+    CommandErrors errs -> printErrors errs+    CommandReadyToGo (flags, commandParse) ->       case commandParse of-        _ | fromFlag (globalVersion flags)        -> printVersion+        _+          | fromFlag (globalVersion flags) -> printVersion           | fromFlag (globalNumericVersion flags) -> printNumericVersion-        CommandHelp     help           -> printHelp help-        CommandList     opts           -> printOptionsList opts-        CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> action-+        CommandHelp help -> printHelp help+        CommandList opts -> printOptionsList opts+        CommandErrors errs -> printErrors errs+        CommandReadyToGo action -> action   where     printHelp help = getProgName >>= putStr . help     printOptionsList = putStr . unlines@@ -108,20 +110,22 @@       putStr (intercalate "\n" errs)       exitWith (ExitFailure 1)     printNumericVersion = putStrLn $ prettyShow cabalVersion-    printVersion        = putStrLn $ "Cabal library version "-                                  ++ prettyShow cabalVersion+    printVersion =+      putStrLn $+        "Cabal library version "+          ++ prettyShow cabalVersion      progs = defaultProgramDb     commands =-      [configureCommand progs `commandAddAction` configureAction-      ,buildCommand     progs `commandAddAction` buildAction-      ,installCommand         `commandAddAction` installAction-      ,copyCommand            `commandAddAction` copyAction-      ,haddockCommand         `commandAddAction` haddockAction-      ,cleanCommand           `commandAddAction` cleanAction-      ,sdistCommand           `commandAddAction` sdistAction-      ,registerCommand        `commandAddAction` registerAction-      ,unregisterCommand      `commandAddAction` unregisterAction+      [ configureCommand progs `commandAddAction` configureAction+      , buildCommand progs `commandAddAction` buildAction+      , installCommand `commandAddAction` installAction+      , copyCommand `commandAddAction` copyAction+      , haddockCommand `commandAddAction` haddockAction+      , cleanCommand `commandAddAction` cleanAction+      , sdistCommand `commandAddAction` sdistAction+      , registerCommand `commandAddAction` registerAction+      , unregisterCommand `commandAddAction` unregisterAction       ]  configureAction :: ConfigFlags -> [String] -> IO ()@@ -130,16 +134,17 @@   let verbosity = fromFlag (configVerbosity flags)   rawSystemExit verbosity "sh" $     "configure"-    : configureArgs backwardsCompatHack flags-  where backwardsCompatHack = True+      : configureArgs backwardsCompatHack flags+  where+    backwardsCompatHack = True  copyAction :: CopyFlags -> [String] -> IO () copyAction flags args = do   noExtraFlags args   let destArgs = case fromFlag $ copyDest flags of-        NoCopyDest      -> ["install"]-        CopyTo path     -> ["copy", "destdir=" ++ path]-        CopyToDb _      -> error "CopyToDb not supported via Make"+        NoCopyDest -> ["install"]+        CopyTo path -> ["copy", "destdir=" ++ path]+        CopyToDb _ -> error "CopyToDb not supported via Make"    rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs @@ -154,7 +159,7 @@   noExtraFlags args   rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]     `catchIO` \_ ->-    rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]+      rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]  buildAction :: BuildFlags -> [String] -> IO () buildAction flags args = do@@ -172,7 +177,7 @@   rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"]  registerAction :: RegisterFlags -> [String] -> IO ()-registerAction  flags args = do+registerAction flags args = do   noExtraFlags args   rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] 

@@ -1,2939 +1,1084 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Check--- Copyright   :  Lennart Kolmodin 2008--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This has code for checking for various problems in packages. There is one--- set of checks that just looks at a 'PackageDescription' in isolation and--- another set of checks that also looks at files in the package. Some of the--- checks are basic sanity checks, others are portability standards that we'd--- like to encourage. There is a 'PackageCheck' type that distinguishes the--- different kinds of checks so we can see which ones are appropriate to report--- in different situations. This code gets used when configuring a package when--- we consider only basic problems. The higher standard is used when--- preparing a source tarball and by Hackage when uploading new packages. The--- reason for this is that we want to hold packages that are expected to be--- distributed to a higher standard than packages that are only ever expected--- to be used on the author's own environment.--module Distribution.PackageDescription.Check (-        -- * Package Checking-        CheckExplanation(..),-        PackageCheck(..),-        checkPackage,-        checkConfiguredPackage,-        wrapParseWarning,-        ppPackageCheck,--        -- ** Checking package contents-        checkPackageFiles,-        checkPackageContent,-        CheckPackageContentOps(..),-        checkPackageFileNames,-  ) where--import Data.Foldable                                 (foldrM)-import Distribution.Compat.Prelude-import Prelude ()--import Data.List                                     (delete, group)-import Distribution.CabalSpecVersion-import Distribution.Compat.Lens-import Distribution.Compiler-import Distribution.License-import Distribution.ModuleName                       (ModuleName)-import Distribution.Package-import Distribution.PackageDescription-import Distribution.PackageDescription.Configuration-import Distribution.Parsec.Warning                   (PWarning, showPWarning)-import Distribution.Pretty                           (prettyShow)-import Distribution.Simple.BuildPaths                (autogenPackageInfoModuleName, autogenPathsModuleName)-import Distribution.Simple.BuildToolDepends-import Distribution.Simple.CCompiler-import Distribution.Simple.Glob-import Distribution.Simple.Utils                     hiding (findPackageDesc, notice)-import Distribution.System-import Distribution.Types.ComponentRequestedSpec-import Distribution.Types.PackageName.Magic-import Distribution.Utils.Generic                    (isAscii)-import Distribution.Verbosity-import Distribution.Version-import Distribution.Utils.Path-import Language.Haskell.Extension-import System.FilePath-       ( makeRelative, normalise, splitDirectories, splitExtension, splitPath-       , takeExtension, takeFileName, (<.>), (</>))--import qualified Data.ByteString.Lazy      as BS-import qualified Data.Map                  as Map-import qualified Control.Monad             as CM-import qualified Distribution.Compat.DList as DList-import qualified Distribution.SPDX         as SPDX-import qualified System.Directory          as System--import qualified System.Directory        (getDirectoryContents)-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-import qualified Distribution.Types.PackageDescription.Lens        as L---- $setup--- >>> import Control.Arrow ((&&&))---- --------------------------------------------------------------- * Warning messages--- ---------------------------------------------------------------- | Which stanza does `CheckExplanation` refer to?----data CEType = CETLibrary | CETExecutable | CETTest | CETBenchmark-    deriving (Eq, Ord, Show)---- | Pretty printing `CEType`.----ppCE :: CEType -> String-ppCE CETLibrary = "library"-ppCE CETExecutable = "executable"-ppCE CETTest = "test suite"-ppCE CETBenchmark = "benchmark"---- | Which field does `CheckExplanation` refer to?----data CEField = CEFCategory | CEFMaintainer | CEFSynopsis-             | CEFDescription | CEFSynOrDesc-    deriving (Eq, Ord, Show)---- | Pretty printing `CEField`.----ppCEField :: CEField -> String-ppCEField CEFCategory = "category"-ppCEField CEFMaintainer = "maintainer"-ppCEField CEFSynopsis = "synopsis"-ppCEField CEFDescription = "description"-ppCEField CEFSynOrDesc = "synopsis' or 'description"---- | Explanations of 'PackageCheck`'s errors/warnings.----data CheckExplanation =-          ParseWarning FilePath PWarning-        | NoNameField-        | NoVersionField-        | NoTarget-        | UnnamedInternal-        | DuplicateSections [UnqualComponentName]-        | IllegalLibraryName PackageDescription-        | NoModulesExposed Library-        | SignaturesCabal2-        | AutogenNotExposed-        | AutogenIncludesNotIncluded-        | NoMainIs Executable-        | NoHsLhsMain-        | MainCCabal1_18-        | AutogenNoOther CEType UnqualComponentName-        | AutogenIncludesNotIncludedExe-        | TestsuiteTypeNotKnown TestType-        | TestsuiteNotSupported TestType-        | BenchmarkTypeNotKnown BenchmarkType-        | BenchmarkNotSupported BenchmarkType-        | NoHsLhsMainBench-        | InvalidNameWin PackageDescription-        | ZPrefix-        | NoBuildType-        | NoCustomSetup-        | UnknownCompilers [String]-        | UnknownLanguages [String]-        | UnknownExtensions [String]-        | LanguagesAsExtension [String]-        | DeprecatedExtensions [(Extension, Maybe Extension)]-        | MissingField CEField-        | SynopsisTooLong-        | ShortDesc-        | InvalidTestWith [Dependency]-        | ImpossibleInternalDep [Dependency]-        | ImpossibleInternalExe [ExeDependency]-        | MissingInternalExe [ExeDependency]-        | NONELicense-        | NoLicense-        | AllRightsReservedLicense-        | LicenseMessParse PackageDescription-        | UnrecognisedLicense String-        | UncommonBSD4-        | UnknownLicenseVersion License [Version]-        | NoLicenseFile-        | UnrecognisedSourceRepo String-        | MissingType-        | MissingLocation-        | MissingModule-        | MissingTag-        | SubdirRelPath-        | SubdirGoodRelPath String-        | OptFasm String-        | OptViaC String-        | OptHpc String-        | OptProf String-        | OptO String-        | OptHide String-        | OptMake String-        | OptONot String-        | OptOOne String-        | OptOTwo String-        | OptSplitSections String-        | OptSplitObjs String-        | OptWls String-        | OptExts String-        | OptRts String-        | OptWithRts String-        | COptONumber String String-        | COptCPP String-        | OptAlternatives String String [(String, String)]-        | RelativeOutside String FilePath-        | AbsolutePath String FilePath-        | BadRelativePAth String FilePath String-        | DistPoint (Maybe String) FilePath-        | GlobSyntaxError String String-        | RecursiveGlobInRoot String FilePath-        | InvalidOnWin [FilePath]-        | FilePathTooLong FilePath-        | FilePathNameTooLong FilePath-        | FilePathSplitTooLong FilePath-        | FilePathEmpty-        | CVTestSuite-        | CVDefaultLanguage-        | CVDefaultLanguageComponent-        | CVExtraDocFiles-        | CVMultiLib-        | CVReexported-        | CVMixins-        | CVExtraFrameworkDirs-        | CVDefaultExtensions-        | CVExtensionsDeprecated-        | CVSources-        | CVExtraDynamic [[String]]-        | CVVirtualModules-        | CVSourceRepository-        | CVExtensions CabalSpecVersion [Extension]-        | CVCustomSetup-        | CVExpliticDepsCustomSetup-        | CVAutogenPaths-        | CVAutogenPackageInfo-        | CVAutogenPackageInfoGuard-        | GlobNoMatch String String-        | GlobExactMatch String String FilePath-        | GlobNoDir String String FilePath-        | UnknownOS [String]-        | UnknownArch [String]-        | UnknownCompiler [String]-        | BaseNoUpperBounds-        | MissingUpperBounds [PackageName]-        | SuspiciousFlagName [String]-        | DeclaredUsedFlags (Set FlagName) (Set FlagName)-        | NonASCIICustomField [String]-        | RebindableClashPaths-        | RebindableClashPackageInfo-        | WErrorUnneeded String-        | JUnneeded String-        | FDeferTypeErrorsUnneeded String-        | DynamicUnneeded String-        | ProfilingUnneeded String-        | UpperBoundSetup String-        | DuplicateModule String [ModuleName]-        | PotentialDupModule String [ModuleName]-        | BOMStart FilePath-        | NotPackageName FilePath String-        | NoDesc-        | MultiDesc [String]-        | UnknownFile String (SymbolicPath PackageDir LicenseFile)-        | MissingSetupFile-        | MissingConfigureScript-        | UnknownDirectory String FilePath-        | MissingSourceControl-        | MissingExpectedDocFiles Bool [FilePath]-        | WrongFieldForExpectedDocFiles Bool String [FilePath]-    deriving (Eq, Ord, Show)---- | Wraps `ParseWarning` into `PackageCheck`.----wrapParseWarning :: FilePath -> PWarning -> PackageCheck-wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw)-    -- TODO: as Jul 2022 there is no severity indication attached PWarnType.-    --       Once that is added, we can output something more appropriate-    --       than PackageDistSuspicious for every parse warning.-    --       (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs)---- | Pretty printing `CheckExplanation`.----ppExplanation :: CheckExplanation -> String-ppExplanation (ParseWarning fp pp) = showPWarning fp pp-ppExplanation NoNameField = "No 'name' field."-ppExplanation NoVersionField = "No 'version' field."-ppExplanation NoTarget =-    "No executables, libraries, tests, or benchmarks found. Nothing to do."-ppExplanation UnnamedInternal =-    "Found one or more unnamed internal libraries. Only the non-internal"-      ++ " library can have the same name as the package."-ppExplanation (DuplicateSections duplicateNames) =-    "Duplicate sections: "-      ++ commaSep (map unUnqualComponentName duplicateNames)-      ++ ". The name of every library, executable, test suite,"-      ++ " and benchmark section in the package must be unique."-ppExplanation (IllegalLibraryName pkg) =-    "Illegal internal library name "-      ++ prettyShow (packageName pkg)-      ++ ". Internal libraries cannot have the same name as the package."-      ++ " Maybe you wanted a non-internal library?"-      ++ " If so, rewrite the section stanza"-      ++ " from 'library: '" ++ prettyShow (packageName pkg)-      ++ "' to 'library'."-ppExplanation (NoModulesExposed lib) =-    showLibraryName (libName lib) ++ " does not expose any modules"-ppExplanation SignaturesCabal2 =-    "To use the 'signatures' field the package needs to specify "-      ++ "at least 'cabal-version: 2.0'."-ppExplanation AutogenNotExposed =-    "An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'."-ppExplanation AutogenIncludesNotIncluded =-    "An include in 'autogen-includes' is neither in 'includes' or "-       ++ "'install-includes'."-ppExplanation (NoMainIs exe) =-    "No 'main-is' field found for executable " ++ prettyShow (exeName exe)-ppExplanation NoHsLhsMain =-    "The 'main-is' field must specify a '.hs' or '.lhs' file "-      ++ "(even if it is generated by a preprocessor), "-      ++ "or it may specify a C/C++/obj-C source file."-ppExplanation MainCCabal1_18 =-    "The package uses a C/C++/obj-C source file for the 'main-is' field. "-      ++ "To use this feature you need to specify 'cabal-version: 1.18' or"-      ++ " higher."-ppExplanation (AutogenNoOther ct ucn) =-    "On " ++ ppCE ct ++ " '" ++ prettyShow ucn ++ "' an 'autogen-module'"-      ++ " is not on 'other-modules'"-ppExplanation AutogenIncludesNotIncludedExe =-    "An include in 'autogen-includes' is not in 'includes'."-ppExplanation (TestsuiteTypeNotKnown tt) =-    quote (prettyShow tt) ++ " is not a known type of test suite. "-      ++ "Either remove the 'type' field or use a known type. "-      ++ "The known test suite types are: "-      ++ commaSep (map prettyShow knownTestTypes)-ppExplanation (TestsuiteNotSupported tt) =-    quote (prettyShow tt) ++ " is not a supported test suite version. "-      ++ "Either remove the 'type' field or use a known type. "-      ++ "The known test suite types are: "-      ++ commaSep (map prettyShow knownTestTypes)-ppExplanation (BenchmarkTypeNotKnown tt) =-    quote (prettyShow tt) ++ " is not a known type of benchmark. "-      ++ "Either remove the 'type' field or use a known type. "-      ++ "The known benchmark types are: "-      ++ commaSep (map prettyShow knownBenchmarkTypes)-ppExplanation (BenchmarkNotSupported tt) =-    quote (prettyShow tt) ++ " is not a supported benchmark version. "-      ++ "Either remove the 'type' field or use a known type. "-      ++ "The known benchmark types are: "-      ++ commaSep (map prettyShow knownBenchmarkTypes)-ppExplanation NoHsLhsMainBench =-    "The 'main-is' field must specify a '.hs' or '.lhs' file "-      ++ "(even if it is generated by a preprocessor)."-ppExplanation (InvalidNameWin pkg) =-    "The package name '" ++ prettyShow (packageName pkg) ++ "' is "-      ++ "invalid on Windows. Many tools need to convert package names to "-      ++ "file names so using this name would cause problems."-ppExplanation ZPrefix =-    "Package names with the prefix 'z-' are reserved by Cabal and "-      ++ "cannot be used."-ppExplanation NoBuildType =-    "No 'build-type' specified. If you do not need a custom Setup.hs or "-      ++ "./configure script then use 'build-type: Simple'."-ppExplanation NoCustomSetup =-    "Ignoring the 'custom-setup' section because the 'build-type' is "-      ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "-      ++ "custom Setup.hs script."-ppExplanation (UnknownCompilers unknownCompilers) =-    "Unknown compiler " ++ commaSep (map quote unknownCompilers)-      ++ " in 'tested-with' field."-ppExplanation (UnknownLanguages unknownLanguages) =-    "Unknown languages: " ++ commaSep unknownLanguages-ppExplanation (UnknownExtensions unknownExtensions) =-    "Unknown extensions: " ++ commaSep unknownExtensions-ppExplanation (LanguagesAsExtension languagesUsedAsExtensions) =-    "Languages listed as extensions: "-      ++ commaSep languagesUsedAsExtensions-      ++ ". Languages must be specified in either the 'default-language' "-      ++ " or the 'other-languages' field."-ppExplanation (DeprecatedExtensions ourDeprecatedExtensions) =-    "Deprecated extensions: "-      ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions)-      ++ ". " ++ unwords-           [ "Instead of '" ++ prettyShow ext-          ++ "' use '" ++ prettyShow replacement ++ "'."-           | (ext, Just replacement) <- ourDeprecatedExtensions ]-ppExplanation (MissingField cef) =-    "No '" ++ ppCEField cef ++ "' field."-ppExplanation SynopsisTooLong =-    "The 'synopsis' field is rather long (max 80 chars is recommended)."-ppExplanation ShortDesc =-    "The 'description' field should be longer than the 'synopsis' field. "-      ++ "It's useful to provide an informative 'description' to allow "-      ++ "Haskell programmers who have never heard about your package to "-      ++ "understand the purpose of your package. "-      ++ "The 'description' field content is typically shown by tooling "-      ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which "-      ++ "serves as a headline. "-      ++ "Please refer to <https://cabal.readthedocs.io/en/stable/"-      ++ "cabal-package.html#package-properties> for more details."-ppExplanation (InvalidTestWith testedWithImpossibleRanges) =-    "Invalid 'tested-with' version range: "-      ++ commaSep (map prettyShow testedWithImpossibleRanges)-      ++ ". To indicate that you have tested a package with multiple "-      ++ "different versions of the same compiler use multiple entries, "-      ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "-      ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."-ppExplanation (ImpossibleInternalDep depInternalLibWithImpossibleVersion) =-    "The package has an impossible version range for a dependency on an "-      ++ "internal library: "-      ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion)-      ++ ". This version range does not include the current package, and must "-      ++ "be removed as the current package's library will always be used."-ppExplanation (ImpossibleInternalExe depInternalExecWithImpossibleVersion) =-    "The package has an impossible version range for a dependency on an "-      ++ "internal executable: "-      ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion)-      ++ ". This version range does not include the current package, and must "-      ++ "be removed as the current package's executable will always be used."-ppExplanation (MissingInternalExe depInternalExeWithImpossibleVersion) =-    "The package depends on a missing internal executable: "-      ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion)-ppExplanation NONELicense = "The 'license' field is missing or is NONE."-ppExplanation NoLicense = "The 'license' field is missing."-ppExplanation AllRightsReservedLicense =-    "The 'license' is AllRightsReserved. Is that really what you want?"-ppExplanation (LicenseMessParse pkg) =-    "Unfortunately the license " ++ quote (prettyShow (license pkg))-      ++ " messes up the parser in earlier Cabal versions so you need to "-      ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "-      ++ "compatibility with earlier Cabal versions then use 'OtherLicense'."-ppExplanation (UnrecognisedLicense l) =-    quote ("license: " ++ l) ++ " is not a recognised license. The "-      ++ "known licenses are: " ++ commaSep (map prettyShow knownLicenses)-ppExplanation UncommonBSD4 =-    "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "-      ++ "refers to the old 4-clause BSD license with the advertising "-      ++ "clause. 'BSD3' refers the new 3-clause BSD license."-ppExplanation (UnknownLicenseVersion lic known) =-    "'license: " ++ prettyShow lic ++ "' is not a known "-      ++ "version of that license. The known versions are "-      ++ commaSep (map prettyShow known)-      ++ ". If this is not a mistake and you think it should be a known "-      ++ "version then please file a ticket."-ppExplanation NoLicenseFile = "A 'license-file' is not specified."-ppExplanation (UnrecognisedSourceRepo kind) =-    quote kind ++ " is not a recognised kind of source-repository. "-      ++ "The repo kind is usually 'head' or 'this'"-ppExplanation MissingType =-    "The source-repository 'type' is a required field."-ppExplanation MissingLocation =-    "The source-repository 'location' is a required field."-ppExplanation MissingModule =-    "For a CVS source-repository, the 'module' is a required field."-ppExplanation MissingTag =-    "For the 'this' kind of source-repository, the 'tag' is a required "-      ++ "field. It should specify the tag corresponding to this version "-      ++ "or release of the package."-ppExplanation SubdirRelPath =-    "The 'subdir' field of a source-repository must be a relative path."-ppExplanation (SubdirGoodRelPath err) =-    "The 'subdir' field of a source-repository is not a good relative path: "-      ++ show err-ppExplanation (OptFasm fieldName) =-    "'" ++ fieldName ++ ": -fasm' is unnecessary and will not work on CPU "-      ++ "architectures other than x86, x86-64, ppc or sparc."-ppExplanation (OptViaC fieldName) =-    "'" ++ fieldName ++": -fvia-C' is usually unnecessary. If your package "-      ++ "needs -via-C for correctness rather than performance then it "-      ++ "is using the FFI incorrectly and will probably not work with GHC "-      ++ "6.10 or later."-ppExplanation (OptHpc fieldName) =-    "'" ++ fieldName ++ ": -fhpc' is not necessary. Use the configure flag "-      ++ " --enable-coverage instead."-ppExplanation (OptProf fieldName) =-    "'" ++ fieldName ++ ": -prof' is not necessary and will lead to problems "-      ++ "when used on a library. Use the configure flag "-      ++ "--enable-library-profiling and/or --enable-profiling."-ppExplanation (OptO fieldName) =-    "'" ++ fieldName ++ ": -o' is not needed. "-      ++ "The output files are named automatically."-ppExplanation (OptHide fieldName) =-    "'" ++ fieldName ++ ": -hide-package' is never needed. "-      ++ "Cabal hides all packages."-ppExplanation (OptMake fieldName) =-    "'" ++ fieldName-      ++ ": --make' is never needed. Cabal uses this automatically."-ppExplanation (OptONot fieldName) =-      "'" ++ fieldName ++ ": -O0' is not needed. "-      ++ "Use the --disable-optimization configure flag."-ppExplanation (OptOOne fieldName) =-    "'" ++ fieldName ++ ": -O' is not needed. "-      ++ "Cabal automatically adds the '-O' flag. "-      ++ "Setting it yourself interferes with the --disable-optimization flag."-ppExplanation (OptOTwo fieldName) =-    "'" ++ fieldName ++ ": -O2' is rarely needed. "-      ++ "Check that it is giving a real benefit "-      ++ "and not just imposing longer compile times on your users."-ppExplanation (OptSplitSections fieldName) =-    "'" ++ fieldName ++ ": -split-sections' is not needed. "-      ++ "Use the --enable-split-sections configure flag."-ppExplanation (OptSplitObjs fieldName) =-    "'" ++ fieldName ++ ": -split-objs' is not needed. "-      ++ "Use the --enable-split-objs configure flag."-ppExplanation (OptWls fieldName) =-    "'" ++ fieldName ++ ": -optl-Wl,-s' is not needed and is not portable to"-      ++ " all operating systems. Cabal 1.4 and later automatically strip"-      ++ " executables. Cabal also has a flag --disable-executable-stripping"-      ++ " which is necessary when building packages for some Linux"-      ++ " distributions and using '-optl-Wl,-s' prevents that from working."-ppExplanation (OptExts fieldName) =-    "Instead of '" ++ fieldName ++ ": -fglasgow-exts' it is preferable to use "-      ++ "the 'extensions' field."-ppExplanation (OptRts fieldName) =-    "'" ++ fieldName ++ ": -rtsopts' has no effect for libraries. It should "-      ++ "only be used for executables."-ppExplanation (OptWithRts fieldName) =-    "'" ++ fieldName ++ ": -with-rtsopts' has no effect for libraries. It "-      ++ "should only be used for executables."-ppExplanation (COptONumber prefix label) =-    "'" ++ prefix ++": -O[n]' is generally not needed. When building with "-      ++ " optimisations Cabal automatically adds '-O2' for " ++ label-      ++ " code. Setting it yourself interferes with the"-      ++ " --disable-optimization flag."-ppExplanation (COptCPP opt) =-    "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag."-ppExplanation (OptAlternatives badField goodField flags) =-    "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)-      ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags)-  where (badFlags, goodFlags) = unzip flags-ppExplanation (RelativeOutside field path) =-    quote (field ++ ": " ++ path)-      ++ " is a relative path outside of the source tree. "-      ++ "This will not work when generating a tarball with 'sdist'."-ppExplanation (AbsolutePath field path) =-    quote (field ++ ": " ++ path) ++ " specifies an absolute path, but the "-      ++ quote field ++ " field must use relative paths."-ppExplanation (BadRelativePAth field path err) =-    quote (field ++ ": " ++ path)-      ++ " is not a good relative path: " ++ show err-ppExplanation (DistPoint mfield path) =-    incipit ++ " points inside the 'dist' "-      ++ "directory. This is not reliable because the location of this "-      ++ "directory is configurable by the user (or package manager). In "-      ++ "addition the layout of the 'dist' directory is subject to change "-      ++ "in future versions of Cabal."-  where -- mfiled Nothing -> the path is inside `ghc-options`-        incipit = maybe ("'ghc-options' path " ++ quote path)-                        (\field -> quote (field ++ ": " ++ path))-                        mfield-ppExplanation (GlobSyntaxError field expl) =-    "In the '" ++ field ++ "' field: " ++ expl-ppExplanation (RecursiveGlobInRoot field glob) =-    "In the '" ++ field ++ "': glob '" ++ glob-    ++ "' starts at project root directory, this might "-    ++ "include `.git/`, ``dist-newstyle/``, or other large directories!"-ppExplanation (InvalidOnWin paths) =-    "The " ++ quotes paths ++ " invalid on Windows, which "-      ++ "would cause portability problems for this package. Windows file "-      ++ "names cannot contain any of the characters \":*?<>|\" and there "-      ++ "a few reserved names including \"aux\", \"nul\", \"con\", "-      ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"."-  where quotes [failed] = "path " ++ quote failed ++ " is"-        quotes failed = "paths " ++ intercalate ", " (map quote failed)-                          ++ " are"-ppExplanation (FilePathTooLong path) =-         "The following file name is too long to store in a portable POSIX "-      ++ "format tar archive. The maximum length is 255 ASCII characters.\n"-      ++ "The file in question is:\n  " ++ path-ppExplanation (FilePathNameTooLong path) =-    "The following file name is too long to store in a portable POSIX "-      ++ "format tar archive. The maximum length for the name part (including "-      ++ "extension) is 100 ASCII characters. The maximum length for any "-      ++ "individual directory component is 155.\n"-      ++ "The file in question is:\n  " ++ path-ppExplanation (FilePathSplitTooLong path) =-    "The following file name is too long to store in a portable POSIX "-      ++ "format tar archive. While the total length is less than 255 ASCII "-      ++ "characters, there are unfortunately further restrictions. It has to "-      ++ "be possible to split the file path on a directory separator into "-      ++ "two parts such that the first part fits in 155 characters or less "-      ++ "and the second part fits in 100 characters or less. Basically you "-      ++ "have to make the file name or directory names shorter, or you could "-      ++ "split a long directory name into nested subdirectories with shorter "-      ++ "names.\nThe file in question is:\n  " ++ path-ppExplanation FilePathEmpty =-    "Encountered a file with an empty name, something is very wrong! "-      ++ "Files with an empty name cannot be stored in a tar archive or in "-      ++ "standard file systems."-ppExplanation CVTestSuite =-    "The 'test-suite' section is new in Cabal 1.10. "-      ++ "Unfortunately it messes up the parser in older Cabal versions "-      ++ "so you must specify at least 'cabal-version: >= 1.8', but note "-      ++ "that only Cabal 1.10 and later can actually run such test suites."-ppExplanation CVDefaultLanguage =-    "To use the 'default-language' field the package needs to specify "-      ++ "at least 'cabal-version: >= 1.10'."-ppExplanation CVDefaultLanguageComponent =-    "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' "-      ++ "must specify the 'default-language' field for each component (e.g. "-      ++ "Haskell98 or Haskell2010). If a component uses different languages "-      ++ "in different modules then list the other ones in the "-      ++ "'other-languages' field."-ppExplanation CVExtraDocFiles =-    "To use the 'extra-doc-files' field the package needs to specify "-      ++ "'cabal-version: 1.18' or higher."-ppExplanation CVMultiLib =-    "To use multiple 'library' sections or a named library section "-      ++ "the package needs to specify at least 'cabal-version: 2.0'."-ppExplanation CVReexported =-    "To use the 'reexported-module' field the package needs to specify "-      ++ "'cabal-version: 1.22' or higher."-ppExplanation CVMixins =-    "To use the 'mixins' field the package needs to specify "-      ++ "at least 'cabal-version: 2.0'."-ppExplanation CVExtraFrameworkDirs =-    "To use the 'extra-framework-dirs' field the package needs to specify"-      ++ " 'cabal-version: 1.24' or higher."-ppExplanation CVDefaultExtensions =-    "To use the 'default-extensions' field the package needs to specify "-      ++ "at least 'cabal-version: >= 1.10'."-ppExplanation CVExtensionsDeprecated =-    "For packages using 'cabal-version: >= 1.10' the 'extensions' "-      ++ "field is deprecated. The new 'default-extensions' field lists "-      ++ "extensions that are used in all modules in the component, while "-      ++ "the 'other-extensions' field lists extensions that are used in "-      ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."-ppExplanation CVSources =-    "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' "-      ++ " and 'extra-library-flavours' requires the package "-      ++ " to specify at least 'cabal-version: 3.0'."-ppExplanation (CVExtraDynamic flavs) =-    "The use of 'extra-dynamic-library-flavours' requires the package "-      ++ " to specify at least 'cabal-version: 3.0'. The flavours are: "-      ++ commaSep (concat flavs)-ppExplanation CVVirtualModules =-    "The use of 'virtual-modules' requires the package "-      ++ " to specify at least 'cabal-version: 2.2'."-ppExplanation CVSourceRepository =-    "The 'source-repository' section is new in Cabal 1.6. "-      ++ "Unfortunately it messes up the parser in earlier Cabal versions "-      ++ "so you need to specify 'cabal-version: >= 1.6'."-ppExplanation (CVExtensions version extCab12) =-    "Unfortunately the language extensions "-      ++ commaSep (map (quote . prettyShow) extCab12)-      ++ " break the parser in earlier Cabal versions so you need to "-      ++ "specify 'cabal-version: >= " ++ showCabalSpecVersion version-      ++ "'. Alternatively if you require compatibility with earlier "-      ++ "Cabal versions then you may be able to use an equivalent "-      ++ "compiler-specific flag."-ppExplanation CVCustomSetup =-    "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' "-      ++ "must use a 'custom-setup' section with a 'setup-depends' field "-      ++ "that specifies the dependencies of the Setup.hs script itself. "-      ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "-      ++ "so a simple example would be 'setup-depends: base, Cabal'."-ppExplanation CVExpliticDepsCustomSetup =-    "From version 1.24 cabal supports specifying explicit dependencies "-      ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or "-      ++ "higher and adding a 'custom-setup' section with a 'setup-depends' "-      ++ "field that specifies the dependencies of the Setup.hs script "-      ++ "itself. The 'setup-depends' field uses the same syntax as "-      ++ "'build-depends', so a simple example would be 'setup-depends: base, "-      ++ "Cabal'."-ppExplanation CVAutogenPaths =-    "Packages using 'cabal-version: 2.0' and the autogenerated "-      ++ "module Paths_* must include it also on the 'autogen-modules' field "-      ++ "besides 'exposed-modules' and 'other-modules'. This specifies that "-      ++ "the module does not come with the package and is generated on "-      ++ "setup. Modules built with a custom Setup.hs script also go here "-      ++ "to ensure that commands like sdist don't fail."-ppExplanation CVAutogenPackageInfo =-    "Packages using 'cabal-version: 2.0' and the autogenerated "-      ++ "module PackageInfo_* must include it in 'autogen-modules' as well as"-      ++ " 'exposed-modules' and 'other-modules'. This specifies that "-      ++ "the module does not come with the package and is generated on "-      ++ "setup. Modules built with a custom Setup.hs script also go here "-      ++ "to ensure that commands like sdist don't fail."-ppExplanation CVAutogenPackageInfoGuard =-    "To use the autogenerated module PackageInfo_* you need to specify "-      ++ "`cabal-version: 3.12` or higher. This is not possible in `cabal "-      ++ "3.10`. To use this feature and be able to upload your package to "-      ++ "Hackage, download `cabal 3.12`!"-ppExplanation (GlobNoMatch field glob) =-    "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"-      ++ " match any files."-ppExplanation (GlobExactMatch field glob file) =-    "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"-      ++ " match the file '" ++ file ++ "' because the extensions do not"-      ++ " exactly match (e.g., foo.en.html does not exactly match *.html)."-      ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or"-      ++ " higher."-ppExplanation (GlobNoDir field glob dir) =-    "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to"-      ++ " match files in the directory '" ++ dir ++ "', but there is no"-      ++ " directory by that name."-ppExplanation (UnknownOS unknownOSs) =-    "Unknown operating system name " ++ commaSep (map quote unknownOSs)-ppExplanation (UnknownArch unknownArches) =-    "Unknown architecture name " ++ commaSep (map quote unknownArches)-ppExplanation (UnknownCompiler unknownImpls) =-    "Unknown compiler name " ++ commaSep (map quote unknownImpls)-ppExplanation (MissingUpperBounds names) =-    let separator = "\n  - "-    in-    "These packages miss upper bounds:" ++ separator-      ++ (intercalate separator (unPackageName <$> names)) ++ "\n"-      ++  "Please add them, using `cabal gen-bounds` for suggestions."-      ++ " For more information see: "-      ++ " https://pvp.haskell.org/"-ppExplanation BaseNoUpperBounds =-    "The dependency 'build-depends: base' does not specify an upper "-      ++ "bound on the version number. Each major release of the 'base' "-      ++ "package changes the API in various ways and most packages will "-      ++ "need some changes to compile with it. The recommended practice "-      ++ "is to specify an upper bound on the version of the 'base' "-      ++ "package. This ensures your package will continue to build when a "-      ++ "new major version of the 'base' package is released. If you are "-      ++ "not sure what upper bound to use then use the next  major "-      ++ "version. For example if you have tested your package with 'base' "-      ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'."-ppExplanation (SuspiciousFlagName invalidFlagNames) =-    "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". "-      ++ "To avoid ambiguity in command line interfaces, flag shouldn't "-      ++ "start with a dash. Also for better compatibility, flag names "-      ++ "shouldn't contain non-ascii characters."-ppExplanation (DeclaredUsedFlags declared used) =-    "Declared and used flag sets differ: "-      ++ s declared ++ " /= " ++ s used ++ ". "-  where s :: Set.Set FlagName -> String-        s = commaSep . map unFlagName . Set.toList-ppExplanation (NonASCIICustomField nonAsciiXFields) =-    "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". "-      ++ "For better compatibility, custom field names "-      ++ "shouldn't contain non-ascii characters."-ppExplanation RebindableClashPaths =-    "Packages using RebindableSyntax with OverloadedStrings or"-      ++ " OverloadedLists in default-extensions, in conjunction with the"-      ++ " autogenerated module Paths_*, are known to cause compile failures"-      ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*"-      ++ " autogen module, specify at least 'cabal-version: 2.2'."-ppExplanation RebindableClashPackageInfo =-    "Packages using RebindableSyntax with OverloadedStrings or"-      ++ " OverloadedLists in default-extensions, in conjunction with the"-      ++ " autogenerated module PackageInfo_*, are known to cause compile failures"-      ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*"-      ++ " autogen module, specify at least 'cabal-version: 2.2'."-ppExplanation (WErrorUnneeded fieldName) = addConditionalExp $-    "'" ++ fieldName ++ ": -Werror' makes the package easy to "-      ++ "break with future GHC versions because new GHC versions often "-      ++ "add new warnings."-ppExplanation (JUnneeded fieldName) = addConditionalExp $-    "'" ++ fieldName ++ ": -j[N]' can make sense for specific user's setup,"-      ++ " but it is not appropriate for a distributed package."-ppExplanation (FDeferTypeErrorsUnneeded fieldName) = addConditionalExp $-    "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development "-      ++ "but is not appropriate for a distributed package."-ppExplanation (DynamicUnneeded fieldName) = addConditionalExp $-    "'" ++ fieldName ++ ": -d*' debug flags are not appropriate "-      ++ "for a distributed package."-ppExplanation (ProfilingUnneeded fieldName) = addConditionalExp $-    "'" ++ fieldName ++ ": -fprof*' profiling flags are typically not "-      ++ "appropriate for a distributed library package. These flags are "-      ++ "useful to profile this package, but when profiling other packages "-      ++ "that use this one these flags clutter the profile output with "-      ++ "excessive detail. If you think other packages really want to see "-      ++ "cost centres from this package then use '-fprof-auto-exported' "-      ++ "which puts cost centres only on exported functions."-ppExplanation (UpperBoundSetup nm) =-    "The dependency 'setup-depends: '"++nm++"' does not specify an "-      ++ "upper bound on the version number. Each major release of the "-      ++ "'"++nm++"' package changes the API in various ways and most "-      ++ "packages will need some changes to compile with it. If you are "-      ++ "not sure what upper bound to use then use the next major "-      ++ "version."-ppExplanation (DuplicateModule s dupLibsLax) =-    "Duplicate modules in " ++ s ++ ": "-      ++ commaSep (map prettyShow dupLibsLax)-ppExplanation (PotentialDupModule s dupLibsStrict) =-    "Potential duplicate modules (subject to conditionals) in " ++ s-      ++ ": " ++ commaSep (map prettyShow dupLibsStrict)-ppExplanation (BOMStart pdfile) =-    pdfile ++ " starts with an Unicode byte order mark (BOM)."-      ++ " This may cause problems with older cabal versions."-ppExplanation (NotPackageName pdfile expectedCabalname) =-    "The filename " ++ quote pdfile ++ " does not match package name "-      ++ "(expected: " ++ quote expectedCabalname ++ ")"-ppExplanation NoDesc =-    "No cabal file found.\n"-      ++ "Please create a package description file <pkgname>.cabal"-ppExplanation (MultiDesc multiple) =-    "Multiple cabal files found while checking.\n"-      ++ "Please use only one of: "-      ++ intercalate ", " multiple-ppExplanation (UnknownFile fieldname file) =-    "The '" ++ fieldname ++ "' field refers to the file "-      ++ quote (getSymbolicPath file) ++ " which does not exist."-ppExplanation MissingSetupFile =-    "The package is missing a Setup.hs or Setup.lhs script."-ppExplanation MissingConfigureScript =-    "The 'build-type' is 'Configure' but there is no 'configure' script. "-      ++ "You probably need to run 'autoreconf -i' to generate it."-ppExplanation (UnknownDirectory kind dir) =-    quote (kind ++ ": " ++ dir)-      ++ " specifies a directory which does not exist."-ppExplanation MissingSourceControl =-    "When distributing packages it is encouraged to specify source "-      ++ "control information in the .cabal file using one or more "-      ++ "'source-repository' sections. See the Cabal user guide for "-      ++ "details."-ppExplanation (MissingExpectedDocFiles extraDocFileSupport paths) =-    "Please consider including the " ++ quotes paths-      ++ " in the '" ++ targetField ++ "' section of the .cabal file "-      ++ "if it contains useful information for users of the package."-  where quotes [p] = "file " ++ quote p-        quotes ps = "files " ++ intercalate ", " (map quote ps)-        targetField = if extraDocFileSupport-                        then "extra-doc-files"-                        else "extra-source-files"-ppExplanation (WrongFieldForExpectedDocFiles extraDocFileSupport field paths) =-    "Please consider moving the " ++ quotes paths-      ++ " from the '" ++ field ++ "' section of the .cabal file "-      ++ "to the section '" ++ targetField ++ "'."-  where quotes [p] = "file " ++ quote p-        quotes ps = "files " ++ intercalate ", " (map quote ps)-        targetField = if extraDocFileSupport-                        then "extra-doc-files"-                        else "extra-source-files"----- | Results of some kind of failed package check.------ There are a range of severities, from merely dubious to totally insane.--- All of them come with a human readable explanation. In future we may augment--- them with more machine readable explanations, for example to help an IDE--- suggest automatic corrections.----data PackageCheck =--       -- | This package description is no good. There's no way it's going to-       -- build sensibly. This should give an error at configure time.-       PackageBuildImpossible { explanation :: CheckExplanation }--       -- | A problem that is likely to affect building the package, or an-       -- issue that we'd like every package author to be aware of, even if-       -- the package is never distributed.-     | PackageBuildWarning { explanation :: CheckExplanation }--       -- | An issue that might not be a problem for the package author but-       -- might be annoying or detrimental when the package is distributed to-       -- users. We should encourage distributed packages to be free from these-       -- issues, but occasionally there are justifiable reasons so we cannot-       -- ban them entirely.-     | PackageDistSuspicious { explanation :: CheckExplanation }--       -- | Like PackageDistSuspicious but will only display warnings-       -- rather than causing abnormal exit when you run 'cabal check'.-     | PackageDistSuspiciousWarn { explanation :: CheckExplanation }--       -- | An issue that is OK in the author's environment but is almost-       -- certain to be a portability problem for other environments. We can-       -- quite legitimately refuse to publicly distribute packages with these-       -- problems.-     | PackageDistInexcusable { explanation :: CheckExplanation }-  deriving (Eq, Ord)---- | Pretty printing 'PackageCheck'.----ppPackageCheck :: PackageCheck -> String-ppPackageCheck e = ppExplanation (explanation e)--instance Show PackageCheck where-    show notice = ppPackageCheck notice--check :: Bool -> PackageCheck -> Maybe PackageCheck-check False _  = Nothing-check True  pc = Just pc--checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck-                 -> Maybe PackageCheck-checkSpecVersion pkg specver cond pc-  | specVersion pkg >= specver  = Nothing-  | otherwise                   = check cond pc---- --------------------------------------------------------------- * Standard checks--- ---------------------------------------------------------------- | Check for common mistakes and problems in package descriptions.------ This is the standard collection of checks covering all aspects except--- for checks that require looking at files within the package. For those--- see 'checkPackageFiles'.------ It requires the 'GenericPackageDescription' and optionally a particular--- configuration of that package. If you pass 'Nothing' then we just check--- a version of the generic description using 'flattenPackageDescription'.----checkPackage :: GenericPackageDescription-             -> Maybe PackageDescription-             -> [PackageCheck]-checkPackage gpkg mpkg =-     checkConfiguredPackage pkg-  ++ checkConditionals gpkg-  ++ checkPackageVersions gpkg-  ++ checkDevelopmentOnlyFlags gpkg-  ++ checkFlagNames gpkg-  ++ checkUnusedFlags gpkg-  ++ checkUnicodeXFields gpkg-  ++ checkPathsModuleExtensions pkg-  ++ checkPackageInfoModuleExtensions pkg-  ++ checkSetupVersions gpkg-  ++ checkDuplicateModules gpkg-  where-    pkg = fromMaybe (flattenPackageDescription gpkg) mpkg----TODO: make this variant go away---      we should always know the GenericPackageDescription-checkConfiguredPackage :: PackageDescription -> [PackageCheck]-checkConfiguredPackage pkg =-    checkSanity pkg- ++ checkFields pkg- ++ checkLicense pkg- ++ checkSourceRepos pkg- ++ checkAllGhcOptions pkg- ++ checkCCOptions pkg- ++ checkCxxOptions pkg- ++ checkCPPOptions pkg- ++ checkPaths pkg- ++ checkCabalVersion pkg----- --------------------------------------------------------------- * Basic sanity checks--- ---------------------------------------------------------------- | Check that this package description is sane.----checkSanity :: PackageDescription -> [PackageCheck]-checkSanity pkg =-  catMaybes [--    check (null . unPackageName . packageName $ pkg) $-      PackageBuildImpossible NoNameField--  , check (nullVersion == packageVersion pkg) $-      PackageBuildImpossible NoVersionField--  , check (all ($ pkg) [ null . executables-                       , null . testSuites-                       , null . benchmarks-                       , null . allLibraries-                       , null . foreignLibs ]) $-      PackageBuildImpossible NoTarget--  , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $-      PackageBuildImpossible UnnamedInternal--  , check (not (null duplicateNames)) $-      PackageBuildImpossible (DuplicateSections duplicateNames)--  -- NB: but it's OK for executables to have the same name!-  -- TODO shouldn't need to compare on the string level-  , check (any (== prettyShow (packageName pkg))-               (prettyShow <$> subLibNames)) $-      PackageBuildImpossible (IllegalLibraryName pkg)-  ]-  --TODO: check for name clashes case insensitively: windows file systems cannot-  --cope.--  ++ concatMap (checkLibrary    pkg) (allLibraries pkg)-  ++ concatMap (checkExecutable pkg) (executables pkg)-  ++ concatMap (checkTestSuite  pkg) (testSuites pkg)-  ++ concatMap (checkBenchmark  pkg) (benchmarks pkg)--  where-    -- The public 'library' gets special dispensation, because it-    -- is common practice to export a library and name the executable-    -- the same as the package.-    subLibNames = mapMaybe (libraryNameString . libName) $ subLibraries pkg-    exeNames = map exeName $ executables pkg-    testNames = map testName $ testSuites pkg-    bmNames = map benchmarkName $ benchmarks pkg-    duplicateNames = dups $ subLibNames ++ exeNames ++ testNames ++ bmNames--checkLibrary :: PackageDescription -> Library -> [PackageCheck]-checkLibrary pkg lib =-  catMaybes [--  -- TODO: This check is bogus if a required-signature was passed through-    check (null (explicitLibModules lib) && null (reexportedModules lib)) $-      PackageDistSuspiciousWarn (NoModulesExposed lib)--    -- check use of signatures sections-  , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $-      PackageDistInexcusable SignaturesCabal2--    -- check that all autogen-modules appear on other-modules or exposed-modules-  , check-      (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $-      PackageBuildImpossible AutogenNotExposed--    -- check that all autogen-includes appear on includes or install-includes-  , check-      (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) $-      PackageBuildImpossible AutogenIncludesNotIncluded-  ]--  where-    checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck-    checkVersion ver cond pc-      | specVersion pkg >= ver = Nothing-      | otherwise              = check cond pc--allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath]-allExplicitIncludes x = view L.includes x ++ view L.installIncludes x--checkExecutable :: PackageDescription -> Executable -> [PackageCheck]-checkExecutable pkg exe =-  catMaybes [--    check (null (modulePath exe)) $-      PackageBuildImpossible (NoMainIs exe)--  -- This check does not apply to scripts.-  , check (package pkg /= fakePackageId-       && not (null (modulePath exe))-       && not (fileExtensionSupportedLanguage $ modulePath exe)) $-      PackageBuildImpossible NoHsLhsMain--  , checkSpecVersion pkg CabalSpecV1_18-          (fileExtensionSupportedLanguage (modulePath exe)-        && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $-      PackageDistInexcusable MainCCabal1_18--    -- check that all autogen-modules appear on other-modules-  , check-      (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $-      PackageBuildImpossible (AutogenNoOther CETExecutable (exeName exe))--    -- check that all autogen-includes appear on includes-  , check-      (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $-      PackageBuildImpossible AutogenIncludesNotIncludedExe-  ]--checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]-checkTestSuite pkg test =-  catMaybes [--    case testInterface test of-      TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $-        PackageBuildWarning (TestsuiteTypeNotKnown tt)--      TestSuiteUnsupported tt -> Just $-        PackageBuildWarning (TestsuiteNotSupported tt)-      _ -> Nothing--  , check mainIsWrongExt $-      PackageBuildImpossible NoHsLhsMain--  , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $-      PackageDistInexcusable MainCCabal1_18--    -- check that all autogen-modules appear on other-modules-  , check-      (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) $-      PackageBuildImpossible (AutogenNoOther CETTest (testName test))--    -- check that all autogen-includes appear on includes-  , check-      (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) $-      PackageBuildImpossible AutogenIncludesNotIncludedExe-  ]-  where-    mainIsWrongExt = case testInterface test of-      TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f-      _                   -> False--    mainIsNotHsExt = case testInterface test of-      TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]-      _                   -> False--checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck]-checkBenchmark _pkg bm =-  catMaybes [--    case benchmarkInterface bm of-      BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $-        PackageBuildWarning (BenchmarkTypeNotKnown tt)--      BenchmarkUnsupported tt -> Just $-        PackageBuildWarning (BenchmarkNotSupported tt)-      _ -> Nothing--  , check mainIsWrongExt $-      PackageBuildImpossible NoHsLhsMainBench--    -- check that all autogen-modules appear on other-modules-  , check-      (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) $-      PackageBuildImpossible (AutogenNoOther CETBenchmark (benchmarkName bm))--    -- check that all autogen-includes appear on includes-  , check-      (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) $-      PackageBuildImpossible AutogenIncludesNotIncludedExe-  ]-  where-    mainIsWrongExt = case benchmarkInterface bm of-      BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]-      _                   -> False---- --------------------------------------------------------------- * Additional pure checks--- --------------------------------------------------------------checkFields :: PackageDescription -> [PackageCheck]-checkFields pkg =-  catMaybes [--    check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $-      PackageDistInexcusable (InvalidNameWin pkg)--  , check (isPrefixOf "z-" . prettyShow . packageName $ pkg) $-      PackageDistInexcusable ZPrefix--  , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $-      PackageBuildWarning NoBuildType--  , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $-      PackageBuildWarning NoCustomSetup--  , check (not (null unknownCompilers)) $-      PackageBuildWarning (UnknownCompilers unknownCompilers)--  , check (not (null unknownLanguages)) $-      PackageBuildWarning (UnknownLanguages unknownLanguages)--  , check (not (null unknownExtensions)) $-      PackageBuildWarning (UnknownExtensions unknownExtensions)--  , check (not (null languagesUsedAsExtensions)) $-      PackageBuildWarning (LanguagesAsExtension languagesUsedAsExtensions)--  , check (not (null ourDeprecatedExtensions)) $-      PackageDistSuspicious (DeprecatedExtensions ourDeprecatedExtensions)--  , check (ShortText.null (category pkg)) $-      PackageDistSuspicious (MissingField CEFCategory)--  , check (ShortText.null (maintainer pkg)) $-      PackageDistSuspicious (MissingField CEFMaintainer)--  , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $-      PackageDistInexcusable (MissingField CEFSynOrDesc)--  , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $-      PackageDistSuspicious (MissingField CEFDescription)--  , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $-      PackageDistSuspicious (MissingField CEFSynopsis)--    --TODO: recommend the bug reports URL, author and homepage fields-    --TODO: recommend not using the stability field-    --TODO: recommend specifying a source repo--  , check (ShortText.length (synopsis pkg) > 80) $-      PackageDistSuspicious SynopsisTooLong--    -- See also https://github.com/haskell/cabal/pull/3479-  , check (not (ShortText.null (description pkg))-           && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $-      PackageDistSuspicious ShortDesc--    -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"-  , check (not (null testedWithImpossibleRanges)) $-      PackageDistInexcusable (InvalidTestWith testedWithImpossibleRanges)--  -- for more details on why the following was commented out,-  -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507-  -- , check (not (null depInternalLibraryWithExtraVersion)) $-  --     PackageBuildWarning $-  --          "The package has an extraneous version range for a dependency on an "-  --       ++ "internal library: "-  --       ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion)-  --       ++ ". This version range includes the current package but isn't needed "-  --       ++ "as the current package's library will always be used."--  , check (not (null depInternalLibraryWithImpossibleVersion)) $-      PackageBuildImpossible-        (ImpossibleInternalDep depInternalLibraryWithImpossibleVersion)--  -- , check (not (null depInternalExecutableWithExtraVersion)) $-  --     PackageBuildWarning $-  --          "The package has an extraneous version range for a dependency on an "-  --       ++ "internal executable: "-  --       ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion)-  --       ++ ". This version range includes the current package but isn't needed "-  --       ++ "as the current package's executable will always be used."--  , check (not (null depInternalExecutableWithImpossibleVersion)) $-      PackageBuildImpossible-        (ImpossibleInternalExe depInternalExecutableWithImpossibleVersion)--  , check (not (null depMissingInternalExecutable)) $-      PackageBuildImpossible (MissingInternalExe depMissingInternalExecutable)-  ]-  where-    unknownCompilers  = [ name | (OtherCompiler name, _) <- testedWith pkg ]-    unknownLanguages  = [ name | bi <- allBuildInfo pkg-                               , UnknownLanguage name <- allLanguages bi ]-    unknownExtensions = filter (/= "TypeAbstractions")-                          [ name | bi <- allBuildInfo pkg-                                 , UnknownExtension name <- allExtensions bi-                                 , name `notElem` map prettyShow knownLanguages ]-    ourDeprecatedExtensions = nub $ catMaybes-      [ find ((==ext) . fst) deprecatedExtensions-      | bi <- allBuildInfo pkg-      , ext <- allExtensions bi ]-    languagesUsedAsExtensions =-      [ name | bi <- allBuildInfo pkg-             , UnknownExtension name <- allExtensions bi-             , name `elem` map prettyShow knownLanguages ]--    testedWithImpossibleRanges =-      [ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet-      | (compiler, vr) <- testedWith pkg-      , isNoVersion vr ]--    internalExecutables = map exeName $ executables pkg--    internalLibDeps =-      [ dep-      | bi <- allBuildInfo pkg-      , dep@(Dependency name _ _) <- targetBuildDepends bi-      , name == packageName pkg-      ]--    internalExeDeps =-      [ dep-      | bi <- allBuildInfo pkg-      , dep <- getAllToolDependencies pkg bi-      , isInternal pkg dep-      ]--    -- depInternalLibraryWithExtraVersion =-    --   [ dep-    --   | dep@(Dependency _ versionRange _) <- internalLibDeps-    --   , not $ isAnyVersion versionRange-    --   , packageVersion pkg `withinRange` versionRange-    --   ]--    depInternalLibraryWithImpossibleVersion =-      [ dep-      | dep@(Dependency _ versionRange _) <- internalLibDeps-      , not $ packageVersion pkg `withinRange` versionRange-      ]--    -- depInternalExecutableWithExtraVersion =-    --   [ dep-    --   | dep@(ExeDependency _ _ versionRange) <- internalExeDeps-    --   , not $ isAnyVersion versionRange-    --   , packageVersion pkg `withinRange` versionRange-    --   ]--    depInternalExecutableWithImpossibleVersion =-      [ dep-      | dep@(ExeDependency _ _ versionRange) <- internalExeDeps-      , not $ packageVersion pkg `withinRange` versionRange-      ]--    depMissingInternalExecutable =-      [ dep-      | dep@(ExeDependency _ eName _) <- internalExeDeps-      , not $ eName `elem` internalExecutables-      ]--checkLicense :: PackageDescription -> [PackageCheck]-checkLicense pkg = case licenseRaw pkg of-    Right l -> checkOldLicense pkg l-    Left  l -> checkNewLicense pkg l--checkNewLicense :: PackageDescription -> SPDX.License -> [PackageCheck]-checkNewLicense _pkg lic = catMaybes-    [ check (lic == SPDX.NONE) $-        PackageDistInexcusable NONELicense ]--checkOldLicense :: PackageDescription -> License -> [PackageCheck]-checkOldLicense pkg lic = catMaybes-  [ check (lic == UnspecifiedLicense) $-      PackageDistInexcusable NoLicense--  , check (lic == AllRightsReserved) $-      PackageDistSuspicious AllRightsReservedLicense--  , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $-      PackageDistInexcusable (LicenseMessParse pkg)--  , case lic of-      UnknownLicense l -> Just $ PackageBuildWarning (UnrecognisedLicense l)-      _ -> Nothing--  , check (lic == BSD4) $-      PackageDistSuspicious UncommonBSD4--  , case unknownLicenseVersion lic of-      Just knownVersions -> Just $-        PackageDistSuspicious (UnknownLicenseVersion lic knownVersions)-      _ -> Nothing--  , check (lic `notElem` [ AllRightsReserved-                                 , UnspecifiedLicense, PublicDomain]-           -- AllRightsReserved and PublicDomain are not strictly-           -- licenses so don't need license files.-        && null (licenseFiles pkg)) $-      PackageDistSuspicious NoLicenseFile-  ]-  where-    unknownLicenseVersion (GPL  (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | GPL  (Just v') <- knownLicenses ]-    unknownLicenseVersion (LGPL (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]-    unknownLicenseVersion (AGPL (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ]-    unknownLicenseVersion (Apache  (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | Apache  (Just v') <- knownLicenses ]-    unknownLicenseVersion _ = Nothing--    checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck-    checkVersion ver cond pc-      | specVersion pkg >= ver  = Nothing-      | otherwise               = check cond pc--    compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4-                     , PublicDomain, AllRightsReserved-                     , UnspecifiedLicense, OtherLicense ]--checkSourceRepos :: PackageDescription -> [PackageCheck]-checkSourceRepos pkg =-  catMaybes $ concat [[--    case repoKind repo of-      RepoKindUnknown kind -> Just $ PackageDistInexcusable $-        UnrecognisedSourceRepo kind-      _ -> Nothing--  , check (isNothing (repoType repo)) $-      PackageDistInexcusable MissingType--  , check (isNothing (repoLocation repo)) $-      PackageDistInexcusable MissingLocation--  , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $-      PackageDistInexcusable MissingModule--  , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $-      PackageDistInexcusable MissingTag--  , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $-      PackageDistInexcusable SubdirRelPath--  , do-      subdir <- repoSubdir repo-      err    <- isGoodRelativeDirectoryPath subdir-      return $ PackageDistInexcusable (SubdirGoodRelPath err)-  ]-  | repo <- sourceRepos pkg ]----TODO: check location looks like a URL for some repo types.---- | Checks GHC options from all ghc-*-options fields in the given--- PackageDescription and reports commonly misused or non-portable flags-checkAllGhcOptions :: PackageDescription -> [PackageCheck]-checkAllGhcOptions pkg =-    checkGhcOptions "ghc-options" (hcOptions GHC) pkg- ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg- ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg---- | Extracts GHC options belonging to the given field from the given--- PackageDescription using given function and checks them for commonly misused--- or non-portable flags-checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck]-checkGhcOptions fieldName getOptions pkg =-  catMaybes [--    checkFlags ["-fasm"] $-      PackageDistInexcusable (OptFasm fieldName)--  , checkFlags ["-fvia-C"] $-      PackageDistSuspicious (OptViaC fieldName)--  , checkFlags ["-fhpc"] $-      PackageDistInexcusable (OptHpc fieldName)--  , checkFlags ["-prof"] $-      PackageBuildWarning (OptProf fieldName)--  , unlessScript . checkFlags ["-o"] $-      PackageBuildWarning (OptO fieldName)--  , checkFlags ["-hide-package"] $-      PackageBuildWarning (OptHide fieldName)--  , checkFlags ["--make"] $-      PackageBuildWarning (OptMake fieldName)--  , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $-      PackageDistSuspicious (OptONot fieldName)--  , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $-      PackageDistSuspiciousWarn (OptONot fieldName)--  , checkFlags [ "-O", "-O1"] $-      PackageDistInexcusable (OptOOne fieldName)--  , checkFlags ["-O2"] $-      PackageDistSuspiciousWarn (OptOTwo fieldName)--  , checkFlags ["-split-sections"] $-      PackageBuildWarning (OptSplitSections fieldName)--  , checkFlags ["-split-objs"] $-      PackageBuildWarning (OptSplitObjs fieldName)--  , checkFlags ["-optl-Wl,-s", "-optl-s"] $-      PackageDistInexcusable (OptWls fieldName)--  , checkFlags ["-fglasgow-exts"] $-      PackageDistSuspicious (OptExts fieldName)--  , check ("-rtsopts" `elem` lib_ghc_options) $-      PackageBuildWarning (OptRts fieldName)--  , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $-      PackageBuildWarning (OptWithRts fieldName)--  , checkAlternatives fieldName "extensions"-      [ (flag, prettyShow extension) | flag <- ghc_options_no_rtsopts-                                  , Just extension <- [ghcExtension flag] ]--  , checkAlternatives fieldName "extensions"-      [ (flag, extension) | flag@('-':'X':extension) <- ghc_options_no_rtsopts ]--  , checkAlternatives fieldName "cpp-options" $-         [ (flag, flag) | flag@('-':'D':_) <- ghc_options_no_rtsopts ]-      ++ [ (flag, flag) | flag@('-':'U':_) <- ghc_options_no_rtsopts ]--  , checkAlternatives fieldName "include-dirs"-      [ (flag, dir) | flag@('-':'I':dir) <- ghc_options_no_rtsopts ]--  , checkAlternatives fieldName "extra-libraries"-      [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ]--  , checkAlternatives fieldName "extra-libraries-static"-      [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ]--  , checkAlternatives fieldName "extra-lib-dirs"-      [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ]--  , checkAlternatives fieldName "extra-lib-dirs-static"-      [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ]--  , checkAlternatives fieldName "frameworks"-      [ (flag, fmwk) | (flag@"-framework", fmwk) <--           zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ]--  , checkAlternatives fieldName "extra-framework-dirs"-      [ (flag, dir) | (flag@"-framework-path", dir) <--           zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ]-  ]--  where-    all_ghc_options    = concatMap getOptions (allBuildInfo pkg)-    ghc_options_no_rtsopts = rmRtsOpts all_ghc_options-    lib_ghc_options    = concatMap (getOptions . libBuildInfo)-                         (allLibraries pkg)-    test_ghc_options      = concatMap (getOptions . testBuildInfo)-                            (testSuites pkg)-    benchmark_ghc_options = concatMap (getOptions . benchmarkBuildInfo)-                            (benchmarks pkg)-    test_and_benchmark_ghc_options     = test_ghc_options ++-                                         benchmark_ghc_options-    non_test_and_benchmark_ghc_options = concatMap getOptions-                                         (allBuildInfo (pkg { testSuites = []-                                                            , benchmarks = []-                                                            }))--    checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkFlags flags = check (any (`elem` flags) all_ghc_options)--    unlessScript :: Maybe PackageCheck -> Maybe PackageCheck-    unlessScript pc | packageId pkg == fakePackageId = Nothing-                    | otherwise                      = pc--    checkTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkTestAndBenchmarkFlags flags = check (any (`elem` flags) test_and_benchmark_ghc_options)--    checkNonTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkNonTestAndBenchmarkFlags flags = check (any (`elem` flags) non_test_and_benchmark_ghc_options)--    ghcExtension ('-':'f':name) = case name of-      "allow-overlapping-instances"    -> enable  OverlappingInstances-      "no-allow-overlapping-instances" -> disable OverlappingInstances-      "th"                             -> enable  TemplateHaskell-      "no-th"                          -> disable TemplateHaskell-      "ffi"                            -> enable  ForeignFunctionInterface-      "no-ffi"                         -> disable ForeignFunctionInterface-      "fi"                             -> enable  ForeignFunctionInterface-      "no-fi"                          -> disable ForeignFunctionInterface-      "monomorphism-restriction"       -> enable  MonomorphismRestriction-      "no-monomorphism-restriction"    -> disable MonomorphismRestriction-      "mono-pat-binds"                 -> enable  MonoPatBinds-      "no-mono-pat-binds"              -> disable MonoPatBinds-      "allow-undecidable-instances"    -> enable  UndecidableInstances-      "no-allow-undecidable-instances" -> disable UndecidableInstances-      "allow-incoherent-instances"     -> enable  IncoherentInstances-      "no-allow-incoherent-instances"  -> disable IncoherentInstances-      "arrows"                         -> enable  Arrows-      "no-arrows"                      -> disable Arrows-      "generics"                       -> enable  Generics-      "no-generics"                    -> disable Generics-      "implicit-prelude"               -> enable  ImplicitPrelude-      "no-implicit-prelude"            -> disable ImplicitPrelude-      "implicit-params"                -> enable  ImplicitParams-      "no-implicit-params"             -> disable ImplicitParams-      "bang-patterns"                  -> enable  BangPatterns-      "no-bang-patterns"               -> disable BangPatterns-      "scoped-type-variables"          -> enable  ScopedTypeVariables-      "no-scoped-type-variables"       -> disable ScopedTypeVariables-      "extended-default-rules"         -> enable  ExtendedDefaultRules-      "no-extended-default-rules"      -> disable ExtendedDefaultRules-      _                                -> Nothing-    ghcExtension "-cpp"             = enable CPP-    ghcExtension _                  = Nothing--    enable  e = Just (EnableExtension e)-    disable e = Just (DisableExtension e)--    rmRtsOpts :: [String] -> [String]-    rmRtsOpts ("-with-rtsopts":_:xs) = rmRtsOpts xs-    rmRtsOpts (x:xs) = x : rmRtsOpts xs-    rmRtsOpts [] = []---checkCCOptions :: PackageDescription -> [PackageCheck]-checkCCOptions = checkCLikeOptions "C" "cc-options" ccOptions--checkCxxOptions :: PackageDescription -> [PackageCheck]-checkCxxOptions = checkCLikeOptions "C++" "cxx-options" cxxOptions--checkCLikeOptions :: String -> String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck]-checkCLikeOptions label prefix accessor pkg =-  catMaybes [--    checkAlternatives prefix "include-dirs"-      [ (flag, dir) | flag@('-':'I':dir) <- all_cLikeOptions ]--  , checkAlternatives prefix "extra-libraries"-      [ (flag, lib) | flag@('-':'l':lib) <- all_cLikeOptions ]--  , checkAlternatives prefix "extra-lib-dirs"-      [ (flag, dir) | flag@('-':'L':dir) <- all_cLikeOptions ]--  , checkAlternatives "ld-options" "extra-libraries"-      [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ]--  , checkAlternatives "ld-options" "extra-lib-dirs"-      [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ]--  , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $-      PackageDistSuspicious (COptONumber prefix label)-  ]--  where all_cLikeOptions = [ opts | bi <- allBuildInfo pkg-                                  , opts <- accessor bi ]-        all_ldOptions = [ opts | bi <- allBuildInfo pkg-                               , opts <- ldOptions bi ]--        checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck-        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 ]-    ]-    ++-    [ PackageBuildWarning (COptCPP opt)-    | 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-checkAlternatives badField goodField flags =-  check (not (null badFlags)) $-    PackageBuildWarning (OptAlternatives badField goodField flags)-  where (badFlags, _) = unzip flags--data PathKind-    = PathKindFile-    | PathKindDirectory-    | PathKindGlob-  deriving (Eq)--checkPaths :: PackageDescription -> [PackageCheck]-checkPaths pkg =-  checkPackageFileNamesWithGlob-  [ (kind == PathKindGlob, path)-  | (path, _, kind) <- relPaths ++ absPaths-  ]-  ++-  [ PackageBuildWarning (RelativeOutside field path)-  | (path, field, _) <- relPaths ++ absPaths-  , isOutsideTree path ]-  ++-  [ PackageDistInexcusable (AbsolutePath field path)-  | (path, field, _) <- relPaths-  , isAbsoluteOnAnyPlatform path ]-  ++-  [ PackageDistInexcusable (BadRelativePAth field path err)-  | (path, field, kind) <- relPaths-  -- these are not paths, but globs...-  , err <- maybeToList $ case kind of-      PathKindFile      -> isGoodRelativeFilePath path-      PathKindGlob      -> isGoodRelativeGlob path-      PathKindDirectory -> isGoodRelativeDirectoryPath path-  ]-  ++-  [ PackageDistInexcusable $ DistPoint (Just field) path-  | (path, field, _) <- relPaths ++ absPaths-  , isInsideDist path ]-  ++-  [ PackageDistInexcusable (DistPoint Nothing path)-  | bi <- allBuildInfo pkg-  , (GHC, flags) <- perCompilerFlavorToList $ options bi-  , path <- flags-  , isInsideDist path ]-  ++-  [ PackageDistInexcusable $-      GlobSyntaxError "data-files" (explainGlobSyntaxError pat err)-  | (Left err, pat) <- zip globsDataFiles $ dataFiles pkg-  ]-  ++-  [ PackageDistInexcusable-      (GlobSyntaxError "extra-source-files" (explainGlobSyntaxError pat err))-  | (Left err, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg-  ]-  ++-  [ PackageDistInexcusable $-      GlobSyntaxError "extra-doc-files" (explainGlobSyntaxError pat err)-  | (Left err, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg-  ]-  ++-  [ PackageDistSuspiciousWarn $-      RecursiveGlobInRoot "data-files" pat-  | (Right glob, pat) <- zip globsDataFiles $ dataFiles pkg-  , isRecursiveInRoot glob-  ]-  ++-  [ PackageDistSuspiciousWarn $-      RecursiveGlobInRoot "extra-source-files" pat-  | (Right glob, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg-  , isRecursiveInRoot glob-  ]-  ++-  [ PackageDistSuspiciousWarn $-      RecursiveGlobInRoot "extra-doc-files" pat-  | (Right glob, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg-  , isRecursiveInRoot glob-  ]-  where-    isOutsideTree path = case splitDirectories path of-      "..":_     -> True-      ".":"..":_ -> True-      _          -> False-    isInsideDist path = case map lowercase (splitDirectories path) of-      "dist"    :_ -> True-      ".":"dist":_ -> True-      _            -> False--    -- paths that must be relative-    relPaths :: [(FilePath, String, PathKind)]-    relPaths =-      [ (path, "extra-source-files", PathKindGlob)      | path <- extraSrcFiles pkg ] ++-      [ (path, "extra-tmp-files",    PathKindFile)      | path <- extraTmpFiles pkg ] ++-      [ (path, "extra-doc-files",    PathKindGlob)      | path <- extraDocFiles pkg ] ++-      [ (path, "data-files",         PathKindGlob)      | path <- dataFiles     pkg ] ++-      [ (path, "data-dir",           PathKindDirectory) | path <- [dataDir      pkg]] ++-      [ (path, "license-file",       PathKindFile)      | path <- map getSymbolicPath $ licenseFiles  pkg ] ++-      concat-        [ [ (path, "asm-sources",      PathKindFile)      | path <- asmSources      bi ] ++-          [ (path, "cmm-sources",      PathKindFile)      | path <- cmmSources      bi ] ++-          [ (path, "c-sources",        PathKindFile)      | path <- cSources        bi ] ++-          [ (path, "cxx-sources",      PathKindFile)      | path <- cxxSources      bi ] ++-          [ (path, "js-sources",       PathKindFile)      | path <- jsSources       bi ] ++-          [ (path, "install-includes", PathKindFile)      | path <- installIncludes bi ] ++-          [ (path, "hs-source-dirs",   PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi ]-        | bi <- allBuildInfo pkg-        ]--    -- paths that are allowed to be absolute-    absPaths :: [(FilePath, String, PathKind)]-    absPaths = concat-      [ [ (path, "includes",       PathKindFile)      | path <- includes     bi ] ++-        [ (path, "include-dirs",   PathKindDirectory) | path <- includeDirs  bi ] ++-        [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ] ++-        [ (path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi ]-      | bi <- allBuildInfo pkg-      ]-    globsDataFiles :: [Either GlobSyntaxError Glob]-    globsDataFiles =  parseFileGlob (specVersion pkg) <$> dataFiles pkg-    globsExtraSrcFiles :: [Either GlobSyntaxError Glob]-    globsExtraSrcFiles =  parseFileGlob (specVersion pkg) <$> extraSrcFiles pkg-    globsExtraDocFiles :: [Either GlobSyntaxError Glob]-    globsExtraDocFiles =  parseFileGlob (specVersion pkg) <$> extraDocFiles pkg----TODO: check sets of paths that would be interpreted differently between Unix--- and windows, ie case-sensitive or insensitive. Things that might clash, or--- conversely be distinguished.----TODO: use the tar path checks on all the above paths---- | Check that the package declares the version in the @\"cabal-version\"@--- field correctly.----checkCabalVersion :: PackageDescription -> [PackageCheck]-checkCabalVersion pkg =-  catMaybes [--    -- check use of test suite sections-    checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $-      PackageDistInexcusable CVTestSuite--    -- check use of default-language field-    -- note that we do not need to do an equivalent check for the-    -- other-language field since that one does not change behaviour-  , checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $-      PackageBuildWarning CVDefaultLanguage--  , check (specVersion pkg >= CabalSpecV1_10 && specVersion pkg < CabalSpecV3_4-           && any isNothing (buildInfoField defaultLanguage)) $-      PackageBuildWarning CVDefaultLanguageComponent--  , checkVersion CabalSpecV1_18-    (not . null $ extraDocFiles pkg) $-      PackageDistInexcusable CVExtraDocFiles--  , checkVersion CabalSpecV2_0-    (not (null (subLibraries pkg))) $-      PackageDistInexcusable CVMultiLib--    -- check use of reexported-modules sections-  , checkVersion CabalSpecV1_22-    (any (not.null.reexportedModules) (allLibraries pkg)) $-      PackageDistInexcusable CVReexported--    -- check use of thinning and renaming-  , checkVersion CabalSpecV2_0 usesBackpackIncludes $-      PackageDistInexcusable CVMixins--    -- check use of 'extra-framework-dirs' field-  , checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $-      -- Just a warning, because this won't break on old Cabal versions.-      PackageDistSuspiciousWarn CVExtraFrameworkDirs--    -- check use of default-extensions field-    -- don't need to do the equivalent check for other-extensions-  , checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $-      PackageBuildWarning CVDefaultExtensions--    -- check use of extensions field-  , check (specVersion pkg >= CabalSpecV1_10-           && any (not . null) (buildInfoField oldExtensions)) $-      PackageBuildWarning CVExtensionsDeprecated--  , checkVersion CabalSpecV3_0 (any (not . null)-                        (concatMap buildInfoField-                         [ asmSources-                         , cmmSources-                         , extraBundledLibs-                         , extraLibFlavours ])) $-      PackageDistInexcusable CVSources--  , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $-      PackageDistInexcusable-        (CVExtraDynamic $ buildInfoField extraDynLibFlavours)--  , checkVersion CabalSpecV2_2 (any (not . null)-                        (buildInfoField virtualModules)) $-      PackageDistInexcusable CVVirtualModules--    -- check use of "source-repository" section-  , checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $-      PackageDistInexcusable CVSourceRepository--    -- check for new language extensions-  , checkVersion CabalSpecV1_2 (not (null mentionedExtensionsThatNeedCabal12)) $-      PackageDistInexcusable-        (CVExtensions CabalSpecV1_2 mentionedExtensionsThatNeedCabal12)--  , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $-      PackageDistInexcusable-        (CVExtensions CabalSpecV1_4 mentionedExtensionsThatNeedCabal14)--  , check (specVersion pkg >= CabalSpecV1_24-           && isNothing (setupBuildInfo pkg)-           && buildType pkg == Custom) $-      PackageBuildWarning CVCustomSetup--  , check (specVersion pkg < CabalSpecV1_24-           && isNothing (setupBuildInfo pkg)-           && buildType pkg == Custom) $-      PackageDistSuspiciousWarn CVExpliticDepsCustomSetup--  , check (specVersion pkg >= CabalSpecV2_0-           && elem (autogenPathsModuleName pkg) allModuleNames-           && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $-      PackageDistInexcusable CVAutogenPaths--  , check (specVersion pkg >= CabalSpecV2_0-           && elem (autogenPackageInfoModuleName pkg) allModuleNames-           && not (elem (autogenPackageInfoModuleName pkg) allModuleNamesAutogen) ) $-      PackageDistInexcusable CVAutogenPackageInfo--  , check-      (elem (autogenPackageInfoModuleName pkg) allModuleNames)-      (PackageDistInexcusable CVAutogenPackageInfoGuard)-  ]-  where-    -- Perform a check on packages that use a version of the spec less than-    -- the version given. This is for cases where a new Cabal version adds-    -- a new feature and we want to check that it is not used prior to that-    -- version.-    checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck-    checkVersion ver cond pc-      | specVersion pkg >= ver = Nothing-      | otherwise              = check cond pc--    buildInfoField field         = map field (allBuildInfo pkg)--    usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg)--    mentionedExtensions = [ ext | bi <- allBuildInfo pkg-                                , ext <- allExtensions bi ]-    mentionedExtensionsThatNeedCabal12 =-      nub (filter (`elem` compatExtensionsExtra) mentionedExtensions)--    -- As of Cabal-1.4 we can add new extensions without worrying about-    -- breaking old versions of cabal.-    mentionedExtensionsThatNeedCabal14 =-      nub (filter (`notElem` compatExtensions) mentionedExtensions)--    -- The known extensions in Cabal-1.2.3-    compatExtensions =-      map EnableExtension-      [ OverlappingInstances, UndecidableInstances, IncoherentInstances-      , RecursiveDo, ParallelListComp, MultiParamTypeClasses-      , FunctionalDependencies, Rank2Types-      , RankNTypes, PolymorphicComponents, ExistentialQuantification-      , ScopedTypeVariables, ImplicitParams, FlexibleContexts-      , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns-      , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface-      , Arrows, Generics, NamedFieldPuns, PatternGuards-      , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms-      , HereDocuments] ++-      map DisableExtension-      [MonomorphismRestriction, ImplicitPrelude] ++-      compatExtensionsExtra--    -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6-    -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8)-    compatExtensionsExtra =-      map EnableExtension-      [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving-      , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms-      , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields-      , OverloadedStrings, GADTs, RelaxedPolyRec-      , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable-      , ConstrainedClassMethods-      ] ++-      map DisableExtension-      [MonoPatBinds]--    allModuleNames =-         (case library pkg of-           Nothing -> []-           (Just lib) -> explicitLibModules lib-         )-      ++ concatMap otherModules (allBuildInfo pkg)--    allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg)---- --------------------------------------------------------------- * Checks on the GenericPackageDescription--- ---------------------------------------------------------------- | Check the build-depends fields for any weirdness or bad practice.----checkPackageVersions :: GenericPackageDescription -> [PackageCheck]-checkPackageVersions pkg =-  -- if others is empty,-  -- the error will still fire but listing no dependencies.-  -- so we have to check-  if length others > 0-  then-    PackageDistSuspiciousWarn (MissingUpperBounds others) : baseErrors-  else-    baseErrors-  where-    baseErrors = PackageDistInexcusable BaseNoUpperBounds <$ bases-    deps = toDependencyVersionsMap allNonInternalBuildDepends pkg-    -- base gets special treatment (it's more critical)-    (bases, others) = partition (("base" ==) . unPackageName) $-      [ name-      | (name, vr) <- Map.toList deps-      , not (hasUpperBound vr)-      ]--    -- Get the combined build-depends entries of all components.-    allNonInternalBuildDepends :: PackageDescription -> [Dependency]-    allNonInternalBuildDepends = targetBuildDepends CM.<=< allNonInternalBuildInfo--    allNonInternalBuildInfo :: PackageDescription -> [BuildInfo]-    allNonInternalBuildInfo pkg_descr =-      [bi | lib <- allLibraries pkg_descr, let bi = libBuildInfo lib]-        ++ [bi | flib <- foreignLibs pkg_descr, let bi = foreignLibBuildInfo flib]-        ++ [bi | exe <- executables pkg_descr, let bi = buildInfo exe]--checkConditionals :: GenericPackageDescription -> [PackageCheck]-checkConditionals pkg =-  catMaybes [--    check (not $ null unknownOSs) $-      PackageDistInexcusable (UnknownOS unknownOSs)--  , check (not $ null unknownArches) $-      PackageDistInexcusable (UnknownArch unknownArches)--  , check (not $ null unknownImpls) $-      PackageDistInexcusable (UnknownCompiler unknownImpls)-  ]-  where-    unknownOSs    = [ os   | OS   (OtherOS os)           <- conditions, os /= "haiku" ]-    unknownArches = [ arch | Arch (OtherArch arch)       <- conditions ]-    unknownImpls  = [ impl | Impl (OtherCompiler impl) _ <- conditions ]-    conditions = concatMap fvs (maybeToList (condLibrary pkg))-              ++ concatMap (fvs . snd) (condSubLibraries pkg)-              ++ concatMap (fvs . snd) (condForeignLibs pkg)-              ++ concatMap (fvs . snd) (condExecutables pkg)-              ++ concatMap (fvs . snd) (condTestSuites pkg)-              ++ concatMap (fvs . snd) (condBenchmarks pkg)-    fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables-    compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct-    condfv c = case c of-      Var v      -> [v]-      Lit _      -> []-      CNot c1    -> condfv c1-      COr  c1 c2 -> condfv c1 ++ condfv c2-      CAnd c1 c2 -> condfv c1 ++ condfv c2--checkFlagNames :: GenericPackageDescription -> [PackageCheck]-checkFlagNames gpd-    | null invalidFlagNames = []-    | otherwise             =-        [ PackageDistInexcusable (SuspiciousFlagName invalidFlagNames) ]-  where-    invalidFlagNames =-        [ fn-        | flag <- genPackageFlags gpd-        , let fn = unFlagName (flagName flag)-        , invalidFlagName fn-        ]-    -- starts with dash-    invalidFlagName ('-':_) = True-    -- mon ascii letter-    invalidFlagName cs = any (not . isAscii) cs--checkUnusedFlags :: GenericPackageDescription -> [PackageCheck]-checkUnusedFlags gpd-    | declared == used = []-    | otherwise        =-        [ PackageDistSuspicious (DeclaredUsedFlags declared used) ]-  where-    declared :: Set.Set FlagName-    declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd--    used :: Set.Set FlagName-    used = mconcat-        [ toSetOf (L.condLibrary      . traverse      . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condForeignLibs  . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condExecutables  . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condTestSuites   . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        , toSetOf (L.condBenchmarks   . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd-        ]--checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck]-checkUnicodeXFields gpd-    | null nonAsciiXFields = []-    | otherwise            =-        [ PackageDistInexcusable (NonASCIICustomField nonAsciiXFields) ]-  where-    nonAsciiXFields :: [String]-    nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ]--    xfields :: [(String,String)]-    xfields = DList.runDList $ mconcat-        [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd-        , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd-        ]---- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build.-checkPathsModuleExtensions :: PackageDescription -> [PackageCheck]-checkPathsModuleExtensions = checkAutogenModuleExtensions autogenPathsModuleName RebindableClashPaths---- | cabal-version <2.2 + PackageInfo_module + default-extensions: doesn't build.-checkPackageInfoModuleExtensions :: PackageDescription -> [PackageCheck]-checkPackageInfoModuleExtensions = checkAutogenModuleExtensions autogenPackageInfoModuleName RebindableClashPackageInfo---- | cabal-version <2.2 + *_module + default-extensions: doesn't build.-checkAutogenModuleExtensions ::-  (PackageDescription -> ModuleName) ->-  CheckExplanation ->-  PackageDescription ->-  [PackageCheck]-checkAutogenModuleExtensions autogenModuleName rebindableClashExplanation pd-    | specVersion pd >= CabalSpecV2_2 = []-    | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd)-        = return (PackageBuildImpossible rebindableClashExplanation)-    | otherwise = []-  where-    mn = autogenModuleName pd--    checkLib :: Library -> Bool-    checkLib l = mn `elem` exposedModules l && checkExts (l ^. L.defaultExtensions)--    checkBI :: BuildInfo -> Bool-    checkBI bi =-        (mn `elem` otherModules bi || mn `elem` autogenModules bi) &&-        checkExts (bi ^. L.defaultExtensions)--    checkExts exts = rebind `elem` exts && (strings `elem` exts || lists `elem` exts)-      where-        rebind  = EnableExtension RebindableSyntax-        strings = EnableExtension OverloadedStrings-        lists   = EnableExtension OverloadedLists---- | Checks GHC options from all ghc-*-options fields from the given BuildInfo--- and reports flags that are OK during development process, but are--- unacceptable in a distributed package-checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck]-checkDevelopmentOnlyFlagsBuildInfo bi =-    checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi)- ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi)- ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi)---- | Checks the given list of flags belonging to the given field and reports--- flags that are OK during development process, but are unacceptable in a--- distributed package-checkDevelopmentOnlyFlagsOptions :: String -> [String] -> [PackageCheck]-checkDevelopmentOnlyFlagsOptions fieldName ghcOptions =-  catMaybes [--    check has_Werror $-      PackageDistInexcusable (WErrorUnneeded fieldName)--  , check has_J $-      PackageDistInexcusable (JUnneeded fieldName)--  , checkFlags ["-fdefer-type-errors"] $-      PackageDistInexcusable (FDeferTypeErrorsUnneeded fieldName)--    -- -dynamic is not a debug flag-  , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic")-           ghcOptions) $-      PackageDistInexcusable (DynamicUnneeded fieldName)--  , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls",-               "-fprof-cafs", "-fno-prof-count-entries",-               "-auto-all", "-auto", "-caf-all"] $-      PackageDistSuspicious (ProfilingUnneeded fieldName)-  ]-  where--    has_Werror       = "-Werror" `elem` ghcOptions-    has_J            = any-                         (\o -> case o of-                           "-j"                -> True-                           ('-' : 'j' : d : _) -> isDigit d-                           _                   -> False-                         )-                         ghcOptions-    checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkFlags flags = check (any (`elem` flags) ghcOptions)--checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck]-checkDevelopmentOnlyFlags pkg =-    concatMap checkDevelopmentOnlyFlagsBuildInfo-              [ bi-              | (conditions, bi) <- allConditionalBuildInfo-              , not (any guardedByManualFlag conditions) ]-  where-    guardedByManualFlag = definitelyFalse--    -- We've basically got three-values logic here: True, False or unknown-    -- hence this pattern to propagate the unknown cases properly.-    definitelyFalse (Var (PackageFlag n)) = maybe False not (Map.lookup n manualFlags)-    definitelyFalse (Var _)        = False-    definitelyFalse (Lit  b)       = not b-    definitelyFalse (CNot c)       = definitelyTrue c-    definitelyFalse (COr  c1 c2)   = definitelyFalse c1 && definitelyFalse c2-    definitelyFalse (CAnd c1 c2)   = definitelyFalse c1 || definitelyFalse c2--    definitelyTrue (Var (PackageFlag n)) = fromMaybe False (Map.lookup n manualFlags)-    definitelyTrue (Var _)        = False-    definitelyTrue (Lit  b)       = b-    definitelyTrue (CNot c)       = definitelyFalse c-    definitelyTrue (COr  c1 c2)   = definitelyTrue c1 || definitelyTrue c2-    definitelyTrue (CAnd c1 c2)   = definitelyTrue c1 && definitelyTrue c2--    manualFlags = Map.fromList-                    [ (flagName flag, flagDefault flag)-                    | flag <- genPackageFlags pkg-                    , flagManual flag ]--    allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)]-    allConditionalBuildInfo =-        concatMap (collectCondTreePaths libBuildInfo)-                  (maybeToList (condLibrary pkg))--     ++ concatMap (collectCondTreePaths libBuildInfo . snd)-                  (condSubLibraries pkg)--     ++ concatMap (collectCondTreePaths buildInfo . snd)-                  (condExecutables pkg)--     ++ concatMap (collectCondTreePaths testBuildInfo . snd)-                  (condTestSuites pkg)--     ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd)-                  (condBenchmarks pkg)--    -- get all the leaf BuildInfo, paired up with the path (in the tree sense)-    -- of if-conditions that guard it-    collectCondTreePaths :: (a -> b)-                         -> CondTree v c a-                         -> [([Condition v], b)]-    collectCondTreePaths mapData = go []-      where-        go conditions condNode =-            -- the data at this level in the tree:-            (reverse conditions, mapData (condTreeData condNode))--          : concat-            [ go (condition:conditions) ifThen-            | (CondBranch condition ifThen _) <- condTreeComponents condNode ]--         ++ concat-            [ go (condition:conditions) elseThen-            | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ]----- --------------------------------------------------------------- * Checks involving files in the package--- ---------------------------------------------------------------- | Sanity check things that requires IO. It looks at the files in the--- package and expects to find the package unpacked in at the given file path.----checkPackageFiles :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck]-checkPackageFiles verbosity pkg root = do-  contentChecks <- checkPackageContent checkFilesIO pkg-  preDistributionChecks <- checkPackageFilesPreDistribution verbosity pkg root-  -- Sort because different platforms will provide files from-  -- `getDirectoryContents` in different orders, and we'd like to be-  -- stable for test output.-  return (sort contentChecks ++ sort preDistributionChecks)-  where-    checkFilesIO = CheckPackageContentOps {-      doesFileExist        = System.doesFileExist                  . relative,-      doesDirectoryExist   = System.doesDirectoryExist             . relative,-      getDirectoryContents = System.Directory.getDirectoryContents . relative,-      getFileContents      = BS.readFile                           . relative-    }-    relative path = root </> path---- | A record of operations needed to check the contents of packages.--- Used by 'checkPackageContent'.----data CheckPackageContentOps m = CheckPackageContentOps {-    doesFileExist        :: FilePath -> m Bool,-    doesDirectoryExist   :: FilePath -> m Bool,-    getDirectoryContents :: FilePath -> m [FilePath],-    getFileContents      :: FilePath -> m BS.ByteString-  }---- | Sanity check things that requires looking at files in the package.--- This is a generalised version of 'checkPackageFiles' that can work in any--- monad for which you can provide 'CheckPackageContentOps' operations.------ The point of this extra generality is to allow doing checks in some virtual--- file system, for example a tarball in memory.----checkPackageContent :: (Monad m, Applicative m)-                    => CheckPackageContentOps m-                    -> PackageDescription-                    -> m [PackageCheck]-checkPackageContent ops pkg = do-  cabalBomError   <- checkCabalFileBOM    ops-  cabalNameError  <- checkCabalFileName   ops pkg-  licenseErrors   <- checkLicensesExist   ops pkg-  setupError      <- checkSetupExists     ops pkg-  configureError  <- checkConfigureExists ops pkg-  localPathErrors <- checkLocalPathsExist ops pkg-  vcsLocation     <- checkMissingVcsInfo  ops pkg--  return $ licenseErrors-        ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError]-        ++ localPathErrors-        ++ vcsLocation--checkCabalFileBOM :: Monad m => CheckPackageContentOps m-                  -> m (Maybe PackageCheck)-checkCabalFileBOM ops = do-  epdfile <- findPackageDesc ops-  case epdfile of-    -- MASSIVE HACK.  If the Cabal file doesn't exist, that is-    -- a very strange situation to be in, because the driver code-    -- in 'Distribution.Setup' ought to have noticed already!-    -- But this can be an issue, see #3552 and also when-    -- --cabal-file is specified.  So if you can't find the file,-    -- just don't bother with this check.-    Left _       -> return Nothing-    Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8)-                    `liftM` getFileContents ops pdfile-      where pc = PackageDistInexcusable (BOMStart pdfile)--  where-    bomUtf8 :: BS.ByteString-    bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8--checkCabalFileName :: Monad m => CheckPackageContentOps m-                 -> PackageDescription-                 -> m (Maybe PackageCheck)-checkCabalFileName ops pkg = do-  -- findPackageDesc already takes care to detect missing/multiple-  -- .cabal files; we don't include this check in 'findPackageDesc' in-  -- order not to short-cut other checks which call 'findPackageDesc'-  epdfile <- findPackageDesc ops-  case epdfile of-    -- see "MASSIVE HACK" note in 'checkCabalFileBOM'-    Left _       -> return Nothing-    Right pdfile-      | takeFileName pdfile == expectedCabalname -> return Nothing-      | otherwise -> return $ Just $ PackageDistInexcusable-                       (NotPackageName pdfile expectedCabalname)-  where-    pkgname = unPackageName . packageName $ pkg-    expectedCabalname = pkgname <.> "cabal"----- |Find a package description file in the given directory.  Looks for--- @.cabal@ files.  Like 'Distribution.Simple.Utils.findPackageDesc',--- but generalized over monads.-findPackageDesc :: Monad m => CheckPackageContentOps m-                 -> m (Either PackageCheck FilePath) -- ^<pkgname>.cabal-findPackageDesc ops- = do let dir = "."-      files <- getDirectoryContents ops dir-      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal-      -- file we filter to exclude dirs and null base file names:-      cabalFiles <- filterM (doesFileExist ops)-                       [ dir </> file-                       | file <- files-                       , let (name, ext) = splitExtension file-                       , not (null name) && ext == ".cabal" ]-      case cabalFiles of-        []          -> return (Left $ PackageBuildImpossible NoDesc)-        [cabalFile] -> return (Right cabalFile)-        multiple    -> return (Left $ PackageBuildImpossible-                                (MultiDesc multiple))--checkLicensesExist :: (Monad m, Applicative m)-                   => CheckPackageContentOps m-                   -> PackageDescription-                   -> m [PackageCheck]-checkLicensesExist ops pkg = do-    exists <- traverse (doesFileExist ops . getSymbolicPath) (licenseFiles pkg)-    return-      [ PackageBuildWarning (UnknownFile fieldname file)-      | (file, False) <- zip (licenseFiles pkg) exists ]-  where-    fieldname | length (licenseFiles pkg) == 1 = "license-file"-              | otherwise                      = "license-files"--checkSetupExists :: Monad m => CheckPackageContentOps m-                 -> PackageDescription-                 -> m (Maybe PackageCheck)-checkSetupExists ops pkg = do-  let simpleBuild = buildType pkg == Simple-  hsexists  <- doesFileExist ops "Setup.hs"-  lhsexists <- doesFileExist ops "Setup.lhs"-  return $ check (not simpleBuild && not hsexists && not lhsexists) $-    PackageDistInexcusable MissingSetupFile--checkConfigureExists :: Monad m => CheckPackageContentOps m-                     -> PackageDescription-                     -> m (Maybe PackageCheck)-checkConfigureExists ops pd-  | buildType pd == Configure = do-      exists <- doesFileExist ops "configure"-      return $ check (not exists) $-        PackageBuildWarning MissingConfigureScript-  | otherwise = return Nothing--checkLocalPathsExist :: Monad m => CheckPackageContentOps m-                     -> PackageDescription-                     -> m [PackageCheck]-checkLocalPathsExist ops pkg = do-  let dirs = [ (dir, kind)-             | bi <- allBuildInfo pkg-             , (dir, kind) <--                  [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ]-               ++ [ (dir, "extra-lib-dirs-static") | dir <- extraLibDirsStatic bi ]-               ++ [ (dir, "extra-framework-dirs")-                  | dir <- extraFrameworkDirs  bi ]-               ++ [ (dir, "include-dirs")   | dir <- includeDirs  bi ]-               ++ [ (getSymbolicPath dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]-             , isRelativeOnAnyPlatform dir ]-  missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs-  return [ PackageBuildWarning (UnknownDirectory kind dir)-         | (dir, kind) <- missing ]--checkMissingVcsInfo :: (Monad m, Applicative m)-                    => CheckPackageContentOps m-                    -> PackageDescription-                    -> m [PackageCheck]-checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do-    vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames-    if vcsInUse-      then return [ PackageDistSuspicious MissingSourceControl ]-      else return []-  where-    repoDirnames = [ dirname | repo    <- knownRepoTypes-                             , dirname <- repoTypeDirname repo]--checkMissingVcsInfo _ _ = return []--repoTypeDirname :: KnownRepoType -> [FilePath]-repoTypeDirname Darcs     = ["_darcs"]-repoTypeDirname Git       = [".git"]-repoTypeDirname SVN       = [".svn"]-repoTypeDirname CVS       = ["CVS"]-repoTypeDirname Mercurial = [".hg"]-repoTypeDirname GnuArch   = [".arch-params"]-repoTypeDirname Bazaar    = [".bzr"]-repoTypeDirname Monotone  = ["_MTN"]-repoTypeDirname Pijul     = [".pijul"]---- --------------------------------------------------------------- * Checks involving files in the package--- ---------------------------------------------------------------- | Check the names of all files in a package for portability problems. This--- should be done for example when creating or validating a package tarball.----checkPackageFileNames :: [FilePath] -> [PackageCheck]-checkPackageFileNames = checkPackageFileNamesWithGlob . zip (repeat True)--checkPackageFileNamesWithGlob :: [(Bool, FilePath)] -> [PackageCheck]-checkPackageFileNamesWithGlob files =-  catMaybes $-    checkWindowsPaths files-    :-    [ checkTarPath file-    | (_, file) <- files-    ]--checkWindowsPaths :: [(Bool, FilePath)] -> Maybe PackageCheck-checkWindowsPaths paths =-    case filter (not . FilePath.Windows.isValid . escape) paths of-      [] -> Nothing-      ps -> Just $-        PackageDistInexcusable (InvalidOnWin $ map snd ps)-  where-    -- force a relative name to catch invalid file names like "f:oo" which-    -- otherwise parse as file "oo" in the current directory on the 'f' drive.-    escape (isGlob, path) = (".\\" ++)-        -- glob paths will be expanded before being dereferenced, so asterisks-        -- shouldn't count against them.-      $ map (\c -> if c == '*' && isGlob then 'x' else c) path---- | Check a file name is valid for the portable POSIX tar format.------ The POSIX tar format has a restriction on the length of file names. It is--- unfortunately not a simple restriction like a maximum length. The exact--- restriction is that either the whole path be 100 characters or less, or it--- be possible to split the path on a directory separator such that the first--- part is 155 characters or less and the second part 100 characters or less.----checkTarPath :: FilePath -> Maybe PackageCheck-checkTarPath path-  | length path > 255   = Just longPath-  | otherwise = case pack nameMax (reverse (splitPath path)) of-    Left err           -> Just err-    Right []           -> Nothing-    Right (h:rest) -> case pack prefixMax remainder of-      Left err         -> Just err-      Right []         -> Nothing-      Right (_:_)      -> Just noSplit-     where-        -- drop the '/' between the name and prefix:-        remainder = safeInit h : rest--  where-    nameMax, prefixMax :: Int-    nameMax   = 100-    prefixMax = 155--    pack _   []     = Left emptyName-    pack maxLen (c:cs)-      | n > maxLen  = Left longName-      | otherwise   = Right (pack' maxLen n cs)-      where n = length c--    pack' maxLen n (c:cs)-      | n' <= maxLen = pack' maxLen n' cs-      where n' = n + length c-    pack' _     _ cs = cs--    longPath = PackageDistInexcusable (FilePathTooLong path)-    longName = PackageDistInexcusable (FilePathNameTooLong path)-    noSplit = PackageDistInexcusable (FilePathSplitTooLong path)-    emptyName = PackageDistInexcusable FilePathEmpty---- ----------------------------------------------------------------- * Checks for missing content and other pre-distribution checks--- ------------------------------------------------------------------ | Similar to 'checkPackageContent', 'checkPackageFilesPreDistribution'--- inspects the files included in the package, but is primarily looking for--- files in the working tree that may have been missed or other similar--- problems that can only be detected pre-distribution.------ Because Hackage necessarily checks the uploaded tarball, it is too late to--- check these on the server; these checks only make sense in the development--- and package-creation environment. Hence we can use IO, rather than needing--- to pass a 'CheckPackageContentOps' dictionary around.-checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck]--- Note: this really shouldn't return any 'Inexcusable' warnings,--- because that will make us say that Hackage would reject the package.--- But, because Hackage doesn't run these tests, that will be a lie!-checkPackageFilesPreDistribution = checkGlobFiles---- | Discover problems with the package's wildcards.-checkGlobFiles :: Verbosity-               -> PackageDescription-               -> FilePath-               -> IO [PackageCheck]-checkGlobFiles verbosity pkg root = do-  -- Get the desirable doc files from package’s directory-  rootContents <- System.Directory.getDirectoryContents root-  docFiles0 <- filterM System.doesFileExist-                       [ file-                       | file <- rootContents-                       , isDesirableExtraDocFile desirableDocFiles file-                       ]-  -- Check the globs-  (warnings, unlisted) <- foldrM checkGlob ([], docFiles0) allGlobs--  return $ if null unlisted-    -- No missing desirable file-    then warnings-    -- Some missing desirable files-    else warnings ++-         let unlisted' = (root </>) <$> unlisted-         in [ PackageDistSuspiciousWarn-                (MissingExpectedDocFiles extraDocFilesSupport unlisted')-            ]-  where-    -- `extra-doc-files` is supported only from version 1.18-    extraDocFilesSupport = specVersion pkg >= CabalSpecV1_18-    adjustedDataDir = if null (dataDir pkg) then root else root </> dataDir pkg-    -- Cabal fields with globs-    allGlobs :: [(String, Bool, FilePath, FilePath)]-    allGlobs = concat-      [ (,,,) "extra-source-files" (not extraDocFilesSupport) root <$>-        extraSrcFiles pkg-      , (,,,) "extra-doc-files" True root <$> extraDocFiles pkg-      , (,,,) "data-files" False adjustedDataDir <$> dataFiles pkg-      ]--    -- For each field with globs (see allGlobs), look for:-    -- • errors (missing directory, no match)-    -- • omitted documentation files (changelog)-    checkGlob :: (String, Bool, FilePath, FilePath)-              -> ([PackageCheck], [FilePath])-              -> IO ([PackageCheck], [FilePath])-    checkGlob (field, isDocField, dir, glob) acc@(warnings, docFiles1) =-      -- Note: we just skip over parse errors here; they're reported elsewhere.-      case parseFileGlob (specVersion pkg) glob of-        Left _ -> return acc-        Right parsedGlob -> do-          results <- runDirFileGlob verbosity (root </> dir) parsedGlob-          let acc0 = (warnings, True, docFiles1, [])-          return $ case foldr checkGlobResult acc0 results of-            (individualWarn, noMatchesWarn, docFiles1', wrongPaths) ->-              let wrongFieldWarnings = [ PackageDistSuspiciousWarn-                                          (WrongFieldForExpectedDocFiles-                                            extraDocFilesSupport-                                            field wrongPaths)-                                       | not (null wrongPaths) ]-              in-                ( if noMatchesWarn-                    then [PackageDistSuspiciousWarn (GlobNoMatch field glob)] ++-                         individualWarn ++-                         wrongFieldWarnings-                    else individualWarn ++ wrongFieldWarnings-                , docFiles1'-                )-          where-            checkGlobResult :: GlobResult FilePath-                            -> ([PackageCheck], Bool, [FilePath], [FilePath])-                            -> ([PackageCheck], Bool, [FilePath], [FilePath])-            checkGlobResult result (ws, noMatchesWarn, docFiles2, wrongPaths) =-              let noMatchesWarn' = noMatchesWarn &&-                                   not (suppressesNoMatchesWarning result)-              in case getWarning field glob result of-                -- No match: add warning and do no further check-                Left w ->-                  ( w : ws-                  , noMatchesWarn'-                  , docFiles2-                  , wrongPaths-                  )-                -- Match: check doc files-                Right path ->-                  let path' = makeRelative root (normalise path)-                      (docFiles2', wrongPaths') = checkDoc isDocField-                                                           path'-                                                           docFiles2-                                                           wrongPaths-                  in-                    ( ws-                    , noMatchesWarn'-                    , docFiles2'-                    , wrongPaths'-                    )--    -- Check whether a path is a desirable doc: if so, check if it is in the-    -- field "extra-doc-files".-    checkDoc :: Bool                     -- Is it "extra-doc-files" ?-             -> FilePath                 -- Path to test-             -> [FilePath]               -- Pending doc files to check-             -> [FilePath]               -- Previous wrong paths-             -> ([FilePath], [FilePath]) -- Updated paths-    checkDoc isDocField path docFiles wrongFieldPaths =-      if path `elem` docFiles-        -- Found desirable doc file-        then-          ( delete path docFiles-          , if isDocField then wrongFieldPaths else path : wrongFieldPaths-          )-        -- Not a desirable doc file-        else-          ( docFiles-          , wrongFieldPaths-          )--    -- Predicate for desirable documentation file on Hackage server-    isDesirableExtraDocFile :: ([FilePath], [FilePath]) -> FilePath -> Bool-    isDesirableExtraDocFile (basenames, extensions) path =-      basename `elem` basenames && ext `elem` extensions-      where-        (basename, ext) = splitExtension (map toLower path)--    -- Changelog patterns (basenames & extensions)-    -- Source: hackage-server/src/Distribution/Server/Packages/ChangeLog.hs-    desirableChangeLog =-      [ "news"-      , "changelog"-      , "change_log"-      , "changes"-      ]-    desirableChangeLogExtensions = ["", ".txt", ".md", ".markdown", ".rst"]-    -- [TODO] Check readme. Observations:-    --        • Readme is not necessary if package description is good.-    --        • Some readmes exists only for repository browsing.-    --        • There is currently no reliable way to check what a good-    --          description is; there will be complains if the criterion is-    --          based on the length or number of words (can of worms).-    -- -- Readme patterns-    -- -- Source: hackage-server/src/Distribution/Server/Packages/Readme.hs-    -- desirableReadme = ["readme"]-    desirableDocFiles = (desirableChangeLog, desirableChangeLogExtensions)--    -- If there's a missing directory in play, since our globs don't-    -- (currently) support disjunction, that will always mean there are no-    -- matches. The no matches error in this case is strictly less informative-    -- than the missing directory error, so sit on it.-    suppressesNoMatchesWarning (GlobMatch _) = True-    suppressesNoMatchesWarning (GlobWarnMultiDot _) = False-    suppressesNoMatchesWarning (GlobMissingDirectory _) = True--    getWarning :: String-               -> FilePath-               -> GlobResult FilePath-               -> Either PackageCheck FilePath-    getWarning _ _ (GlobMatch path) =-      Right path-    -- Before Cabal 2.4, the extensions of globs had to match the file-    -- exactly. This has been relaxed in 2.4 to allow matching only the-    -- suffix. This warning detects when pre-2.4 package descriptions are-    -- omitting files purely because of the stricter check.-    getWarning field glob (GlobWarnMultiDot file) =-      Left (PackageDistSuspiciousWarn (GlobExactMatch field glob file))-    getWarning field glob (GlobMissingDirectory dir) =-      Left (PackageDistSuspiciousWarn (GlobNoDir field glob dir))---- | Check that setup dependencies, have proper bounds.--- In particular, @base@ and @Cabal@ upper bounds are mandatory.-checkSetupVersions :: GenericPackageDescription -> [PackageCheck]-checkSetupVersions pkg =-    [ emitError nameStr-    | (name, vr) <- Map.toList deps-    , not (hasUpperBound vr)-    , let nameStr = unPackageName name-    , nameStr `elem` criticalPkgs-    ]-  where-    criticalPkgs = ["Cabal", "base"]-    deps = toDependencyVersionsMap (foldMap setupDepends . setupBuildInfo) pkg-    emitError nm =-      PackageDistInexcusable (UpperBoundSetup nm)--checkDuplicateModules :: GenericPackageDescription -> [PackageCheck]-checkDuplicateModules pkg =-       concatMap checkLib   (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg)-    ++ concatMap checkExe   (map snd $ condExecutables pkg)-    ++ concatMap checkTest  (map snd $ condTestSuites  pkg)-    ++ concatMap checkBench (map snd $ condBenchmarks  pkg)-  where-    -- the duplicate modules check is has not been thoroughly vetted for backpack-    checkLib   = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l))-    checkExe   = checkDups "executable" exeModules-    checkTest  = checkDups "test suite" testModules-    checkBench = checkDups "benchmark"  benchmarkModules-    checkDups s getModules t =-               let sumPair (x,x') (y,y') = (x + x' :: Int, y + y' :: Int)-                   mergePair (x, x') (y, y') = (x + x', max y y')-                   maxPair (x, x') (y, y') = (max x x', max y y')-                   libMap = foldCondTree Map.empty-                                         (\(_,v) -> Map.fromListWith sumPair . map (\x -> (x,(1, 1))) $ getModules v )-                                         (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely.-                                         (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches-                                         t-                   dupLibsStrict = Map.keys $ Map.filter ((>1) . fst) libMap-                   dupLibsLax = Map.keys $ Map.filter ((>1) . snd) libMap-               in if not (null dupLibsLax)-                      then [PackageBuildImpossible-                             (DuplicateModule s dupLibsLax)]-                      else if not (null dupLibsStrict)-                           then [PackageDistSuspicious-                                   (PotentialDupModule s dupLibsStrict)]-                           else []---- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------toDependencyVersionsMap :: (PackageDescription -> [Dependency]) -> GenericPackageDescription -> Map PackageName VersionRange-toDependencyVersionsMap selectDependencies pkg = case typicalPkg pkg of-      Right (pkgs', _) ->-        let-          self :: PackageName-          self = pkgName $ package pkgs'-        in-        Map.fromListWith intersectVersionRanges $-          [ (pname, vr)-          | Dependency pname vr _ <- selectDependencies pkgs'-          , pname /= self-          ]-      -- Just in case finalizePD fails for any reason,-      -- or if the package doesn't depend on the base package at all,-      -- no deps is no checks.-      _ -> Map.empty---quote :: String -> String-quote s = "'" ++ s ++ "'"--commaSep :: [String] -> String-commaSep = intercalate ", "--dups :: Ord a => [a] -> [a]-dups xs = [ x | (x:_:_) <- group (sort xs) ]--fileExtensionSupportedLanguage :: FilePath -> Bool-fileExtensionSupportedLanguage path =-    isHaskell || isC-  where-    extension = takeExtension path-    isHaskell = extension `elem` [".hs", ".lhs"]-    isC       = isJust (filenameCDialect extension)---- | Whether a path is a good relative path.  We aren't worried about perfect--- cross-platform compatibility here; this function just checks the paths in--- the (local) @.cabal@ file, while only Hackage needs the portability.------ >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp)------ Note that "foo./bar.hs" would be invalid on Windows.------ >>> traverse_ test ["foo/bar/quu", "a/b.hs", "foo./bar.hs"]--- Nothing; Nothing--- Nothing; Nothing--- Nothing; Nothing------ Trailing slash is not allowed for files, for directories it is ok.------ >>> test "foo/"--- Nothing; Just "trailing slash"------ Leading @./@ is fine, but @.@ and @./@ are not valid files.------ >>> traverse_ test [".", "./", "./foo/bar"]--- Nothing; Just "trailing dot segment"--- Nothing; Just "trailing slash"--- Nothing; Nothing------ Lastly, not good file nor directory cases:------ >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar"]--- Just "empty path"; Just "empty path"--- Just "posix absolute path"; Just "posix absolute path"--- Just "empty path segment"; Just "empty path segment"--- Just "trailing same directory segment: ."; Just "trailing same directory segment: ."--- Just "same directory segment: ."; Just "same directory segment: ."--- Just "parent directory segment: .."; Just "parent directory segment: .."------ For the last case, 'isGoodRelativeGlob' doesn't warn:------ >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"]--- Just "parent directory segment: .."----isGoodRelativeFilePath :: FilePath -> Maybe String-isGoodRelativeFilePath = state0-  where-    -- initial state-    state0 []                    = Just "empty path"-    state0 (c:cs) | c == '.'     = state1 cs-                  | c == '/'     = Just "posix absolute path"-                  | otherwise    = state5 cs--    -- after initial .-    state1 []                    = Just "trailing dot segment"-    state1 (c:cs) | c == '.'     = state4 cs-                  | c == '/'     = state2 cs-                  | otherwise    = state5 cs--    -- after ./ or after / between segments-    state2 []                    = Just "trailing slash"-    state2 (c:cs) | c == '.'     = state3 cs-                  | c == '/'     = Just "empty path segment"-                  | otherwise    = state5 cs--    -- after non-first segment's .-    state3 []                    = Just "trailing same directory segment: ."-    state3 (c:cs) | c == '.'     = state4 cs-                  | c == '/'     = Just "same directory segment: ."-                  | otherwise    = state5 cs--    -- after ..-    state4 []                    = Just "trailing parent directory segment: .."-    state4 (c:cs) | c == '.'     = state5 cs-                  | c == '/'     = Just "parent directory segment: .."-                  | otherwise    = state5 cs--    -- in a segment which is ok.-    state5 []                    = Nothing-    state5 (c:cs) | c == '.'     = state5 cs-                  | c == '/'     = state2 cs-                  | otherwise    = state5 cs---- | See 'isGoodRelativeFilePath'.------ This is barebones function. We check whether the glob is a valid file--- by replacing stars @*@ with @x@ses.-isGoodRelativeGlob :: FilePath -> Maybe String-isGoodRelativeGlob = isGoodRelativeFilePath . map f where-    f '*' = 'x'-    f c   = c---- | See 'isGoodRelativeFilePath'.-isGoodRelativeDirectoryPath :: FilePath -> Maybe String-isGoodRelativeDirectoryPath = state0-  where-    -- initial state-    state0 []                    = Just "empty path"-    state0 (c:cs) | c == '.'     = state5 cs-                  | c == '/'     = Just "posix absolute path"-                  | otherwise    = state4 cs--    -- after initial ./ or after / between segments-    state1 []                    = Nothing-    state1 (c:cs) | c == '.'     = state2 cs-                  | c == '/'     = Just "empty path segment"-                  | otherwise    = state4 cs--    -- after non-first setgment's .-    state2 []                    = Just "trailing same directory segment: ."-    state2 (c:cs) | c == '.'     = state3 cs-                  | c == '/'     = Just "same directory segment: ."-                  | otherwise    = state4 cs--    -- after ..-    state3 []                    = Just "trailing parent directory segment: .."-    state3 (c:cs) | c == '.'     = state4 cs-                  | c == '/'     = Just "parent directory segment: .."-                  | otherwise    = state4 cs--    -- in a segment which is ok.-    state4 []                    = Nothing-    state4 (c:cs) | c == '.'     = state4 cs-                  | c == '/'     = state1 cs-                  | otherwise    = state4 cs--    -- after initial .-    state5 []                    = Nothing -- "."-    state5 (c:cs) | c == '.'     = state3 cs-                  | c == '/'     = state1 cs-                  | otherwise    = state4 cs---- [Note: Good relative paths]------ Using @kleene@ we can define an extended regex:------ @--- import Algebra.Lattice--- import Kleene--- import Kleene.ERE (ERE (..), intersections)------ data C = CDot | CSlash | CChar---   deriving (Eq, Ord, Enum, Bounded, Show)------ reservedR :: ERE C--- reservedR = notChar CSlash------ pathPieceR :: ERE C--- pathPieceR = intersections---     [ plus reservedR---     , ERENot (string [CDot])---     , ERENot (string [CDot,CDot])---     ]------ filePathR :: ERE C--- filePathR = optional (string [CDot, CSlash]) <> pathPieceR <> star (char CSlash <> pathPieceR)------ dirPathR :: ERE C--- dirPathR = (char CDot \/ filePathR) <> optional (char CSlash)------ plus :: ERE C -> ERE C--- plus r = r <> star r------ optional :: ERE C -> ERE C--- optional r = mempty \/ r--- @------ Results in following state machine for @filePathR@------ @--- 0 -> \x -> if---     | x <= CDot           -> 1---     | otherwise           -> 5--- 1 -> \x -> if---     | x <= CDot           -> 4---     | x <= CSlash         -> 2---     | otherwise           -> 5--- 2 -> \x -> if---     | x <= CDot           -> 3---     | otherwise           -> 5--- 3 -> \x -> if---     | x <= CDot           -> 4---     | otherwise           -> 5--- 4 -> \x -> if---     | x <= CDot           -> 5---     | otherwise           -> 5--- 5+ -> \x -> if---     | x <= CDot           -> 5---     | x <= CSlash         -> 2---     | otherwise           -> 5--- @------ and @dirPathR@:------ @--- 0 -> \x -> if---     | x <= CDot           -> 5---     | otherwise           -> 4--- 1+ -> \x -> if---     | x <= CDot           -> 2---     | otherwise           -> 4--- 2 -> \x -> if---     | x <= CDot           -> 3---     | otherwise           -> 4--- 3 -> \x -> if---     | x <= CDot           -> 4---     | otherwise           -> 4--- 4+ -> \x -> if---     | x <= CDot           -> 4---     | x <= CSlash         -> 1---     | otherwise           -> 4--- 5+ -> \x -> if---     | x <= CDot           -> 3---     | x <= CSlash         -> 1---     | otherwise           -> 4--- @------- TODO: What we really want to do is test if there exists any--- configuration in which the base version is unbounded above.--- However that's a bit tricky because there are many possible--- configurations. As a cheap easy and safe approximation we will--- pick a single "typical" configuration and check if that has an--- open upper bound. To get a typical configuration we finalise--- using no package index and the current platform.-typicalPkg :: GenericPackageDescription-           -> Either [Dependency] (PackageDescription, FlagAssignment)-typicalPkg = finalizePD-  mempty defaultComponentRequestedSpec (const True)-  buildPlatform-  (unknownCompilerInfo-    (CompilerId buildCompilerFlavor nullVersion)-      NoAbiTag)-  []--addConditionalExp :: String -> String-addConditionalExp expl = expl ++-         " Alternatively, if you want to use this, make it conditional based "-      ++ "on a Cabal configuration flag (with 'manual: True' and 'default: "-      ++ "False') and enable that flag during development."+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      :  Distribution.PackageDescription.Check+-- Copyright   :  Lennart Kolmodin 2008, Francesco Ariis 2022+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This has code for checking for various problems in packages. There is one+-- set of checks that just looks at a 'PackageDescription' in isolation and+-- another set of checks that also looks at files in the package. Some of the+-- checks are basic sanity checks, others are portability standards that we'd+-- like to encourage. There is a 'PackageCheck' type that distinguishes the+-- different kinds of checks so we can see which ones are appropriate to report+-- in different situations. This code gets used when configuring a package when+-- we consider only basic problems. The higher standard is used when+-- preparing a source tarball and by Hackage when uploading new packages. The+-- reason for this is that we want to hold packages that are expected to be+-- distributed to a higher standard than packages that are only ever expected+-- to be used on the author's own environment.+module Distribution.PackageDescription.Check+  ( -- * Package Checking+    CheckExplanation (..)+  , CheckExplanationID+  , CheckExplanationIDString+  , PackageCheck (..)+  , checkPackage+  , checkConfiguredPackage+  , wrapParseWarning+  , ppPackageCheck+  , ppCheckExplanationId+  , isHackageDistError+  , filterPackageChecksById+  , filterPackageChecksByIdString++    -- ** Checking package contents+  , checkPackageFiles+  , checkPackageFilesGPD+  , checkPackageContent+  , CheckPackageContentOps (..)+  ) where++import Distribution.Compat.Prelude+import Prelude ()++import Data.List (group)+import Distribution.CabalSpecVersion+import Distribution.Compat.Lens+import Distribution.Compiler+import Distribution.License+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Check.Common+import Distribution.PackageDescription.Check.Conditional+import Distribution.PackageDescription.Check.Monad+import Distribution.PackageDescription.Check.Paths+import Distribution.PackageDescription.Check.Target+import Distribution.PackageDescription.Check.Warning+import Distribution.Parsec.Warning (PWarning)+import Distribution.Pretty (prettyShow)+import Distribution.Simple.Glob+  ( Glob+  , GlobResult (..)+  , globMatches+  , parseFileGlob+  , runDirFileGlob+  )+import Distribution.Simple.Utils hiding (findPackageDesc, notice)+import Distribution.Utils.Generic (isAscii)+import Distribution.Utils.Path+  ( LicenseFile+  , PackageDir+  , SymbolicPath+  , getSymbolicPath+  )+import Distribution.Verbosity+import Distribution.Version+import System.FilePath (splitExtension, takeFileName, (<.>), (</>))++import qualified Data.ByteString.Lazy as BS+import qualified Distribution.SPDX as SPDX+import qualified System.Directory as System++import qualified System.Directory (getDirectoryContents)+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.GenericPackageDescription.Lens as L++import Control.Monad++-- $setup+-- >>> import Control.Arrow ((&&&))++-- ☞ N.B.+--+-- Part of the tools/scaffold used to perform check is found in+-- Distribution.PackageDescription.Check.Types. Summary of that module (for+-- how we use it here):+-- 1. we work inside a 'CheckM m a' monad (where `m` is an abstraction to+--    run non-pure checks);+-- 2. 'checkP', 'checkPre' functions perform checks (respectively pure and+--    non-pure);+-- 3. 'PackageCheck' and 'CheckExplanation' are types for warning severity+--    and description.++-- ------------------------------------------------------------+-- Checking interface+-- ------------------------------------------------------------++-- | 'checkPackagePrim' is the most general way to invoke package checks.+-- We pass to it two interfaces (one to check contents of packages, the+-- other to inspect working tree for orphan files) and before that a+-- Boolean to indicate whether we want pure checks or not. Based on these+-- parameters, some checks will be performed, some omitted.+-- Generality over @m@ means we could do non pure checks in monads other+-- than IO (e.g. a virtual filesystem, like a zip file, a VCS filesystem,+-- etc).+checkPackagePrim+  :: Monad m+  => Bool -- Perform pure checks?+  -> Maybe (CheckPackageContentOps m) -- Package content interface.+  -> Maybe (CheckPreDistributionOps m) -- Predist checks interface.+  -> GenericPackageDescription -- GPD to check.+  -> m [PackageCheck]+checkPackagePrim b mco mpdo gpd = do+  let cm = checkGenericPackageDescription gpd+      ci = CheckInterface b mco mpdo+      ctx = pristineCheckCtx ci gpd+  execCheckM cm ctx++-- | Check for common mistakes and problems in package descriptions.+--+-- This is the standard collection of checks covering all aspects except+-- for checks that require looking at files within the package. For those+-- see 'checkPackageFiles'.+checkPackage :: GenericPackageDescription -> [PackageCheck]+checkPackage gpd = runIdentity $ checkPackagePrim True Nothing Nothing gpd++-- | This function is an oddity due to the historical+-- GenericPackageDescription/PackageDescription split. It is only maintained+-- not to break interface, use `checkPackage` if possible.+checkConfiguredPackage :: PackageDescription -> [PackageCheck]+checkConfiguredPackage pd = checkPackage (pd2gpd pd)++-- | Sanity check things that requires looking at files in the package.+-- This is a generalised version of 'checkPackageFiles' that can work in any+-- monad for which you can provide 'CheckPackageContentOps' operations.+--+-- The point of this extra generality is to allow doing checks in some virtual+-- file system, for example a tarball in memory.+checkPackageContent+  :: Monad m+  => CheckPackageContentOps m+  -> GenericPackageDescription+  -> m [PackageCheck]+checkPackageContent pops gpd = checkPackagePrim False (Just pops) Nothing gpd++-- | Sanity checks that require IO. 'checkPackageFiles' looks at the files+-- in the package and expects to find the package unpacked at the given+-- filepath.+checkPackageFilesGPD+  :: Verbosity -- Glob warn message verbosity.+  -> GenericPackageDescription+  -> FilePath -- Package root.+  -> IO [PackageCheck]+checkPackageFilesGPD verbosity gpd root =+  checkPackagePrim False (Just checkFilesIO) (Just checkPreIO) gpd+  where+    checkFilesIO =+      CheckPackageContentOps+        { doesFileExist = System.doesFileExist . relative+        , doesDirectoryExist = System.doesDirectoryExist . relative+        , getDirectoryContents = System.Directory.getDirectoryContents . relative+        , getFileContents = BS.readFile . relative+        }++    checkPreIO =+      CheckPreDistributionOps+        { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root </> fp) g+        , getDirectoryContentsM = System.Directory.getDirectoryContents . relative+        }++    relative path = root </> path++-- | Same as  'checkPackageFilesGPD', but working with 'PackageDescription'.+--+-- This function is included for legacy reasons, use 'checkPackageFilesGPD'+-- if you are working with 'GenericPackageDescription'.+checkPackageFiles+  :: Verbosity -- Glob warn message verbosity.+  -> PackageDescription+  -> FilePath -- Package root.+  -> IO [PackageCheck]+checkPackageFiles verbosity pd oot =+  checkPackageFilesGPD verbosity (pd2gpd pd) oot++-- ------------------------------------------------------------+-- Package description+-- ------------------------------------------------------------++-- Here lies the meat of the module. Starting from 'GenericPackageDescription',+-- we walk the data while doing a number of checks.+--+-- Where applicable we do a full pattern match (if the data changes, code will+-- break: a gentle reminder to add more checks).+-- Pattern matching variables convention: matching accessor + underscore.+-- This way it is easier to see which one we are missing if we run into+-- an “GPD should have 20 arguments but has been given only 19” error.++-- | 'GenericPackageDescription' checks. Remember that for historical quirks+-- in the cabal codebase we have both `GenericPackageDescription` and+-- `PackageDescription` and that PD is both a *field* of GPD and a concept+-- of its own (i.e. a fully realised GPD).+-- In this case we are checking (correctly) GPD, so for target info/checks+-- you should walk condLibrary_ etc. and *not* the (empty) target info in+-- PD. See 'pd2gpd' for a convenient hack when you only have+-- 'PackageDescription'.+checkGenericPackageDescription+  :: Monad m+  => GenericPackageDescription+  -> CheckM m ()+checkGenericPackageDescription+  gpd@( GenericPackageDescription+          packageDescription_+          _gpdScannedVersion_+          genPackageFlags_+          condLibrary_+          condSubLibraries_+          condForeignLibs_+          condExecutables_+          condTestSuites_+          condBenchmarks_+        ) =+    do+      -- § Description and names.+      checkPackageDescription packageDescription_+      -- Targets should be present...+      let condAllLibraries =+            maybeToList condLibrary_+              ++ (map snd condSubLibraries_)+      checkP+        ( and+            [ null condExecutables_+            , null condTestSuites_+            , null condBenchmarks_+            , null condAllLibraries+            , null condForeignLibs_+            ]+        )+        (PackageBuildImpossible NoTarget)+      -- ... and have unique names (names are not under conditional, it is+      -- appropriate to check here.+      (nsubs, nexes, ntests, nbenchs) <-+        asksCM+          ( ( \n ->+                ( pnSubLibs n+                , pnExecs n+                , pnTests n+                , pnBenchs n+                )+            )+              . ccNames+          )+      let names = concat [nsubs, nexes, ntests, nbenchs]+          dupes = dups names+      checkP+        (not . null $ dups names)+        (PackageBuildImpossible $ DuplicateSections dupes)+      -- PackageDescription checks.+      checkPackageDescription packageDescription_+      -- Flag names.+      mapM_ checkFlagName genPackageFlags_++      -- § Feature checks.+      checkSpecVer+        CabalSpecV2_0+        (not . null $ condSubLibraries_)+        (PackageDistInexcusable CVMultiLib)+      checkSpecVer+        CabalSpecV1_8+        (not . null $ condTestSuites_)+        (PackageDistInexcusable CVTestSuite)++      -- § Conditional targets++      -- Extract dependencies from libraries, to be passed along for+      -- PVP checks purposes.+      pName <-+        asksCM+          ( packageNameToUnqualComponentName+              . pkgName+              . pnPackageId+              . ccNames+          )+      let ads =+            maybe [] ((: []) . extractAssocDeps pName) condLibrary_+              ++ map (uncurry extractAssocDeps) condSubLibraries_++      case condLibrary_ of+        Just cl ->+          checkCondTarget+            genPackageFlags_+            (checkLibrary False ads)+            (const id)+            (mempty, cl)+        Nothing -> return ()+      mapM_+        ( checkCondTarget+            genPackageFlags_+            (checkLibrary False ads)+            (\u l -> l{libName = maybeToLibraryName (Just u)})+        )+        condSubLibraries_+      mapM_+        ( checkCondTarget+            genPackageFlags_+            checkForeignLib+            (const id)+        )+        condForeignLibs_+      mapM_+        ( checkCondTarget+            genPackageFlags_+            (checkExecutable ads)+            (const id)+        )+        condExecutables_+      mapM_+        ( checkCondTarget+            genPackageFlags_+            (checkTestSuite ads)+            (\u l -> l{testName = u})+        )+        condTestSuites_+      mapM_+        ( checkCondTarget+            genPackageFlags_+            (checkBenchmark ads)+            (\u l -> l{benchmarkName = u})+        )+        condBenchmarks_++      -- For unused flags it is clearer and more convenient to fold the+      -- data rather than walk it, an exception to the rule.+      checkP+        (decFlags /= usedFlags)+        (PackageDistSuspicious $ DeclaredUsedFlags decFlags usedFlags)++      -- Duplicate modules.+      mapM_ tellP (checkDuplicateModules gpd)+    where+      -- todo is this caught at parse time?+      checkFlagName :: Monad m => PackageFlag -> CheckM m ()+      checkFlagName pf =+        let fn = unFlagName . flagName $ pf++            invalidFlagName ('-' : _) = True -- starts with dash+            invalidFlagName cs = any (not . isAscii) cs -- non ASCII+         in checkP+              (invalidFlagName fn)+              (PackageDistInexcusable $ SuspiciousFlagName [fn])++      decFlags :: Set.Set FlagName+      decFlags = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd++      usedFlags :: Set.Set FlagName+      usedFlags =+        mconcat+          [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd+          ]++checkPackageDescription :: Monad m => PackageDescription -> CheckM m ()+checkPackageDescription+  pkg@( PackageDescription+          specVersion_+          package_+          licenseRaw_+          licenseFiles_+          _copyright_+          maintainer_+          _author_+          _stability_+          testedWith_+          _homepage_+          _pkgUrl_+          _bugReports_+          sourceRepos_+          synopsis_+          description_+          category_+          customFieldsPD_+          buildTypeRaw_+          setupBuildInfo_+          _library_+          _subLibraries_+          _executables_+          _foreignLibs_+          _testSuites_+          _benchmarks_+          dataFiles_+          dataDir_+          extraSrcFiles_+          extraTmpFiles_+          extraDocFiles_+        ) = do+    -- § Sanity checks.+    checkPackageId package_+    -- TODO `name` is caught at parse level, remove this test.+    let pn = packageName package_+    checkP+      (null . unPackageName $ pn)+      (PackageBuildImpossible NoNameField)+    -- TODO `version` is caught at parse level, remove this test.+    checkP+      (nullVersion == packageVersion package_)+      (PackageBuildImpossible NoVersionField)+    -- But it is OK for executables to have the same name.+    nsubs <- asksCM (pnSubLibs . ccNames)+    checkP+      (any (== prettyShow pn) (prettyShow <$> nsubs))+      (PackageBuildImpossible $ IllegalLibraryName pn)++    -- § Fields check.+    checkNull+      category_+      (PackageDistSuspicious MissingFieldCategory)+    checkNull+      maintainer_+      (PackageDistSuspicious MissingFieldMaintainer)+    checkP+      (ShortText.null synopsis_ && not (ShortText.null description_))+      (PackageDistSuspicious MissingFieldSynopsis)+    checkP+      (ShortText.null description_ && not (ShortText.null synopsis_))+      (PackageDistSuspicious MissingFieldDescription)+    checkP+      (all ShortText.null [synopsis_, description_])+      (PackageDistInexcusable MissingFieldSynOrDesc)+    checkP+      (ShortText.length synopsis_ > 80)+      (PackageDistSuspicious SynopsisTooLong)+    checkP+      ( not (ShortText.null description_)+          && ShortText.length description_ <= ShortText.length synopsis_+      )+      (PackageDistSuspicious ShortDesc)++    -- § Paths.+    mapM_ (checkPath False "extra-source-files" PathKindGlob) extraSrcFiles_+    mapM_ (checkPath False "extra-tmp-files" PathKindFile) extraTmpFiles_+    mapM_ (checkPath False "extra-doc-files" PathKindGlob) extraDocFiles_+    mapM_ (checkPath False "data-files" PathKindGlob) dataFiles_+    checkPath True "data-dir" PathKindDirectory dataDir_+    let licPaths = map getSymbolicPath licenseFiles_+    mapM_ (checkPath False "license-file" PathKindFile) licPaths+    mapM_ checkLicFileExist licenseFiles_++    -- § Globs.+    dataGlobs <- mapM (checkGlob "data-files") dataFiles_+    extraGlobs <- mapM (checkGlob "extra-source-files") extraSrcFiles_+    docGlobs <- mapM (checkGlob "extra-doc-files") extraDocFiles_+    -- We collect globs to feed them to checkMissingDocs.++    -- § Missing documentation.+    checkMissingDocs+      (catMaybes dataGlobs)+      (catMaybes extraGlobs)+      (catMaybes docGlobs)++    -- § Datafield checks.+    checkSetupBuildInfo setupBuildInfo_+    mapM_ checkTestedWith testedWith_+    either+      checkNewLicense+      (checkOldLicense $ null licenseFiles_)+      licenseRaw_+    checkSourceRepos sourceRepos_+    mapM_ checkCustomField customFieldsPD_++    -- Feature checks.+    checkSpecVer+      CabalSpecV1_18+      (not . null $ extraDocFiles_)+      (PackageDistInexcusable CVExtraDocFiles)+    checkSpecVer+      CabalSpecV1_6+      (not . null $ sourceRepos_)+      (PackageDistInexcusable CVSourceRepository)+    checkP+      ( specVersion_ >= CabalSpecV1_24+          && isNothing setupBuildInfo_+          && buildTypeRaw_ == Just Custom+      )+      (PackageBuildWarning CVCustomSetup)+    checkSpecVer+      CabalSpecV1_24+      ( isNothing setupBuildInfo_+          && buildTypeRaw_ == Just Custom+      )+      (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup)+    checkP+      (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2)+      (PackageBuildWarning NoBuildType)+    checkP+      (isJust setupBuildInfo_ && buildType pkg /= Custom)+      (PackageBuildWarning NoCustomSetup)++    -- Contents.+    checkConfigureExists (buildType pkg)+    checkSetupExists (buildType pkg)+    checkCabalFile (packageName pkg)+    mapM_ (checkGlobFile specVersion_ "." "extra-source-files") extraSrcFiles_+    mapM_ (checkGlobFile specVersion_ "." "extra-doc-files") extraDocFiles_+    mapM_ (checkGlobFile specVersion_ dataDir_ "data-files") dataFiles_+    where+      checkNull+        :: Monad m+        => ShortText.ShortText+        -> PackageCheck+        -> CheckM m ()+      checkNull st c = checkP (ShortText.null st) c++      checkTestedWith+        :: Monad m+        => (CompilerFlavor, VersionRange)+        -> CheckM m ()+      checkTestedWith (OtherCompiler n, _) =+        tellP (PackageBuildWarning $ UnknownCompilers [n])+      checkTestedWith (compiler, versionRange) =+        checkVersionRange compiler versionRange++      checkVersionRange+        :: Monad m+        => CompilerFlavor+        -> VersionRange+        -> CheckM m ()+      checkVersionRange cmp vr =+        when+          (isNoVersion vr)+          ( let dep =+                  [ Dependency+                      (mkPackageName (prettyShow cmp))+                      vr+                      mainLibSet+                  ]+             in tellP (PackageDistInexcusable (InvalidTestWith dep))+          )++checkSetupBuildInfo :: Monad m => Maybe SetupBuildInfo -> CheckM m ()+checkSetupBuildInfo Nothing = return ()+checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do+  let uqs = map mkUnqualComponentName ["base", "Cabal"]+  (is, rs) <- partitionDeps [] uqs ds+  let ick = PackageDistInexcusable . UpperBoundSetup+      rck =+        PackageDistSuspiciousWarn+          . MissingUpperBounds CETSetup+  checkPVP ick is+  checkPVPs rck rs++checkPackageId :: Monad m => PackageIdentifier -> CheckM m ()+checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do+  checkP+    (not . FilePath.Windows.isValid . prettyShow $ pkgName_)+    (PackageDistInexcusable $ InvalidNameWin pkgName_)+  checkP (isPrefixOf "z-" . prettyShow $ pkgName_) $+    (PackageDistInexcusable ZPrefix)++checkNewLicense :: Monad m => SPDX.License -> CheckM m ()+checkNewLicense lic = do+  checkP+    (lic == SPDX.NONE)+    (PackageDistInexcusable NONELicense)++checkOldLicense+  :: Monad m+  => Bool -- Flag: no license file?+  -> License+  -> CheckM m ()+checkOldLicense nullLicFiles lic = do+  checkP+    (lic == UnspecifiedLicense)+    (PackageDistInexcusable NoLicense)+  checkP+    (lic == AllRightsReserved)+    (PackageDistSuspicious AllRightsReservedLicense)+  checkSpecVer+    CabalSpecV1_4+    (lic `notElem` compatLicenses)+    (PackageDistInexcusable (LicenseMessParse lic))+  checkP+    (lic == BSD4)+    (PackageDistSuspicious UncommonBSD4)+  case lic of+    UnknownLicense l ->+      tellP (PackageBuildWarning (UnrecognisedLicense l))+    _ -> return ()+  checkP+    ( lic+        `notElem` [ AllRightsReserved+                  , UnspecifiedLicense+                  , PublicDomain+                  ]+        &&+        -- AllRightsReserved and PublicDomain are not strictly+        -- licenses so don't need license files.+        nullLicFiles+    )+    $ (PackageDistSuspicious NoLicenseFile)+  case unknownLicenseVersion lic of+    Just knownVersions ->+      tellP+        (PackageDistSuspicious $ UnknownLicenseVersion lic knownVersions)+    _ -> return ()+  where+    compatLicenses =+      [ GPL Nothing+      , LGPL Nothing+      , AGPL Nothing+      , BSD3+      , BSD4+      , PublicDomain+      , AllRightsReserved+      , UnspecifiedLicense+      , OtherLicense+      ]++    unknownLicenseVersion (GPL (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where+        knownVersions = [v' | GPL (Just v') <- knownLicenses]+    unknownLicenseVersion (LGPL (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where+        knownVersions = [v' | LGPL (Just v') <- knownLicenses]+    unknownLicenseVersion (AGPL (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where+        knownVersions = [v' | AGPL (Just v') <- knownLicenses]+    unknownLicenseVersion (Apache (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where+        knownVersions = [v' | Apache (Just v') <- knownLicenses]+    unknownLicenseVersion _ = Nothing++checkSourceRepos :: Monad m => [SourceRepo] -> CheckM m ()+checkSourceRepos rs = do+  mapM_ repoCheck rs+  checkMissingVcsInfo rs+  where+    -- Single repository checks.+    repoCheck :: Monad m => SourceRepo -> CheckM m ()+    repoCheck+      ( SourceRepo+          repoKind_+          repoType_+          repoLocation_+          repoModule_+          _repoBranch_+          repoTag_+          repoSubdir_+        ) = do+        case repoKind_ of+          RepoKindUnknown kind ->+            tellP+              (PackageDistInexcusable $ UnrecognisedSourceRepo kind)+          _ -> return ()+        checkP+          (isNothing repoType_)+          (PackageDistInexcusable MissingType)+        checkP+          (isNothing repoLocation_)+          (PackageDistInexcusable MissingLocation)+        checkP+          ( repoType_ == Just (KnownRepoType CVS)+              && isNothing repoModule_+          )+          (PackageDistInexcusable MissingModule)+        checkP+          (repoKind_ == RepoThis && isNothing repoTag_)+          (PackageDistInexcusable MissingTag)+        checkP+          (any isAbsoluteOnAnyPlatform repoSubdir_)+          (PackageDistInexcusable SubdirRelPath)+        case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of+          Just err ->+            tellP+              (PackageDistInexcusable $ SubdirGoodRelPath err)+          Nothing -> return ()++checkMissingVcsInfo :: Monad m => [SourceRepo] -> CheckM m ()+checkMissingVcsInfo rs =+  let rdirs = concatMap repoTypeDirname knownRepoTypes+   in checkPkg+        ( \ops -> do+            us <- or <$> traverse (doesDirectoryExist ops) rdirs+            return (null rs && us)+        )+        (PackageDistSuspicious MissingSourceControl)+  where+    repoTypeDirname :: KnownRepoType -> [FilePath]+    repoTypeDirname Darcs = ["_darcs"]+    repoTypeDirname Git = [".git"]+    repoTypeDirname SVN = [".svn"]+    repoTypeDirname CVS = ["CVS"]+    repoTypeDirname Mercurial = [".hg"]+    repoTypeDirname GnuArch = [".arch-params"]+    repoTypeDirname Bazaar = [".bzr"]+    repoTypeDirname Monotone = ["_MTN"]+    repoTypeDirname Pijul = [".pijul"]++-- ------------------------------------------------------------+-- Package and distribution checks+-- ------------------------------------------------------------++-- | Find a package description file in the given directory.  Looks for+-- @.cabal@ files.  Like 'Distribution.Simple.Utils.findPackageDesc',+-- but generalized over monads.+findPackageDesc :: Monad m => CheckPackageContentOps m -> m [FilePath]+findPackageDesc ops = do+  let dir = "."+  files <- getDirectoryContents ops dir+  -- to make sure we do not mistake a ~/.cabal/ dir for a <name>.cabal+  -- file we filter to exclude dirs and null base file names:+  cabalFiles <-+    filterM+      (doesFileExist ops)+      [ dir </> file+      | file <- files+      , let (name, ext) = splitExtension file+      , not (null name) && ext == ".cabal"+      ]+  return cabalFiles++checkCabalFile :: Monad m => PackageName -> CheckM m ()+checkCabalFile pn = do+  -- liftInt is a bit more messy than stricter interface, but since+  -- each of the following check is exclusive, we can simplify the+  -- condition flow.+  liftInt+    ciPackageOps+    ( \ops -> do+        -- 1. Get .cabal files.+        ds <- findPackageDesc ops+        case ds of+          [] -> return [PackageBuildImpossible NoDesc]+          -- No .cabal file.+          [d] -> do+            bc <- bomf ops d+            return (catMaybes [bc, noMatch d])+          -- BOM + no matching .cabal checks.+          _ -> return [PackageBuildImpossible $ MultiDesc ds]+    )+  where+    -- Multiple .cabal files.++    bomf+      :: Monad m+      => CheckPackageContentOps m+      -> FilePath+      -> m (Maybe PackageCheck)+    bomf wops wfp = do+      b <- BS.isPrefixOf bomUtf8 <$> getFileContents wops wfp+      if b+        then (return . Just) (PackageDistInexcusable $ BOMStart wfp)+        else return Nothing++    bomUtf8 :: BS.ByteString+    bomUtf8 = BS.pack [0xef, 0xbb, 0xbf] -- U+FEFF encoded as UTF8+    noMatch :: FilePath -> Maybe PackageCheck+    noMatch wd =+      let expd = unPackageName pn <.> "cabal"+       in if takeFileName wd /= expd+            then Just (PackageDistInexcusable $ NotPackageName wd expd)+            else Nothing++checkLicFileExist+  :: Monad m+  => SymbolicPath PackageDir LicenseFile+  -> CheckM m ()+checkLicFileExist sp = do+  let fp = getSymbolicPath sp+  checkPkg+    (\ops -> not <$> doesFileExist ops fp)+    (PackageBuildWarning $ UnknownFile "license-file" sp)++checkConfigureExists :: Monad m => BuildType -> CheckM m ()+checkConfigureExists Configure =+  checkPkg+    (\ops -> not <$> doesFileExist ops "configure")+    (PackageBuildWarning MissingConfigureScript)+checkConfigureExists _ = return ()++checkSetupExists :: Monad m => BuildType -> CheckM m ()+checkSetupExists Simple = return ()+checkSetupExists _ =+  checkPkg+    ( \ops -> do+        ba <- doesFileExist ops "Setup.hs"+        bb <- doesFileExist ops "Setup.lhs"+        return (not $ ba || bb)+    )+    (PackageDistInexcusable MissingSetupFile)++-- The following functions are similar to 'CheckPackageContentOps m' ones,+-- but, as they inspect the files included in the package, but are primarily+-- looking for files in the working tree that may have been missed or other+-- similar problems that can only be detected pre-distribution.+--+-- Because Hackage necessarily checks the uploaded tarball, it is too late to+-- check these on the server; these checks only make sense in the development+-- and package-creation environment.+-- This most likely means we need to use IO, but a dictionary+-- 'CheckPreDistributionOps m' is provided in case in the future such+-- information can come from somewhere else (e.g. VCS filesystem).+--+-- Note: this really shouldn't return any 'Inexcusable' warnings,+-- because that will make us say that Hackage would reject the package.+-- But, because Hackage doesn't yet run these tests, that will be a lie!++checkGlobFile+  :: Monad m+  => CabalSpecVersion+  -> FilePath -- Glob pattern.+  -> FilePath -- Folder to check.+  -> CabalField -- .cabal field we are checking.+  -> CheckM m ()+checkGlobFile cv ddir title fp = do+  let adjDdir = if null ddir then "." else ddir+      dir+        | title == "data-files" = adjDdir+        | otherwise = "."++  case parseFileGlob cv fp of+    -- We just skip over parse errors here; they're reported elsewhere.+    Left _ -> return ()+    Right parsedGlob -> do+      liftInt ciPreDistOps $ \po -> do+        rs <- runDirFileGlobM po dir parsedGlob+        return $ checkGlobResult title fp rs++-- | Checks for matchless globs and too strict matching (<2.4 spec).+checkGlobResult+  :: CabalField -- .cabal field we are checking+  -> FilePath -- Glob pattern (to show the user+  -- which pattern is the offending+  -- one).+  -> [GlobResult FilePath] -- List of glob results.+  -> [PackageCheck]+checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)+  where+    dirCheck+      | all (not . withoutNoMatchesWarning) rs =+          [PackageDistSuspiciousWarn $ GlobNoMatch title fp]+      | otherwise = []++    -- If there's a missing directory in play, since globs in Cabal packages+    -- don't (currently) support disjunction, that will always mean there are+    -- no matches. The no matches error in this case is strictly less+    -- informative than the missing directory error.+    withoutNoMatchesWarning (GlobMatch _) = True+    withoutNoMatchesWarning (GlobWarnMultiDot _) = False+    withoutNoMatchesWarning (GlobMissingDirectory _) = True+    withoutNoMatchesWarning (GlobMatchesDirectory _) = True++    getWarning :: GlobResult FilePath -> Maybe PackageCheck+    getWarning (GlobMatch _) = Nothing+    -- Before Cabal 2.4, the extensions of globs had to match the file+    -- exactly. This has been relaxed in 2.4 to allow matching only the+    -- suffix. This warning detects when pre-2.4 package descriptions+    -- are omitting files purely because of the stricter check.+    getWarning (GlobWarnMultiDot file) =+      Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file)+    getWarning (GlobMissingDirectory dir) =+      Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir)+    -- GlobMatchesDirectory is handled elsewhere if relevant;+    -- we can discard it here.+    getWarning (GlobMatchesDirectory _) = Nothing++-- ------------------------------------------------------------+-- Other exports+-- ------------------------------------------------------------++-- | Wraps `ParseWarning` into `PackageCheck`.+wrapParseWarning :: FilePath -> PWarning -> PackageCheck+wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw)++-- TODO: as Jul 2022 there is no severity indication attached PWarnType.+--       Once that is added, we can output something more appropriate+--       than PackageDistSuspicious for every parse warning.+--       (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs)++-- ------------------------------------------------------------+-- Ancillaries+-- ------------------------------------------------------------++-- Gets a list of dependencies from a Library target to pass to PVP related+-- functions. We are not doing checks here: this is not imprecise, as the+-- library itself *will* be checked for PVP errors.+-- Same for branch merging,+-- each of those branch will be checked one by one.+extractAssocDeps+  :: UnqualComponentName -- Name of the target library+  -> CondTree ConfVar [Dependency] Library+  -> AssocDep+extractAssocDeps n ct =+  let a = ignoreConditions ct+   in -- Merging is fine here, remember the specific+      -- library dependencies will be checked branch+      -- by branch.+      (n, snd a)++-- | August 2022: this function is an oddity due to the historical+-- GenericPackageDescription/PackageDescription split (check+-- Distribution.Types.PackageDescription for a description of the relationship+-- between GPD and PD.+-- It is only maintained not to break interface, should be deprecated in the+-- future in favour of `checkPackage` when PD and GPD are refactored sensibly.+pd2gpd :: PackageDescription -> GenericPackageDescription+pd2gpd pd = gpd+  where+    gpd :: GenericPackageDescription+    gpd =+      emptyGenericPackageDescription+        { packageDescription = pd+        , condLibrary = fmap t2c (library pd)+        , condSubLibraries = map (t2cName ln id) (subLibraries pd)+        , condForeignLibs =+            map+              (t2cName foreignLibName id)+              (foreignLibs pd)+        , condExecutables =+            map+              (t2cName exeName id)+              (executables pd)+        , condTestSuites =+            map+              (t2cName testName remTest)+              (testSuites pd)+        , condBenchmarks =+            map+              (t2cName benchmarkName remBench)+              (benchmarks pd)+        }++    -- From target to simple, unconditional CondTree.+    t2c :: a -> CondTree ConfVar [Dependency] a+    t2c a = CondNode a [] []++    -- From named target to unconditional CondTree. Notice we have+    -- a function to extract the name *and* a function to modify+    -- the target. This is needed for 'initTargetAnnotation' to work+    -- properly and to contain all the quirks inside 'pd2gpd'.+    t2cName+      :: (a -> UnqualComponentName)+      -> (a -> a)+      -> a+      -> (UnqualComponentName, CondTree ConfVar [Dependency] a)+    t2cName nf mf a = (nf a, t2c . mf $ a)++    ln :: Library -> UnqualComponentName+    ln wl = case libName wl of+      (LSubLibName u) -> u+      LMainLibName -> mkUnqualComponentName "main-library"++    remTest :: TestSuite -> TestSuite+    remTest t = t{testName = mempty}++    remBench :: Benchmark -> Benchmark+    remBench b = b{benchmarkName = mempty}++-- checkMissingDocs will check that we don’t have an interesting file+-- (changes.txt, Changelog.md, NEWS, etc.) in our work-tree which is not+-- present in our .cabal file.+checkMissingDocs+  :: Monad m+  => [Glob] -- data-files globs.+  -> [Glob] -- extra-source-files globs.+  -> [Glob] -- extra-doc-files globs.+  -> CheckM m ()+checkMissingDocs dgs esgs edgs = do+  extraDocSupport <- (>= CabalSpecV1_18) <$> asksCM ccSpecVersion++  -- Everything in this block uses CheckPreDistributionOps interface.+  liftInt+    ciPreDistOps+    ( \ops -> do+        -- 1. Get root files, see if they are interesting to us.+        rootContents <- getDirectoryContentsM ops "."+        -- Recall getDirectoryContentsM arg is relative to root path.+        let des = filter isDesirableExtraDocFile rootContents++        -- 2. Realise Globs.+        let realGlob t =+              concatMap globMatches+                <$> mapM (runDirFileGlobM ops "") t+        rgs <- realGlob dgs+        res <- realGlob esgs+        red <- realGlob edgs++        -- 3. Check if anything in 1. is missing in 2.+        let mcs = checkDoc extraDocSupport des (rgs ++ res ++ red)++        -- 4. Check if files are present but in the wrong field.+        let pcsData = checkDocMove extraDocSupport "data-files" des rgs+            pcsSource =+              if extraDocSupport+                then+                  checkDocMove+                    extraDocSupport+                    "extra-source-files"+                    des+                    res+                else []+            pcs = pcsData ++ pcsSource++        return (mcs ++ pcs)+    )+  where+    checkDoc+      :: Bool -- Cabal spec ≥ 1.18?+      -> [FilePath] -- Desirables.+      -> [FilePath] -- Actuals.+      -> [PackageCheck]+    checkDoc b ds as =+      let fds = map ("." </>) $ filter (flip notElem as) ds+       in if null fds+            then []+            else+              [ PackageDistSuspiciousWarn $+                  MissingExpectedDocFiles b fds+              ]++    checkDocMove+      :: Bool -- Cabal spec ≥ 1.18?+      -> CabalField -- Name of the field.+      -> [FilePath] -- Desirables.+      -> [FilePath] -- Actuals.+      -> [PackageCheck]+    checkDocMove b field ds as =+      let fds = filter (flip elem as) ds+       in if null fds+            then []+            else+              [ PackageDistSuspiciousWarn $+                  WrongFieldForExpectedDocFiles b field fds+              ]++-- Predicate for desirable documentation file on Hackage server.+isDesirableExtraDocFile :: FilePath -> Bool+isDesirableExtraDocFile path =+  basename `elem` desirableChangeLog+    && ext `elem` desirableChangeLogExtensions+  where+    (basename, ext) = splitExtension (map toLower path)++    -- Changelog patterns (basenames & extensions)+    -- Source: hackage-server/src/Distribution/Server/Packages/ChangeLog.hs+    desirableChangeLog = ["news", "changelog", "change_log", "changes"]+    desirableChangeLogExtensions = ["", ".txt", ".md", ".markdown", ".rst"]++-- [TODO] Check readme. Observations:+--        • Readme is not necessary if package description is good.+--        • Some readmes exists only for repository browsing.+--        • There is currently no reliable way to check what a good+--          description is; there will be complains if the criterion+--          is based on the length or number of words (can of worms).+-- -- Readme patterns+-- -- Source: hackage-server/src/Distribution/Server/Packages/Readme.hs+-- desirableReadme = ["readme"]++-- Remove duplicates from list.+dups :: Ord a => [a] -> [a]+dups xs = [x | (x : _ : _) <- group (sort xs)]