Merge branch 'master' into master

haskell · Aug 7, 2021 · 6c0e5c4 · 6c0e5c4
2 parents 412d525 + bd5e3f4
commit 6c0e5c4
Show file tree

Hide file tree

Showing 6 changed files with 84 additions and 20 deletions.
diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving,
              NamedFieldPuns, BangPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- | An abstraction to help with re-running actions when files or other
 -- input values they depend on have changed.
@@ -280,12 +281,13 @@ instance Structured MonitorStateGlobRel
 --
 reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath]
 reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =
-    map getSinglePath singlePaths
- ++ map getGlobPath globPaths
+  map getSinglePath singlePaths ++ map getGlobPath globPaths
   where
+    getSinglePath :: MonitorStateFile -> MonitorFilePath
     getSinglePath (MonitorStateFile kindfile kinddir filepath _) =
       MonitorFile kindfile kinddir filepath
 
+    getGlobPath :: MonitorStateGlob -> MonitorFilePath
     getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =
       MonitorFileGlob kindfile kinddir $ FilePathGlob root $
         case gstate of
@@ -416,7 +418,7 @@ data MonitorChangedReason a =
 -- See 'FileMonitor' for a full explanation.
 --
 checkFileMonitorChanged
-  :: (Binary a, Structured a, Binary b, Structured b)
+  :: forall a b. (Binary a, Structured a, Binary b, Structured b)
   => FileMonitor a b            -- ^ cache file path
   -> FilePath                   -- ^ root directory
   -> a                          -- ^ guard or key value
@@ -437,6 +439,7 @@ checkFileMonitorChanged
                  checkStatusCache
 
   where
+    checkStatusCache :: (MonitorStateFileSet, a, b) -> IO (MonitorChanged a b)
     checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do
         change <- checkForChanges
         case change of
@@ -448,6 +451,7 @@ checkFileMonitorChanged
         -- if we return MonitoredValueChanged that only the value changed.
         -- We do that by checkin for file changes first. Otherwise it makes
         -- more sense to do the cheaper test first.
+        checkForChanges :: IO (Maybe (MonitorChangedReason a))
         checkForChanges
           | fileMonitorCheckIfOnlyValueChanged
           = checkFileChange cachedFileStatus cachedKey cachedResult
@@ -459,21 +463,23 @@ checkFileMonitorChanged
               `mplusMaybeT`
             checkFileChange cachedFileStatus cachedKey cachedResult
 
-    mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
+    mplusMaybeT :: Monad m => m (Maybe a1) -> m (Maybe a1) -> m (Maybe a1)
     mplusMaybeT ma mb = do
       mx <- ma
       case mx of
         Nothing -> mb
         Just x  -> return (Just x)
 
     -- Check if the guard value has changed
+    checkValueChange :: a -> IO (Maybe (MonitorChangedReason a))
     checkValueChange cachedKey
       | not (fileMonitorKeyValid currentKey cachedKey)
       = return (Just (MonitoredValueChanged cachedKey))
       | otherwise
       = return Nothing
 
     -- Check if any file has changed
+    checkFileChange :: MonitorStateFileSet -> a -> b -> IO (Maybe (MonitorChangedReason a))
     checkFileChange cachedFileStatus cachedKey cachedResult = do
       res <- probeFileSystem root cachedFileStatus
       case res of
@@ -994,16 +1000,19 @@ readCacheFileHashes monitor =
                     collectAllFileHashes singlePaths
         `Map.union` collectAllGlobHashes globPaths
 
+    collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, Hash)
     collectAllFileHashes singlePaths =
       Map.fromList [ (fpath, (mtime, hash))
                    | MonitorStateFile _ _ fpath
                        (MonitorStateFileHashed mtime hash) <- singlePaths ]
 
+    collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, Hash)
     collectAllGlobHashes globPaths =
       Map.fromList [ (fpath, (mtime, hash))
                    | MonitorStateGlob _ _ _ gstate <- globPaths
                    , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ]
 
+    collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, Hash))]
     collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =
       [ res
       | (subdir, fstate) <- entries

diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -101,7 +101,7 @@ import qualified Data.ByteString.Lazy as LBS
 import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)
 import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
 import System.FilePath   (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
-import System.IO         (IOMode (AppendMode), withFile)
+import System.IO         (IOMode (AppendMode), Handle, withFile)
 
 import Distribution.Compat.Directory (listDirectory)
 
@@ -689,6 +689,7 @@ rebuildTarget verbosity
           --TODO: [nice to have] git/darcs repos etc
 
 
+    unpackTarballPhase :: FilePath -> IO BuildResult
     unpackTarballPhase tarball =
         withTarballLocalDirectory
           verbosity distDirLayout tarball
@@ -706,6 +707,7 @@ rebuildTarget verbosity
     -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages
     -- would only start from download or unpack phases.
     --
+    rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult
     rebuildPhase buildStatus srcdir =
         assert (elabBuildStyle pkg == BuildInplaceOnly) $
 
@@ -714,6 +716,7 @@ rebuildTarget verbosity
         builddir = distBuildDirectory
                    (elabDistDirParams sharedPackageConfig pkg)
 
+    buildAndInstall :: FilePath -> FilePath -> IO BuildResult
     buildAndInstall srcdir builddir =
         buildAndInstallUnpackedPackage
           verbosity distDirLayout storeDirLayout
@@ -725,6 +728,7 @@ rebuildTarget verbosity
         builddir' = makeRelative srcdir builddir
         --TODO: [nice to have] ^^ do this relative stuff better
 
+    buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult
     buildInplace buildStatus srcdir builddir =
         --TODO: [nice to have] use a relative build dir rather than absolute
         buildInplaceUnpackedPackage
@@ -760,6 +764,7 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
                             asyncFetchPackages verbosity repoctx
                                                pkgsToDownload body
   where
+    pkgsToDownload :: [PackageLocation (Maybe FilePath)]
     pkgsToDownload =
       ordNub $
       [ elabPkgSourceLocation elab
@@ -1143,6 +1148,7 @@ buildAndInstallUnpackedPackage verbosity
         Nothing        -> Nothing
         Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
 
+    initLogFile :: IO ()
     initLogFile =
       case mlogFile of
         Nothing      -> return ()
@@ -1151,6 +1157,7 @@ buildAndInstallUnpackedPackage verbosity
           exists <- doesFileExist logFile
           when exists $ removeFile logFile
 
+    withLogging :: (Maybe Handle -> IO r) -> IO r
     withLogging action =
       case mlogFile of
         Nothing      -> action Nothing
@@ -1162,6 +1169,7 @@ hasValidHaddockTargets ElaboratedConfiguredPackage{..}
   | not elabBuildHaddocks = False
   | otherwise             = any componentHasHaddocks components
   where
+    components :: [ComponentTarget]
     components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets
               ++ maybeToList elabReplTarget ++ elabHaddockTargets
 

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs
@@ -422,8 +422,10 @@ findProjectRoot mstartdir mprojectFile = do
 
     -- Search upwards. If we get to the users home dir or the filesystem root,
     -- then use the current dir
+    probe :: FilePath -> String -> IO (Either BadProjectRoot ProjectRoot)
     probe startdir homedir = go startdir
       where
+        go :: FilePath -> IO (Either BadProjectRoot ProjectRoot)
         go dir | isDrive dir || dir == homedir =
           case mprojectFile of
             Nothing   -> return (Right (ProjectRootImplicit startdir))

diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
@@ -136,6 +136,8 @@ import           Distribution.Compiler
                    ( CompilerFlavor(GHC) )
 import           Distribution.Types.ComponentName
                    ( componentNameString )
+import           Distribution.Types.InstalledPackageInfo
+                   ( InstalledPackageInfo )
 import           Distribution.Types.UnqualComponentName
                    ( UnqualComponentName, packageNameToUnqualComponentName )
 
@@ -424,6 +426,7 @@ runProjectPostBuildPhase verbosity
           projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared
           $ projectConfig
 
+        shouldWriteGhcEnvironment :: Bool
         shouldWriteGhcEnvironment =
           case fromFlagOrDefault NeverWriteGhcEnvironmentFiles
                writeGhcEnvFilesPolicy
@@ -669,37 +672,50 @@ type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)]
 availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes
 availableTargetIndexes installPlan = AvailableTargetIndexes{..}
   where
+    availableTargetsByPackageIdAndComponentName ::
+      Map (PackageId, ComponentName)
+          [AvailableTarget (UnitId, ComponentName)]
     availableTargetsByPackageIdAndComponentName =
       availableTargets installPlan
 
+    availableTargetsByPackageId ::
+      Map PackageId [AvailableTarget (UnitId, ComponentName)]
     availableTargetsByPackageId =
                   Map.mapKeysWith
                     (++) (\(pkgid, _cname) -> pkgid)
                     availableTargetsByPackageIdAndComponentName
       `Map.union` availableTargetsEmptyPackages
 
+    availableTargetsByPackageName ::
+      Map PackageName [AvailableTarget (UnitId, ComponentName)]
     availableTargetsByPackageName =
       Map.mapKeysWith
         (++) packageName
         availableTargetsByPackageId
 
+    availableTargetsByPackageNameAndComponentName ::
+      Map (PackageName, ComponentName)
+          [AvailableTarget (UnitId, ComponentName)]
     availableTargetsByPackageNameAndComponentName =
       Map.mapKeysWith
         (++) (\(pkgid, cname) -> (packageName pkgid, cname))
         availableTargetsByPackageIdAndComponentName
 
+    availableTargetsByPackageNameAndUnqualComponentName ::
+      Map (PackageName, UnqualComponentName)
+          [AvailableTarget (UnitId, ComponentName)]
     availableTargetsByPackageNameAndUnqualComponentName =
       Map.mapKeysWith
         (++) (\(pkgid, cname) -> let pname  = packageName pkgid
                                      cname' = unqualComponentName pname cname
                                   in (pname, cname'))
         availableTargetsByPackageIdAndComponentName
-     where
-       unqualComponentName ::
-         PackageName -> ComponentName -> UnqualComponentName
-       unqualComponentName pkgname =
-           fromMaybe (packageNameToUnqualComponentName pkgname)
-         . componentNameString
+      where
+        unqualComponentName ::
+          PackageName -> ComponentName -> UnqualComponentName
+        unqualComponentName pkgname =
+            fromMaybe (packageNameToUnqualComponentName pkgname)
+          . componentNameString
 
     -- Add in all the empty packages. These do not appear in the
     -- availableTargetsByComponent map, since that only contains
@@ -875,6 +891,7 @@ printPlan verbosity
         in "(" ++ showBuildStatus buildStatus ++ ")"
       ]
 
+    showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String
     showComp elab comp =
         maybe "custom" prettyShow (compComponentName comp) ++
         if Map.null (elabInstantiatedWith elab)
@@ -889,6 +906,7 @@ printPlan verbosity
     nonDefaultFlags elab =
       elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab
 
+    showTargets :: ElaboratedConfiguredPackage -> String
     showTargets elab
       | null (elabBuildTargets elab) = ""
       | otherwise
@@ -897,6 +915,7 @@ printPlan verbosity
                             | t <- elabBuildTargets elab ]
         ++ ")"
 
+    showConfigureFlags :: ElaboratedConfiguredPackage -> String
     showConfigureFlags elab =
         let fullConfigureFlags
               = setupHsConfigureFlags
@@ -930,6 +949,7 @@ printPlan verbosity
             (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))
             partialConfigureFlags
 
+    showBuildStatus :: BuildStatus -> String
     showBuildStatus status = case status of
       BuildStatusPreExisting -> "existing package"
       BuildStatusInstalled   -> "already installed"
@@ -947,13 +967,15 @@ printPlan verbosity
           BuildReasonEphemeralTargets -> "ephemeral targets"
       BuildStatusUpToDate {} -> "up to date" -- doesn't happen
 
+    showMonitorChangedReason :: MonitorChangedReason a -> String
     showMonitorChangedReason (MonitoredFileChanged file) =
       "file " ++ file ++ " changed"
     showMonitorChangedReason (MonitoredValueChanged _)   = "value changed"
     showMonitorChangedReason  MonitorFirstRun            = "first run"
     showMonitorChangedReason  MonitorCorruptCache        =
       "cannot read state cache"
 
+    showBuildProfile :: String
     showBuildProfile = "Build profile: " ++ unwords [
       "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared,
       "-O" ++  (case packageConfigOptimization of
@@ -1001,9 +1023,11 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
          | let mentionDepOf = verbosity <= normal
          , (pkg, failureClassification) <- failuresClassification ]
   where
+    failures :: [(UnitId, BuildFailure)]
     failures =  [ (pkgid, failure)
                 | (pkgid, Left failure) <- Map.toList buildOutcomes ]
 
+    failuresClassification :: [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
     failuresClassification =
       [ (pkg, classifyBuildFailure failure)
       | (pkgid, failure) <- failures
@@ -1014,6 +1038,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
            maybeToList (InstallPlan.lookup plan pkgid)
       ]
 
+    dieIfNotHaddockFailure :: Verbosity -> String -> IO ()
     dieIfNotHaddockFailure
       | currentCommand == HaddockCommand            = die'
       | all isHaddockFailure failuresClassification = warn
@@ -1050,6 +1075,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
     --    detail itself (e.g. ghc reporting errors on stdout)
     --  - then we do not report additional error detail or context.
     --
+    isSimpleCase :: Bool
     isSimpleCase
       | [(pkgid, failure)] <- failures
       , [pkg]              <- rootpkgs
@@ -1063,6 +1089,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
     -- NB: if the Setup script segfaulted or was interrupted,
     -- we should give more detailed information.  So only
     -- assume that exit code 1 is "pedestrian failure."
+    isFailureSelfExplanatory :: BuildFailureReason -> Bool
     isFailureSelfExplanatory (BuildFailed e)
       | Just (ExitFailure 1) <- fromException e = True
 
@@ -1071,23 +1098,29 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
 
     isFailureSelfExplanatory _                  = False
 
+    rootpkgs :: [ElaboratedConfiguredPackage]
     rootpkgs =
       [ pkg
       | InstallPlan.Configured pkg <- InstallPlan.toList plan
       , hasNoDependents pkg ]
 
+    ultimateDeps
+      :: UnitId
+      -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage]
     ultimateDeps pkgid =
         filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)
                (InstallPlan.reverseDependencyClosure plan [pkgid])
 
     hasNoDependents :: HasUnitId pkg => pkg -> Bool
     hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId
 
+    renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
     renderFailureDetail mentionDepOf pkg reason =
         renderFailureSummary mentionDepOf pkg reason ++ "."
      ++ renderFailureExtraDetail reason
      ++ maybe "" showException (buildFailureException reason)
 
+    renderFailureSummary :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
     renderFailureSummary mentionDepOf pkg reason =
         case reason of
           DownloadFailed  _ -> "Failed to download " ++ pkgstr
@@ -1109,13 +1142,15 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
                    then renderDependencyOf (installedUnitId pkg)
                    else ""
 
+    renderFailureExtraDetail :: BuildFailureReason -> String
     renderFailureExtraDetail (ConfigureFailed _) =
       " The failure occurred during the configure step."
     renderFailureExtraDetail (InstallFailed   _) =
       " The failure occurred during the final install step."
     renderFailureExtraDetail _                   =
       ""
 
+    renderDependencyOf :: UnitId -> String
     renderDependencyOf pkgid =
       case ultimateDeps pkgid of
         []         -> ""
@@ -1177,6 +1212,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
              ++ show e
 #endif
 
+    buildFailureException :: BuildFailureReason -> Maybe SomeException
     buildFailureException reason =
       case reason of
         DownloadFailed  e -> Just e
@@ -1230,6 +1266,7 @@ establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages
         mstoreDir = flagToMaybe projectConfigStoreDir
         cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir
 
+        buildSettings :: BuildTimeSettings
         buildSettings = resolveBuildTimeSettings
                           verbosity cabalDirLayout
                           projectConfig