From 0fb13b012ba96b0d51b7c1f4ed61f38b6cfdfdcc Mon Sep 17 00:00:00 2001
From: Peter Becich <peter@simspace.com>
Date: Sun, 22 Aug 2021 21:35:10 -1000
Subject: [PATCH] more type annotations
---
.../src/Distribution/Client/Targets.hs | 7 +++++++
.../src/Distribution/Client/Upload.hs | 21 +++++++++++++------
.../src/Distribution/Client/Utils.hs | 12 +++++++----
cabal-install/src/Distribution/Client/VCS.hs | 3 +++
.../src/Distribution/Client/World.hs | 6 ++++--
5 files changed, 37 insertions(+), 12 deletions(-)
diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs
index 8cc4cdaf68..89aaf1fdab 100644
--- a/cabal-install/src/Distribution/Client/Targets.hs
+++ b/cabal-install/src/Distribution/Client/Targets.hs
@@ -195,6 +195,7 @@ readUserTarget targetstr =
Just target -> return target
Nothing -> return (Left (UserTargetUnrecognised targetstr))
where
+ testFileTargets :: FilePath -> IO (Maybe (Either UserTargetProblem UserTarget))
testFileTargets filename = do
isDir <- doesDirectoryExist filename
isFile <- doesFileExist filename
@@ -221,6 +222,7 @@ readUserTarget targetstr =
= Nothing
return result
+ testUriTargets :: String -> Maybe (Either UserTargetProblem UserTarget)
testUriTargets str =
case parseAbsoluteURI str of
Just uri@URI {
@@ -414,6 +416,7 @@ readPackageTarget :: Verbosity
-> IO (PackageTarget UnresolvedSourcePackage)
readPackageTarget verbosity = traverse modifyLocation
where
+ modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage
modifyLocation location = case location of
LocalUnpackedPackage dir -> do
@@ -444,6 +447,7 @@ readPackageTarget verbosity = traverse modifyLocation
--
-- When that is corrected, this will also need to be fixed.
+ readTarballPackageTarget :: ResolvedPkgLoc -> FilePath -> FilePath -> IO UnresolvedSourcePackage
readTarballPackageTarget location tarballFile tarballOriginalLoc = do
(filename, content) <- extractTarballPackageCabalFile
tarballFile tarballOriginalLoc
@@ -471,6 +475,8 @@ readPackageTarget verbosity = traverse modifyLocation
where
formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg
+ accumEntryMap :: Tar.Entries Tar.FormatError
+ -> Either (Tar.FormatError, Map Tar.TarPath Tar.Entry) (Map Tar.TarPath Tar.Entry)
accumEntryMap = Tar.foldlEntries
(\m e -> Map.insert (Tar.entryTarPath e) e m)
Map.empty
@@ -486,6 +492,7 @@ readPackageTarget verbosity = traverse modifyLocation
noCabalFile = "No cabal file found"
multipleCabalFiles = "Multiple cabal files found"
+ isCabalFile :: Tar.Entry -> Bool
isCabalFile e = case splitPath (Tar.entryPath e) of
[ _dir, file] -> takeExtension file == ".cabal"
[".", _dir, file] -> takeExtension file == ".cabal"
diff --git a/cabal-install/src/Distribution/Client/Upload.hs b/cabal-install/src/Distribution/Client/Upload.hs
index 17a25cd2ad..e156580d07 100644
--- a/cabal-install/src/Distribution/Client/Upload.hs
+++ b/cabal-install/src/Distribution/Client/Upload.hs
@@ -4,7 +4,7 @@ import Distribution.Client.Compat.Prelude
import qualified Prelude as Unsafe (tail, head, read)
import Distribution.Client.Types.Credentials ( Username(..), Password(..) )
-import Distribution.Client.Types.Repo (RemoteRepo(..), maybeRepoRemote)
+import Distribution.Client.Types.Repo (Repo, RemoteRepo(..), maybeRepoRemote)
import Distribution.Client.Types.RepoName (unRepoName)
import Distribution.Client.HttpUtils
( HttpTransport(..), remoteRepoTryUpgradeToHttps )
@@ -44,15 +44,19 @@ upload :: Verbosity -> RepoContext
-> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]
-> IO ()
upload verbosity repoCtxt mUsername mPassword isCandidate paths = do
- let repos = repoContextRepos repoCtxt
+ let repos :: [Repo]
+ repos = repoContextRepos repoCtxt
transport <- repoContextGetTransport repoCtxt
targetRepo <-
case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of
[] -> die' verbosity "Cannot upload. No remote repositories are configured."
(r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))
- let targetRepoURI = remoteRepoURI targetRepo
+ let targetRepoURI :: URI
+ targetRepoURI = remoteRepoURI targetRepo
+ domain :: String
domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI
rootIfEmpty x = if null x then "/" else x
+ uploadURI :: URI
uploadURI = targetRepoURI {
uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</>
case isCandidate of
@@ -167,16 +171,20 @@ promptPassword domain = do
report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO ()
report verbosity repoCtxt mUsername mPassword = do
- let repos = repoContextRepos repoCtxt
+ let repos :: [Repo]
+ repos = repoContextRepos repoCtxt
+ remoteRepos :: [RemoteRepo]
remoteRepos = mapMaybe maybeRepoRemote repos
for_ remoteRepos $ \remoteRepo -> do
let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo)
Username username <- maybe (promptUsername domain) return mUsername
Password password <- maybe (promptPassword domain) return mPassword
- let auth = (username, password)
+ let auth :: (String, String)
+ auth = (username, password)
dotCabal <- getCabalDir
- let srcDir = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)
+ let srcDir :: FilePath
+ srcDir = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)
-- We don't want to bomb out just because we haven't built any packages
-- from this repo yet.
srcExists <- doesDirectoryExist srcDir
@@ -208,6 +216,7 @@ handlePackage transport verbosity uri packageUri auth isCandidate path =
++ err
exitFailure
where
+ okMessage :: IsCandidate -> String
okMessage IsCandidate =
"Package successfully uploaded as candidate. "
++ "You can now preview the result at '" ++ show packageUri
diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs
index f9021803c7..64e715c86a 100644
--- a/cabal-install/src/Distribution/Client/Utils.hs
+++ b/cabal-install/src/Distribution/Client/Utils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ForeignFunctionInterface, CPP #-}
+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-}
module Distribution.Client.Utils
( MergeResult(..)
@@ -76,9 +76,10 @@ import qualified System.IO.Error as IOError
-- | Generic merging utility. For sorted input lists this is a full outer join.
--
-mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
+mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy cmp = merge
where
+ merge :: [a] -> [b] -> [MergeResult a b]
merge [] ys = [ OnlyInRight y | y <- ys]
merge xs [] = [ OnlyInLeft x | x <- xs]
merge (x:xs) (y:ys) =
@@ -92,9 +93,10 @@ data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b
duplicates :: Ord a => [a] -> [[a]]
duplicates = duplicatesBy compare
-duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]
+duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [[a]]
duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
where
+ eq :: a -> a -> Bool
eq a b = case cmp a b of
EQ -> True
_ -> False
@@ -175,7 +177,9 @@ withEnvOverrides overrides m = do
withExtraPathEnv :: [FilePath] -> IO a -> IO a
withExtraPathEnv paths m = do
oldPathSplit <- getSearchPath
- let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)
+ let newPath :: String
+ newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)
+ oldPath :: String
oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit
-- TODO: This is a horrible hack to work around the fact that
-- setEnv can't take empty values as an argument
diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs
index 683fb1e726..f13b02dec9 100644
--- a/cabal-install/src/Distribution/Client/VCS.hs
+++ b/cabal-install/src/Distribution/Client/VCS.hs
@@ -157,6 +157,9 @@ validateSourceRepos rs =
(problems@(_:_), _) -> Left problems
([], vcss) -> Right vcss
where
+ validateSourceRepo' :: SourceRepositoryPackage f
+ -> Either (SourceRepositoryPackage f, SourceRepoProblem)
+ (SourceRepositoryPackage f, String, RepoType, VCS Program)
validateSourceRepo' r = either (Left . (,) r) Right
(validateSourceRepo r)
diff --git a/cabal-install/src/Distribution/Client/World.hs b/cabal-install/src/Distribution/Client/World.hs
index a24a663dfc..49d530fabf 100644
--- a/cabal-install/src/Distribution/Client/World.hs
+++ b/cabal-install/src/Distribution/Client/World.hs
@@ -35,7 +35,7 @@ import Distribution.Client.Compat.Prelude hiding (getContents)
import Distribution.Types.Dependency
import Distribution.Types.Flag
- ( FlagAssignment, unFlagAssignment
+ ( FlagAssignment, FlagName, unFlagAssignment
, unFlagName, parsecFlagAssignmentNonEmpty )
import Distribution.Simple.Utils
( die', info, chattyTry, writeFileAtomic )
@@ -104,7 +104,8 @@ modifyWorld f verbosity world pkgs =
getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo]
getContents verbosity world = do
content <- safelyReadFile world
- let result = map simpleParsec (lines $ B.unpack content)
+ let result :: [Maybe WorldPkgInfo]
+ result = map simpleParsec (lines $ B.unpack content)
case sequence result of
Nothing -> die' verbosity "Could not parse world file."
Just xs -> return xs
@@ -122,6 +123,7 @@ instance Pretty WorldPkgInfo where
dispFlags [] = Disp.empty
dispFlags fs = Disp.text "--flags="
<<>> Disp.doubleQuotes (flagAssToDoc fs)
+ flagAssToDoc :: [(FlagName, Bool)] -> Disp.Doc
flagAssToDoc = foldr (\(fname,val) flagAssDoc ->
(if not val then Disp.char '-'
else Disp.char '+')
--
GitLab