Unverified Commit bd5e3f4f authored by Emily Pillmore's avatar Emily Pillmore 🌊 Committed by GitHub
Browse files

Merge pull request #7492 from peterbecich/file-monitor-type-annotations

some type annotations
parents 1042ae49 46299da7
......@@ -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,7 +463,7 @@ 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
......@@ -467,6 +471,7 @@ checkFileMonitorChanged
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))
......@@ -474,6 +479,7 @@ checkFileMonitorChanged
= 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
......
......@@ -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
......
......@@ -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))
......
......@@ -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,6 +967,7 @@ 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"
......@@ -954,6 +975,7 @@ printPlan verbosity
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,11 +1098,15 @@ 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])
......@@ -1083,11 +1114,13 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
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,6 +1142,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
then renderDependencyOf (installedUnitId pkg)
else ""
renderFailureExtraDetail :: BuildFailureReason -> String
renderFailureExtraDetail (ConfigureFailed _) =
" The failure occurred during the configure step."
renderFailureExtraDetail (InstallFailed _) =
......@@ -1116,6 +1150,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
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
......
......@@ -225,9 +225,11 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
, "subdir" J..= fmap J.String srpSubdir
]
dist_dir :: FilePath
dist_dir = distBuildDirectory distDirLayout
(elabDistDirParams elaboratedSharedConfig elab)
bin_file :: ComponentDeps.Component -> [J.Pair]
bin_file c = case c of
ComponentDeps.ComponentExe s -> bin_file' s
ComponentDeps.ComponentTest s -> bin_file' s
......@@ -241,6 +243,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat
else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat
flib_file' :: (Pretty a, Show a) => a -> [J.Pair]
flib_file' s =
["bin-file" J..= J.String bin]
where
......@@ -580,6 +583,8 @@ postBuildProjectStatus plan previousPackagesUpToDate
InstallPlan.Configured srcpkg -> elabLibDeps srcpkg
InstallPlan.Installed srcpkg -> elabLibDeps srcpkg
]
elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId]
elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies
-- Was a build was attempted for this package?
......@@ -599,11 +604,13 @@ postBuildProjectStatus plan previousPackagesUpToDate
buildAttempted _ (Left BuildFailure {}) = True
buildAttempted _ (Right _) = True
lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool
lookupBuildStatusRequiresBuild def ipkgid =
case Map.lookup ipkgid pkgBuildStatus of
Nothing -> def -- Not in the plan subset we did the dry-run on
Just buildStatus -> buildStatusRequiresBuild buildStatus
packagesBuildLocal :: Set UnitId
packagesBuildLocal =
selectPlanPackageIdSet $ \pkg ->
case pkg of
......@@ -611,6 +618,7 @@ postBuildProjectStatus plan previousPackagesUpToDate
InstallPlan.Installed _ -> False
InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg
packagesBuildInplace :: Set UnitId
packagesBuildInplace =
selectPlanPackageIdSet $ \pkg ->
case pkg of
......@@ -618,7 +626,7 @@ postBuildProjectStatus plan previousPackagesUpToDate
InstallPlan.Installed _ -> False
InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg
== BuildInplaceOnly
packagesAlreadyInStore :: Set UnitId
packagesAlreadyInStore =
selectPlanPackageIdSet $ \pkg ->
case pkg of
......@@ -626,6 +634,10 @@ postBuildProjectStatus plan previousPackagesUpToDate
InstallPlan.Installed _ -> True
InstallPlan.Configured _ -> False
selectPlanPackageIdSet
:: (InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> Bool)
-> Set UnitId
selectPlanPackageIdSet p = Map.keysSet
. Map.filter p
$ InstallPlan.toMap plan
......@@ -902,6 +914,7 @@ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan =
([], pkgs) -> checkSamePackageDBs pkgs
(pkgs, _) -> checkSamePackageDBs pkgs
where
checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStack
checkSamePackageDBs pkgs =
case ordNub (map elabBuildPackageDBStack pkgs) of
[packageDbs] -> packageDbs
......@@ -914,10 +927,13 @@ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan =
-- this feature, e.g. write out multiple env files, one for each
-- compiler / project profile.
inplacePackages :: [ElaboratedConfiguredPackage]
inplacePackages =
[ srcpkg
| srcpkg <- sourcePackages
, elabBuildStyle srcpkg == BuildInplaceOnly ]
sourcePackages :: [ElaboratedConfiguredPackage]
sourcePackages =
[ srcpkg
| pkg <- InstallPlan.toList elaboratedInstallPlan
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment