diff --git a/.stan.toml b/.stan.toml index 8868811841..7a93dbfa89 100644 --- 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 index db38ae08b8..ed8af6c94b 100644 --- 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 index 4293a367e5..31bbc48c8f 100644 --- 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 index b7a592b78f..70aef0c7b1 100644 --- 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 index f051538f9f..548e9a0ede 100644 --- 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 index 38e194f3b3..97b0a2292d 100644 --- 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 index 9aa9c174f3..a7710cf5e7 100644 --- 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 index 9476a437bb..934f3be49f 100644 --- 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 index b37657a19d..70e95d6475 100644 --- 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 index dd750fdc59..a57e4aab32 100644 --- 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 index 9880b4fab8..e30ab49ade 100644 --- 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 = diff --git a/src/Stack/Types/Build/Exception.hs b/src/Stack/Types/Build/Exception.hs index b358c7f2f2..146321de6f 100644 --- a/src/Stack/Types/Build/Exception.hs +++ b/src/Stack/Types/Build/Exception.hs @@ -346,7 +346,7 @@ instance Pretty BuildPrettyException where go :: UnusedFlags -> StyleDoc go (UFNoPackage src name) = fillSep [ "Package" - , style Error (fromString $ packageNameString name) + , style Error (fromPackageName name) , flow "not found" , showFlagSrc src ] @@ -376,7 +376,7 @@ instance Pretty BuildPrettyException where name = packageNameString pname go (UFSnapshot name) = fillSep [ flow "Attempted to set flag on snapshot package" - , style Current (fromString $ packageNameString name) <> "," + , style Current (fromPackageName name) <> "," , flow "please add the package to" , style Shell "extra-deps" <> "." ] @@ -470,7 +470,7 @@ pprintExceptions exceptions stackYaml stackRoot isImplicitGlobal parentMap wante : flow "add these package names under" : style Shell "allow-newer-deps" <> ":" : mkNarrativeList (Just Shell) False - (map (fromString . packageNameString) (Set.elems pkgsWithMismatches) :: [StyleDoc]) + (map fromPackageName (Set.elems pkgsWithMismatches) :: [StyleDoc]) | not $ Set.null pkgsWithMismatches ] <> addExtraDepsRecommendations @@ -581,9 +581,7 @@ pprintExceptions exceptions stackYaml stackRoot isImplicitGlobal parentMap wante flow "Dependency cycle detected in packages:" <> line <> indent 4 - ( encloseSep "[" "]" "," - (map (style Error . fromString . packageNameString) pNames) - ) + (encloseSep "[" "]" "," (map (style Error . fromPackageName) pNames)) pprintException (DependencyPlanFailures pkg pDeps) = case mapMaybe pprintDep (Map.toList pDeps) of [] -> Nothing @@ -611,30 +609,26 @@ pprintExceptions exceptions stackYaml stackRoot isImplicitGlobal parentMap wante ] where pathElems = - [style Target . fromString . packageIdentifierString $ target] - <> map (fromString . packageIdentifierString) path + [style Target . fromPackageId $ target] + <> map fromPackageId path <> [pkgIdent] ) where - pkgName' = - style Current . fromString . packageNameString $ packageName pkg - pkgIdent = - style - Current - (fromString . packageIdentifierString $ packageIdentifier pkg) + pkgName' = style Current . fromPackageName $ packageName pkg + pkgIdent = style Current (fromPackageId $ packageIdentifier pkg) -- Skip these when they are redundant with 'NotInBuildPlan' info. pprintException (UnknownPackage name) | name `Set.member` allNotInBuildPlan = Nothing | name `Set.member` wiredInPackages = Just $ fillSep [ flow "Can't build a package with same name as a wired-in-package:" - , style Current . fromString . packageNameString $ name + , style Current . fromPackageName $ name ] | Just pruned <- Map.lookup name prunedGlobalDeps = let prunedDeps = - map (style Current . fromString . packageNameString) pruned + map (style Current . fromPackageName) pruned in Just $ fillSep [ flow "Can't use GHC boot package" - , style Current . fromString . packageNameString $ name + , style Current . fromPackageName $ name , flow "when it depends on a replaced boot package. You need to \ \add the following as explicit dependencies to the \ \project:" @@ -643,7 +637,7 @@ pprintExceptions exceptions stackYaml stackRoot isImplicitGlobal parentMap wante ] | otherwise = Just $ fillSep [ flow "Unknown package:" - , style Current . fromString . packageNameString $ name + , style Current . fromPackageName $ name ] pprintFlags flags @@ -676,7 +670,7 @@ pprintExceptions exceptions stackYaml stackRoot isImplicitGlobal parentMap wante ++ L.intercalate ", " (map packageNameString names) ] where - errorName = style Error . fromString . packageNameString $ name + errorName = style Error . fromPackageName $ name goodRange = style Good (fromString (C.display range)) rangeMsg = if range == C.anyVersion then "needed," @@ -694,7 +688,7 @@ pprintExceptions exceptions stackYaml stackRoot isImplicitGlobal parentMap wante inconsistentMsg mVersion = fillSep [ style Error $ maybe ( flow "no version" ) - ( fromString . packageIdentifierString . PackageIdentifier name ) + ( fromPackageId . PackageIdentifier name ) mVersion , flow "is in the Stack configuration" ] diff --git a/src/Stack/Types/Config/Exception.hs b/src/Stack/Types/Config/Exception.hs index bf09e90d29..daf363855d 100644 --- a/src/Stack/Types/Config/Exception.hs +++ b/src/Stack/Types/Config/Exception.hs @@ -222,7 +222,7 @@ instance Pretty ConfigPrettyException where go (name, dirs) = blankLine <> fillSep - [ style Error (fromString $ packageNameString name) + [ style Error (fromPackageName name) , flow "used in:" ] <> line diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 98c8f3cb90..d24293eb92 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -132,14 +132,14 @@ unpackPackages mSnapshot dest 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 (loc, packageLocationIdent loc) @@ -152,7 +152,7 @@ unpackPackages mSnapshot dest 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)