Merge pull request #6348 from commercialhaskell/fromPackage

Use `fromPackageId` and `fromPackageName` to shorten code
commercialhaskell · Nov 25, 2023 · 0c11fba · 0c11fba
2 parents fdb8333 + 2ae8467
commit 0c11fba
Show file tree

Hide file tree

Showing 14 changed files with 73 additions and 74 deletions.
diff --git a/.stan.toml b/.stan.toml
@@ -25,7 +25,7 @@
 # Infinite: base/isSuffixOf
 # Usage of the 'isSuffixOf' function that hangs on infinite lists
 [[ignore]]
-  id = "OBS-STAN-0102-luLR/n-523:30"
+  id = "OBS-STAN-0102-luLR/n-522:30"
 # ✦ Category:      #Infinite #List
 # ✦ File:          src\Stack\New.hs
 #  522 ┃
@@ -35,7 +35,7 @@
 # Infinite: base/isSuffixOf
 # Usage of the 'isSuffixOf' function that hangs on infinite lists
 [[ignore]]
-  id = "OBS-STAN-0102-luLR/n-523:65"
+  id = "OBS-STAN-0102-luLR/n-522:65"
 # ✦ Category:      #Infinite #List
 # ✦ File:          src\Stack\New.hs
 #  522 ┃
@@ -52,7 +52,7 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-fki0nd-1125:21"
+  id = "OBS-STAN-0203-fki0nd-1124:21"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 #  ✦ Category:      #AntiPattern
 #  ✦ File:          src\Stack\Build\Execute.hs
@@ -63,7 +63,7 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-fki0nd-2667:3"
+  id = "OBS-STAN-0203-fki0nd-2666:3"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\Execute.hs

diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs
@@ -755,10 +755,10 @@ addDep name packageInfo = do
                   cs
                 prettyWarnL
                   $ flow "No latest package revision found for"
-                  : style Current (fromString $ packageNameString name) <> ","
+                  : style Current (fromPackageName name) <> ","
                   : flow "dependency callstack:"
                   : mkNarrativeList Nothing False
-                      (map (fromString . packageNameString) cs' :: [StyleDoc])
+                      (map fromPackageName cs' :: [StyleDoc])
                 pure Nothing
               Just (_rev, cfKey, treeKey) ->
                 pure $ Just $
@@ -1125,7 +1125,7 @@ adrInRange pkgId name range adr = if adrVersion adr `withinRange` range
               ]
           pure True
         Just boundsIgnoredDeps -> do
-          let pkgName' = fromString $ packageNameString pkgName
+          let pkgName' = fromPackageName pkgName
               isBoundsIgnoreDep = pkgName `elem` boundsIgnoredDeps
               reason = if isBoundsIgnoreDep
                 then fillSep
@@ -1176,16 +1176,14 @@ adrInRange pkgId name range adr = if adrVersion adr `withinRange` range
             [ if isIgnoring
                 then "Ignoring"
                 else flow "Not ignoring"
-            ,    style
-                   Current
-                   (fromString $ packageNameString pkgName)
-              <> "'s"
+            , style Current (fromPackageName pkgName) <> "'s"
             , flow "bounds on"
-            , style Current (fromString $ packageNameString name)
+            , style Current (fromPackageName name)
             , parens (fromString . T.unpack $ versionRangeText range)
             , flow "and using"
-            , style Current (fromString . packageIdentifierString $
-                PackageIdentifier name (adrVersion adr)) <> "."
+            , style
+                Current
+                (fromPackageId $ PackageIdentifier name (adrVersion adr)) <> "."
             ]
        <> line
        <> fillSep
@@ -1406,7 +1404,7 @@ toolWarningText (ToolWarning (ExeName toolName) pkgName') = fillSep
   [ flow "No packages found in snapshot which provide a"
   , style PkgComponent (fromString $ show toolName)
   , flow "executable, which is a build-tool dependency of"
-  , style Current (fromString $ packageNameString pkgName')
+  , style Current (fromPackageName pkgName')
   ]
 
 -- | Is the given package/version combo defined in the snapshot or in the global

diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -317,7 +317,7 @@ displayTask task = fillSep $
   <> [ fillSep $
            "after:"
          : mkNarrativeList Nothing False
-             (map (fromString . packageIdentifierString) (Set.toList missing) :: [StyleDoc])
+             (map fromPackageId (Set.toList missing) :: [StyleDoc])
      | not $ Set.null missing
      ]
  where
@@ -848,8 +848,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
                     nowBuilding []    = ""
                     nowBuilding names = mconcat $
                         ": "
-                      : L.intersperse ", "
-                          (map (fromString . packageNameString) names)
+                      : L.intersperse ", " (map fromPackageName names)
                     progressFormat = boptsProgressBar eeBuildOpts
                     progressLine prev' total' =
                          "Progress "
@@ -1471,7 +1470,7 @@ withSingleContext
               (TTLocalMutable lp, C.Custom) | lpWanted lp ->
                 prettyWarnL
                   [ flow "Package"
-                  , fromString $ packageNameString $ packageName package
+                  , fromPackageName $ packageName package
                   , flow "uses a custom Cabal build, but does not use a \
                          \custom-setup stanza"
                   ]
@@ -1488,7 +1487,7 @@ withSingleContext
               Just customSetupDeps -> do
                 unless (Map.member (mkPackageName "Cabal") customSetupDeps) $
                   prettyWarnL
-                    [ fromString $ packageNameString $ packageName package
+                    [ fromPackageName $ packageName package
                     , flow "has a setup-depends field, but it does not mention \
                            \a Cabal dependency. This is likely to cause build \
                            \errors."
@@ -1504,13 +1503,13 @@ withSingleContext
                           prettyWarnL
                             [ flow "Found multiple installed packages for \
                                    \custom-setup dep:"
-                            , style Current (fromString $ packageNameString name) <> "."
+                            , style Current (fromPackageName name) <> "."
                             ]
                         pure ("-package-id=" ++ ghcPkgIdString (snd x), Just (fst x))
                       [] -> do
                         prettyWarnL
                           [ flow "Could not find custom-setup dep:"
-                          , style Current (fromString $ packageNameString name) <> "."
+                          , style Current (fromPackageName name) <> "."
                           ]
                         pure ("-package=" ++ packageNameString name, Nothing)
                 let depsArgs = map fst matchedDeps
@@ -1739,7 +1738,7 @@ singleBuild
         eres <- tryAny $ action KeepOpen
         case eres of
           Right () -> prettyWarnL
-            [ style Current (fromString $ packageNameString pname) <> ":"
+            [ style Current (fromPackageName pname) <> ":"
             , flow "unexpected Haddock success."
             ]
           Left _ -> pure ()
@@ -1874,7 +1873,7 @@ singleBuild
              ) $
           prettyInfoL
             [ flow "Building all executables for"
-            , style Current (fromString $ packageNameString $ packageName package)
+            , style Current (fromPackageName $ packageName package)
             , flow "once. After a successful build of all of them, only \
                    \specified executables will be rebuilt."
             ]
@@ -2782,7 +2781,7 @@ fulfillCuratorBuildExpectations pname mcurator enableTests _ defValue action
       case eres of
         Right res -> do
           prettyWarnL
-            [ style Current (fromString $ packageNameString pname) <> ":"
+            [ style Current (fromPackageName pname) <> ":"
             , flow "unexpected test build success."
             ]
           pure res
@@ -2793,7 +2792,7 @@ fulfillCuratorBuildExpectations pname mcurator _ enableBench defValue action
       case eres of
         Right res -> do
           prettyWarnL
-            [ style Current (fromString $ packageNameString pname) <> ":"
+            [ style Current (fromPackageName pname) <> ":"
             , flow "unexpected benchmark build success."
             ]
           pure res

diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs
@@ -302,7 +302,7 @@ resolveRawTarget sma allLocs (ri, rt) =
                          PkgComponent
                          (fromString $ T.unpack $ renderComponent nc)
                      , flow "of package"
-                     , style PkgComponent (fromString $ packageNameString pn)
+                     , style PkgComponent (fromPackageName pn)
                      ]
                  )
                  matches
@@ -313,7 +313,7 @@ resolveRawTarget sma allLocs (ri, rt) =
       Nothing -> pure $ Left $
         fillSep
           [ flow "Unknown local package:"
-          , style Target (fromString $ packageNameString name) <> "."
+          , style Target (fromPackageName name) <> "."
           ]
       Just pp -> do
         comps <- ppComponents pp
@@ -331,7 +331,7 @@ resolveRawTarget sma allLocs (ri, rt) =
                   [ "Component"
                   , style Target (fromString $ T.unpack $ renderComponent comp)
                   , flow "does not exist in package"
-                  , style Target (fromString $ packageNameString name) <> "."
+                  , style Target (fromPackageName name) <> "."
                   ]
           UnresolvedComponent comp ->
             case filter (isCompNamed comp) $ Set.toList comps of
@@ -340,7 +340,7 @@ resolveRawTarget sma allLocs (ri, rt) =
                   [ "Component"
                   , style Target (fromString $ T.unpack comp)
                   , flow "does not exist in package"
-                  , style Target (fromString $ packageNameString name) <> "."
+                  , style Target (fromPackageName name) <> "."
                   ]
               [x] -> Right ResolveResult
                 { rrName = name
@@ -354,7 +354,7 @@ resolveRawTarget sma allLocs (ri, rt) =
                   [ flow "Ambiguous component name"
                   , style Target (fromString $ T.unpack comp)
                   , flow "for package"
-                  , style Target (fromString $ packageNameString name)
+                  , style Target (fromPackageName name)
                   , flow "matches components:"
                   , fillSep $
                       mkNarrativeList (Just PkgComponent) False
@@ -387,7 +387,7 @@ resolveRawTarget sma allLocs (ri, rt) =
   go (RTPackageIdentifier ident@(PackageIdentifier name version))
     | Map.member name locals = pure $ Left $
         fillSep
-          [ style Target (fromString $ packageNameString name)
+          [ style Target (fromPackageName name)
           , flow "target has a specific version number, but it is a local \
                  \package. To avoid confusion, we will not install the \
                  \specified version or build the local one. To build the \
@@ -413,7 +413,7 @@ resolveRawTarget sma allLocs (ri, rt) =
             fillSep
               [ flow "Package with identifier was targeted on the command \
                      \line:"
-              , style Target (fromString $ packageIdentifierString ident) <> ","
+              , style Target (fromPackageId ident) <> ","
               , flow "but it was specified from a non-index location:"
               , flow $ T.unpack $ textDisplay loc' <> "."
               , flow "Recommendation: add the correctly desired version to \
@@ -509,7 +509,7 @@ combineResolveResults results = do
                     catMaybes mcomps
               | otherwise -> Left $ fillSep
                   [ flow "The package"
-                  , style Target $ fromString $ packageNameString name
+                  , style Target $ fromPackageName name
                   , flow "was specified in multiple, incompatible ways:"
                   , fillSep $
                       mkNarrativeList (Just Target) False

diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs
@@ -78,7 +78,7 @@ instance Pretty CoveragePrettyException where
     <> fillSep
          [ flow "Can't specify anything except test-suites as hpc report \
                 \targets"
-         , parens (style Target . fromString . packageNameString $ name)
+         , parens (style Target . fromPackageName $ name)
          , flow "is used with a non test-suite target."
          ]
   pretty NoTargetsOrTixSpecified =
@@ -91,7 +91,7 @@ instance Pretty CoveragePrettyException where
     <> line
     <> fillSep
          [ flow "Expected a local package, but"
-         , style Target . fromString . packageNameString $ name
+         , style Target . fromPackageName $ name
          , flow "is either an extra-dep or in the snapshot."
          ]
 

diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
@@ -421,7 +421,7 @@ getAllLocalTargets GhciOpts{..} targets0 mainIsTargets localMap = do
     then pure directlyWanted
     else do
       let extraList' =
-            map (fromString . packageNameString . fst) extraLoadDeps :: [StyleDoc]
+            map (fromPackageName . fst) extraLoadDeps :: [StyleDoc]
           extraList = mkNarrativeList (Just Current) False extraList'
       if ghciLoadLocalDeps
         then prettyInfo $
@@ -539,7 +539,7 @@ runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do
   prettyInfoL
     ( flow "Configuring GHCi with the following packages:"
     : mkNarrativeList (Just Current) False
-        (map (fromString . packageNameString . ghciPkgName) pkgs :: [StyleDoc])
+        (map (fromPackageName . ghciPkgName) pkgs :: [StyleDoc])
     )
   compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath
   let execGhci extras = do
@@ -733,7 +733,7 @@ figureOutMainFile bopts mainIsTargets targets0 packages =
   renderCandidate c@(pkgName, namedComponent, mainIs) =
     let candidateIndex =
           fromString . show . (+1) . fromMaybe 0 . L.elemIndex c
-        pkgNameText = fromString $ packageNameString pkgName
+        pkgNameText = fromPackageName pkgName
     in  hang 4
           $  fill 4 ( candidateIndex candidates <> ".")
           <> fillSep
@@ -1102,7 +1102,7 @@ targetWarnings localTargets nonLocalTargets mfileTargets = do
     prettyWarnL
       [ flow "Some targets"
       , parens $ fillSep $ punctuate "," $ map
-          (style Good . fromString . packageNameString)
+          (style Good . fromPackageName)
           nonLocalTargets
       , flow "are not local packages, and so cannot be directly loaded. In \
              \future versions of Stack, this might be supported - see"

diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs
@@ -558,8 +558,7 @@ getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do
                 prettyWarn
                   (  flow "Ignoring the following packages:"
                   <> line
-                  <> bulletedList
-                       (map (fromString . packageNameString) ignored)
+                  <> bulletedList (map fromPackageName ignored)
                   )
               else
                 prettyWarnL

diff --git a/src/Stack/List.hs b/src/Stack/List.hs
@@ -57,7 +57,7 @@ listPackages mSnapshot input = do
   case errs1 ++ errs2 of
     [] -> pure ()
     errs -> prettyThrowM $ CouldNotParsePackageSelectors errs
-  mapM_ (Lazy.putStrLn . fromString . packageIdentifierString) locs
+  mapM_ (Lazy.putStrLn . fromPackageId) locs
  where
   toLoc | Just snapshot <- mSnapshot = toLocSnapshot snapshot
         | otherwise = toLocNoSnapshot
@@ -87,14 +87,14 @@ listPackages mSnapshot input = do
         candidates <- getHackageTypoCorrections name
         pure $ Left $ fillSep
           [ flow "Could not find package"
-          , style Current (fromString $ packageNameString name)
+          , style Current (fromPackageName name)
           , flow "on Hackage."
           , if null candidates
               then mempty
               else fillSep $
                   flow "Perhaps you meant one of:"
                 : mkNarrativeList (Just Good) False
-                    (map (fromString . packageNameString) candidates :: [StyleDoc])
+                    (map fromPackageName candidates :: [StyleDoc])
           ]
       Just loc -> pure $ Right (packageLocationIdent loc)
 
@@ -107,7 +107,7 @@ listPackages mSnapshot input = do
       Nothing ->
         pure $ Left $ fillSep
           [ flow "Package does not appear in snapshot:"
-          , style Current (fromString $ packageNameString name) <> "."
+          , style Current (fromPackageName name) <> "."
           ]
       Just sp -> do
         loc <- cplComplete <$> completePackageLocation (rspLocation sp)

diff --git a/src/Stack/New.hs b/src/Stack/New.hs
@@ -182,11 +182,10 @@ instance Pretty NewPrettyException where
     <> fillSep
          ( flow "The names blocked by Stack are:"
          : mkNarrativeList Nothing False
-             (map toStyleDoc (L.sort $ S.toList wiredInPackages))
+             (map fromPackageName sortedWiredInPackages :: [StyleDoc])
          )
    where
-    toStyleDoc :: PackageName -> StyleDoc
-    toStyleDoc = fromString . packageNameString
+    sortedWiredInPackages = L.sort $ S.toList wiredInPackages
   pretty (AttemptedOverwrites name fps) =
     "[S-3113]"
     <> line

diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs
@@ -52,6 +52,8 @@ module Stack.Prelude
   , encloseSep
   , fill
   , fillSep
+  , fromPackageId
+  , fromPackageName
   , flow
   , hang
   , hcat
@@ -362,3 +364,11 @@ putUtf8Builder = putBuilder . getUtf8Builder
 -- | Write a 'Builder' to the standard output stream.
 putBuilder :: MonadIO m => Builder -> m ()
 putBuilder = hPutBuilder stdout
+
+-- | Convert a package identifier to a value of a string-like type.
+fromPackageId :: IsString a => PackageIdentifier -> a
+fromPackageId = fromString . packageIdentifierString
+
+-- | Convert a package name to a value of a string-like type.
+fromPackageName :: IsString a => PackageName -> a
+fromPackageName = fromString . packageNameString
diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs
@@ -565,7 +565,7 @@ checkPackageInExtractedTarball pkgDir = do
   let pkgDesc = resolvePackageDescription config gpd
   prettyInfoL
     [ flow "Checking package"
-    , style Current (fromString $ packageNameString name)
+    , style Current (fromPackageName name)
     , flow "for common mistakes."
     ]
   let pkgChecks =