diff --git a/.stan.toml b/.stan.toml index 9c65471183..e14705d61d 100644 --- a/.stan.toml +++ b/.stan.toml @@ -83,14 +83,14 @@ # Anti-pattern: Data.ByteString.Char8.pack [[ignore]] - id = "OBS-STAN-0203-tuE+RG-234:24" + id = "OBS-STAN-0203-tuE+RG-236:24" # ✦ Description: Usage of 'pack' function that doesn't handle Unicode characters # ✦ Category: #AntiPattern # ✦ File: src\Stack\Build\ExecutePackage.hs # -# 233 ┃ -# 234 ┃ newConfigFileRoot <- S8.pack . toFilePath <$> view configFileRootL -# 235 ┃ ^^^^^^^ +# 235 ┃ +# 236 ┃ newConfigFileRoot <- S8.pack . toFilePath <$> view configFileRootL +# 237 ┃ ^^^^^^^ # Anti-pattern: Data.ByteString.Char8.pack [[ignore]] diff --git a/package.yaml b/package.yaml index 91533b8858..fe7d2274d2 100644 --- a/package.yaml +++ b/package.yaml @@ -83,6 +83,7 @@ dependencies: - fsnotify >= 0.4.1 - generic-deriving - ghc-boot +- hashable - hi-file-parser >= 0.1.6.0 - hpack >= 0.36.0 - hpc diff --git a/src/Path/CheckInstall.hs b/src/Path/CheckInstall.hs index 9421afd0ab..92f32f6e3e 100644 --- a/src/Path/CheckInstall.hs +++ b/src/Path/CheckInstall.hs @@ -6,7 +6,6 @@ module Path.CheckInstall ) where import Control.Monad.Extra ( (&&^), anyM ) -import qualified Data.Text as T import Stack.Prelude import Stack.Types.Config ( HasConfig ) import qualified System.Directory as D @@ -15,7 +14,11 @@ import qualified System.FilePath as FP -- | Checks if the installed executable will be available on the user's PATH. -- This doesn't use @envSearchPath menv@ because it includes paths only visible -- when running in the Stack environment. -warnInstallSearchPathIssues :: HasConfig env => FilePath -> [Text] -> RIO env () +warnInstallSearchPathIssues :: + HasConfig env + => FilePath + -> [String] + -> RIO env () warnInstallSearchPathIssues destDir installed = do searchPath <- liftIO FP.getSearchPath destDirIsInPATH <- liftIO $ @@ -26,7 +29,7 @@ warnInstallSearchPathIssues destDir installed = do searchPath if destDirIsInPATH then forM_ installed $ \exe -> do - mexePath <- (liftIO . D.findExecutable . T.unpack) exe + mexePath <- (liftIO . D.findExecutable) exe case mexePath of Just exePath -> do exeDir <- @@ -34,12 +37,12 @@ warnInstallSearchPathIssues destDir installed = do unless (exeDir `FP.equalFilePath` destDir) $ prettyWarnL [ flow "The" - , style File . fromString . T.unpack $ exe + , style File . fromString $ exe , flow "executable found on the PATH environment variable is" , style File . fromString $ exePath , flow "and not the version that was just installed." , flow "This means that" - , style File . fromString . T.unpack $ exe + , style File . fromString $ exe , "calls on the command line will not use this version." ] Nothing -> @@ -47,7 +50,7 @@ warnInstallSearchPathIssues destDir installed = do [ flow "Installation path" , style Dir . fromString $ destDir , flow "is on the PATH but the" - , style File . fromString . T.unpack $ exe + , style File . fromString $ exe , flow "executable that was just installed could not be found on \ \the PATH." ] diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index aba9d58197..9540d36e01 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -20,7 +20,6 @@ import Data.List ( (\\) ) import Data.List.Extra ( groupSort ) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.Text as T -- import qualified Distribution.PackageDescription as C -- import Distribution.Types.Dependency ( Dependency (..), depLibraries ) import Distribution.Version ( mkVersion ) @@ -52,9 +51,10 @@ import Stack.Types.BuildOptsMonoid ) import Stack.Types.Compiler ( getGhcVersion ) import Stack.Types.CompilerPaths ( HasCompiler, cabalVersionL ) +import Stack.Types.ComponentUtils + ( StackUnqualCompName, unqualCompToString ) import Stack.Types.Config - ( Config (..), HasConfig (..), buildOptsL - ) + ( Config (..), HasConfig (..), buildOptsL ) import Stack.Types.ConfigureOpts ( BaseConfigOpts (..) ) import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..), HasSourceMap @@ -266,7 +266,7 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do "," [ style PkgComponent - (fromString $ packageNameString p <> ":" <> T.unpack exe) + (fromString $ packageNameString p <> ":" <> unqualCompToString exe) | p <- pkgs ] prettyWarnL $ @@ -295,7 +295,7 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do -- , package names for other project packages that have an -- executable with the same name -- ) - warnings :: Map Text ([PackageName],[PackageName]) + warnings :: Map StackUnqualCompName ([PackageName],[PackageName]) warnings = Map.mapMaybe (\(pkgsToBuild, localPkgs) -> @@ -315,7 +315,7 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do -- Both cases warrant a warning. Just (NE.toList pkgsToBuild, otherLocals)) (Map.intersectionWith (,) exesToBuild localExes) - exesToBuild :: Map Text (NonEmpty PackageName) + exesToBuild :: Map StackUnqualCompName (NonEmpty PackageName) exesToBuild = collect [ (exe, pkgName') @@ -323,7 +323,7 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do , TTLocalMutable lp <- [task.taskType] , exe <- (Set.toList . exeComponents . (.components)) lp ] - localExes :: Map Text (NonEmpty PackageName) + localExes :: Map StackUnqualCompName (NonEmpty PackageName) localExes = collect [ (exe, pkg.name) diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 4f5a6e0af6..c2c6b36647 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -35,7 +35,6 @@ import qualified Data.ByteArray as Mem ( convert ) import Data.ByteString.Builder ( byteString ) import qualified Data.Map as M import qualified Data.Set as Set -import qualified Data.Text as T import qualified Data.Yaml as Yaml import Foreign.C.Types ( CTime ) import Path ( (), filename, parent, parseRelFile ) @@ -63,6 +62,8 @@ import Stack.Types.Build ) import Stack.Types.Cache ( ConfigCacheType (..) ) import Stack.Types.CompilerPaths ( cabalVersionL ) +import Stack.Types.ComponentUtils + ( StackUnqualCompName, unqualCompToString ) import Stack.Types.Config ( stackRootL ) import Stack.Types.ConfigureOpts ( BaseConfigOpts (..), ConfigureOpts (..) ) @@ -74,10 +75,11 @@ import Stack.Types.EnvConfig import Stack.Types.GhcPkgId ( ghcPkgIdString ) import Stack.Types.Installed (InstalledLibraryInfo (..), foldOnGhcPkgId' ) -import Stack.Types.NamedComponent ( NamedComponent (..) ) +import Stack.Types.NamedComponent + ( NamedComponent (..), componentCachePath ) import Stack.Types.SourceMap ( smRelDir ) import System.PosixCompat.Files - ( modificationTime, getFileStatus, setFileTimes ) + ( getFileStatus, modificationTime, setFileTimes ) -- | Directory containing files to mark an executable as installed exeInstalledDir :: (HasEnvConfig env) @@ -134,14 +136,7 @@ buildCacheFile dir component = do cachesDir <- buildCachesDir dir smh <- view $ envConfigL . to (.sourceMapHash) smDirName <- smRelDir smh - let nonLibComponent prefix name = prefix <> "-" <> T.unpack name - cacheFileName <- parseRelFile $ case component of - CLib -> "lib" - CSubLib name -> nonLibComponent "sub-lib" name - CFlib name -> nonLibComponent "flib" name - CExe name -> nonLibComponent "exe" name - CTest name -> nonLibComponent "test" name - CBench name -> nonLibComponent "bench" name + cacheFileName <- parseRelFile $ componentCachePath component pure $ cachesDir smDirName cacheFileName -- | Try to read the dirtiness cache for the given package directory. @@ -376,7 +371,7 @@ writePrecompiledCache :: -> ConfigureOpts -> Bool -- ^ build haddocks -> Installed -- ^ library - -> Set Text -- ^ executables + -> Set StackUnqualCompName -- ^ executables -> RIO env () writePrecompiledCache baseConfigOpts @@ -390,7 +385,7 @@ writePrecompiledCache ec <- view envConfigL let stackRootRelative = makeRelative (view stackRootL ec) exes' <- forM (Set.toList exes) $ \exe -> do - name <- parseRelFile $ T.unpack exe + name <- parseRelFile $ unqualCompToString exe stackRootRelative $ baseConfigOpts.snapInstallRoot bindirSuffix name let installedLibToPath libName ghcPkgId pcAction = do diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index cfd8c2953f..30dd18fb74 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -59,6 +59,7 @@ import Stack.Types.CompCollection ( collectionMember ) import Stack.Types.Compiler ( WhichCompiler (..) ) import Stack.Types.CompilerPaths ( CompilerPaths (..), HasCompiler (..) ) +import Stack.Types.ComponentUtils ( unqualCompFromText ) import Stack.Types.Config ( Config (..), HasConfig (..), stackRootL ) import Stack.Types.ConfigureOpts ( BaseConfigOpts (..) ) import qualified Stack.Types.ConfigureOpts as ConfigureOpts @@ -1182,7 +1183,8 @@ checkAndWarnForUnknownTools p = do -- From Cabal 1.12, build-tools can specify another executable in the same -- package. notPackageExe toolName = - MaybeT $ skipIf $ collectionMember toolName p.executables + MaybeT $ skipIf $ + collectionMember (unqualCompFromText toolName) p.executables warn name = MaybeT . pure . Just $ ToolWarning (ExeName name) p.name skipIf p' = pure $ if p' then Nothing else Just () diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index d55a9c0ae4..4a0157759e 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -64,6 +64,8 @@ import Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) ) import Stack.Types.BuildOptsMonoid ( ProgressBarFormat (..) ) import Stack.Types.Compiler ( ActualCompiler (..) ) import Stack.Types.CompilerPaths ( HasCompiler (..), getGhcPkgExe ) +import Stack.Types.ComponentUtils + ( StackUnqualCompName, unqualCompToString ) import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL ) import Stack.Types.ConfigureOpts @@ -162,7 +164,7 @@ printPlan plan = do <> line xs -> do let executableMsg (name, loc) = fillSep $ - fromString (T.unpack name) + fromString (unqualCompToString name) : "from" : ( case loc of Snap -> "snapshot" :: StyleDoc @@ -260,7 +262,7 @@ executePlan copyExecutables :: HasEnvConfig env - => Map Text InstallLocation + => Map StackUnqualCompName InstallLocation -> RIO env () copyExecutables exes | Map.null exes = pure () copyExecutables exes = do @@ -283,23 +285,24 @@ copyExecutables exes = do currExe <- liftIO getExecutablePath -- needed for windows, see below installed <- forMaybeM (Map.toList exes) $ \(name, loc) -> do - let bindir = + let strName = unqualCompToString name + bindir = case loc of Snap -> snapBin Local -> localBin - mfp <- forgivingResolveFile bindir (T.unpack name ++ ext) + mfp <- forgivingResolveFile bindir (strName ++ ext) >>= rejectMissingFile case mfp of Nothing -> do prettyWarnL [ flow "Couldn't find executable" - , style Current (fromString $ T.unpack name) + , style Current (fromString strName) , flow "in directory" , pretty bindir <> "." ] pure Nothing Just file -> do - let destFile = destDir' FP. T.unpack name ++ ext + let destFile = destDir' FP. strName ++ ext prettyInfoL [ flow "Copying from" , pretty file @@ -311,7 +314,7 @@ copyExecutables exes = do Platform _ Windows | FP.equalFilePath destFile currExe -> windowsRenameCopy (toFilePath file) destFile _ -> D.copyFile (toFilePath file) destFile - pure $ Just (name <> T.pack ext) + pure $ Just (strName ++ ext) unless (null installed) $ do prettyInfo $ @@ -321,7 +324,7 @@ copyExecutables exes = do ] <> line <> bulletedList - (map (fromString . T.unpack . textDisplay) installed :: [StyleDoc]) + (map fromString installed :: [StyleDoc]) unless compilerSpecific $ warnInstallSearchPathIssues destDir' installed -- | Windows can't write over the current executable. Instead, we rename the diff --git a/src/Stack/Build/ExecutePackage.hs b/src/Stack/Build/ExecutePackage.hs index 94ccbd0ce7..140970cf9f 100644 --- a/src/Stack/Build/ExecutePackage.hs +++ b/src/Stack/Build/ExecutePackage.hs @@ -32,8 +32,6 @@ import Distribution.System ( OS (..), Platform (..) ) import qualified Distribution.Text as C import Distribution.Types.MungedPackageName ( encodeCompatPackageName ) -import Distribution.Types.UnqualComponentName - ( mkUnqualComponentName ) import Distribution.Version ( mkVersion ) import Path ( (), addExtension, filename, isProperPrefixOf, parent @@ -109,6 +107,10 @@ import Stack.Types.CompilerPaths , cpWhich, getGhcPkgExe ) import qualified Stack.Types.Component as Component +import Stack.Types.ComponentUtils + ( StackUnqualCompName, toCabalName, unqualCompToString + , unqualCompToText + ) import Stack.Types.Config ( Config (..), HasConfig (..) ) import Stack.Types.ConfigureOpts ( BaseConfigOpts (..), ConfigureOpts (..) ) @@ -120,7 +122,7 @@ import Stack.Types.EnvConfig , appropriateGhcColorFlag ) import Stack.Types.EnvSettings ( EnvSettings (..) ) -import Stack.Types.GhcPkgId ( GhcPkgId, unGhcPkgId ) +import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdToText ) import Stack.Types.GlobalOpts ( GlobalOpts (..) ) import Stack.Types.Installed ( InstallLocation (..), Installed (..), InstalledMap @@ -847,9 +849,9 @@ copyPreCompiled ee task pkgId (PrecompiledCache mlib subLibs exes) = do subLibNames = Set.toList $ buildableSubLibs $ case task.taskType of TTLocalMutable lp -> lp.package TTRemotePackage _ p _ -> p - toMungedPackageId :: Text -> MungedPackageId + toMungedPackageId :: StackUnqualCompName -> MungedPackageId toMungedPackageId subLib = - let subLibName = LSubLibName $ mkUnqualComponentName $ T.unpack subLib + let subLibName = LSubLibName $ toCabalName subLib in MungedPackageId (MungedPackageName pname subLibName) pversion toPackageId :: MungedPackageId -> PackageIdentifier toPackageId (MungedPackageId n v) = @@ -958,7 +960,7 @@ checkForUnlistedFiles TTRemotePackage{} _ = pure [] -- coverage reports if coverage is enabled. singleTest :: HasEnvConfig env => TestOpts - -> [Text] + -> [StackUnqualCompName] -> ActionContext -> ExecuteEnv -> Task @@ -1013,7 +1015,7 @@ singleTest topts testsToRun ac ee task installedMap = do ] errs <- fmap Map.unions $ forM suitesToRun $ \(testName, suiteInterface) -> do - let stestName = T.unpack testName + let stestName = unqualCompToString testName (testName', isTestTypeLib) <- case suiteInterface of C.TestSuiteLibV09{} -> pure (stestName ++ "Stub", True) @@ -1077,7 +1079,7 @@ singleTest topts testsToRun ac ee task installedMap = do <> foldMap ( \ghcId -> "package-id " - <> display (unGhcPkgId ghcId) + <> display (ghcPkgIdToText ghcId) <> "\n" ) (pkgGhcIdList ++ thGhcId:Map.elems allDepsMap) @@ -1110,7 +1112,7 @@ singleTest topts testsToRun ac ee task installedMap = do <> T.intercalate " " (map showProcessArgDebug args) announce $ "test (suite: " - <> display testName + <> display (unqualCompToText testName) <> display argsDisplay <> ")" @@ -1153,7 +1155,7 @@ singleTest topts testsToRun ac ee task installedMap = do $ BL.fromStrict $ encodeUtf8 $ fromString $ show ( logPath - , mkUnqualComponentName (T.unpack testName) + , toCabalName testName ) else do isTerminal <- view $ globalOptsL . to (.terminal) @@ -1186,7 +1188,7 @@ singleTest topts testsToRun ac ee task installedMap = do let announceResult result = announce $ "Test suite " - <> display testName + <> display (unqualCompToText testName) <> " " <> result case mec of @@ -1210,15 +1212,15 @@ singleTest topts testsToRun ac ee task installedMap = do (package.buildType == C.Simple) exeName (packageNameString package.name) - (T.unpack testName) + (unqualCompToString testName) pure emptyResult when needHpc $ do let testsToRun' = map f testsToRun f tName = case (.interface) <$> mComponent of - Just C.TestSuiteLibV09{} -> tName <> "Stub" - _ -> tName + Just C.TestSuiteLibV09{} -> unqualCompToText tName <> "Stub" + _ -> unqualCompToText tName where mComponent = collectionLookup tName package.testSuites generateHpcReport pkgDir package testsToRun' @@ -1245,7 +1247,7 @@ singleTest topts testsToRun ac ee task installedMap = do -- | Implements running a package's benchmarks. singleBench :: HasEnvConfig env => BenchmarkOpts - -> [Text] + -> [StackUnqualCompName] -> ActionContext -> ExecuteEnv -> Task @@ -1255,7 +1257,7 @@ singleBench beopts benchesToRun ac ee task installedMap = do (allDepsMap, _cache) <- getConfigCache ee task installedMap False True withSingleContext ac ee task.taskType allDepsMap (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _outputType -> do - let args = map T.unpack benchesToRun <> maybe [] + let args = map unqualCompToString benchesToRun <> maybe [] ((:[]) . ("--benchmark-options=" <>)) beopts.additionalArgs @@ -1305,15 +1307,17 @@ primaryComponentOptions lp = ++ map (T.unpack . T.append "lib:") (getBuildableListText package.subLibraries) - ++ map - (T.unpack . T.append "exe:") - (Set.toList $ exesToBuild lp) + ++ Set.toList + ( Set.mapMonotonic + (\s -> "exe:" ++ unqualCompToString s) + (exesToBuild lp) + ) where package = lp.package -- | Either build all executables or, if the user specifies requested -- components, just build them. -exesToBuild :: LocalPackage -> Set Text +exesToBuild :: LocalPackage -> Set StackUnqualCompName exesToBuild lp = if lp.wanted then exeComponents lp.components else buildableExes lp.package diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index d3d8feb77d..53cdc5b045 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -80,6 +80,7 @@ import Stack.Prelude import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..) ) import Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) ) +import Stack.Types.ComponentUtils ( unqualCompFromText ) import Stack.Types.Config ( Config (..) ) import Stack.Types.NamedComponent ( NamedComponent (..), renderComponent ) @@ -226,9 +227,9 @@ parseRawTarget t = parseCompType t' = case t' of - "exe" -> Just CExe - "test" -> Just CTest - "bench" -> Just CBench + "exe" -> Just (CExe . unqualCompFromText) + "test" -> Just (CTest . unqualCompFromText) + "bench" -> Just (CBench . unqualCompFromText) _ -> Nothing -------------------------------------------------------------------------------- @@ -263,11 +264,14 @@ resolveRawTarget sma allLocs (rawInput, rt) = -- 'ComponentName' isCompNamed :: ComponentName -> NamedComponent -> Bool isCompNamed _ CLib = False - isCompNamed t1 (CSubLib t2) = t1 == t2 - isCompNamed t1 (CExe t2) = t1 == t2 - isCompNamed t1 (CFlib t2) = t1 == t2 - isCompNamed t1 (CTest t2) = t1 == t2 - isCompNamed t1 (CBench t2) = t1 == t2 + isCompNamed t1 t2 = case t2 of + (CSubLib t2') -> t1' == t2' + (CExe t2') -> t1' == t2' + (CFlib t2') -> t1' == t2' + (CTest t2') -> t1' == t2' + (CBench t2') -> t1' == t2' + where + t1' = unqualCompFromText t1 go (RTComponent cname) = do -- Associated list from component name to package that defines it. We use an diff --git a/src/Stack/Component.hs b/src/Stack/Component.hs index 549c9fc5d1..58903446a5 100644 --- a/src/Stack/Component.hs +++ b/src/Stack/Component.hs @@ -22,7 +22,6 @@ module Stack.Component , stackBenchmarkFromCabal , stackTestFromCabal , foldOnNameAndBuildInfo - , stackUnqualToQual , componentDependencyMap , fromCabalName ) where @@ -47,13 +46,6 @@ import Stack.Types.Component ) import Stack.Types.ComponentUtils ( fromCabalName ) import Stack.Types.Dependency ( cabalExeToStackDep, cabalToStackDep ) -import Stack.Types.NamedComponent ( NamedComponent ) - -stackUnqualToQual :: - (Text -> NamedComponent) - -> StackUnqualCompName - -> NamedComponent -stackUnqualToQual c (StackUnqualCompName n) = c n foldOnNameAndBuildInfo :: ( HasField "buildInfo" a StackBuildInfo diff --git a/src/Stack/ComponentFile.hs b/src/Stack/ComponentFile.hs index f8443ae6b6..19513b388d 100644 --- a/src/Stack/ComponentFile.hs +++ b/src/Stack/ComponentFile.hs @@ -55,6 +55,8 @@ import Stack.Types.Component , StackExecutable (..), StackLibrary (..) , StackTestSuite (..), StackUnqualCompName (..) ) +import Stack.Types.ComponentUtils + ( emptyCompName, unqualCompToString ) import Stack.Types.Config ( Config (..), HasConfig (..), prettyStackDevL ) import Stack.Types.NamedComponent ( NamedComponent (..) ) @@ -77,7 +79,7 @@ stackBenchmarkFiles :: StackBenchmark -> RIO GetPackageFileContext (NamedComponent, ComponentFile) stackBenchmarkFiles bench = - resolveComponentFiles (CBench bench.name.unqualCompToText) build names + resolveComponentFiles (CBench bench.name) build names where names = bnames <> exposed exposed = @@ -92,7 +94,7 @@ stackTestSuiteFiles :: StackTestSuite -> RIO GetPackageFileContext (NamedComponent, ComponentFile) stackTestSuiteFiles test = - resolveComponentFiles (CTest test.name.unqualCompToText) build names + resolveComponentFiles (CTest test.name) build names where names = bnames <> exposed exposed = @@ -108,7 +110,7 @@ stackExecutableFiles :: StackExecutable -> RIO GetPackageFileContext (NamedComponent, ComponentFile) stackExecutableFiles exe = - resolveComponentFiles (CExe exe.name.unqualCompToText) build names + resolveComponentFiles (CExe exe.name) build names where build = exe.buildInfo names = @@ -122,9 +124,9 @@ stackLibraryFiles :: stackLibraryFiles lib = resolveComponentFiles componentName build names where - componentRawName = lib.name.unqualCompToText + componentRawName = lib.name componentName - | componentRawName == mempty = CLib + | componentRawName == emptyCompName = CLib | otherwise = CSubLib componentRawName build = lib.buildInfo names = bnames ++ exposed @@ -341,7 +343,7 @@ componentOutputDir namedComponent distDir = CBench name -> makeTmp name where makeTmp name = - buildDir distDir componentNameToDir (name <> "/" <> name <> "-tmp") + buildDir distDir componentNameToDirNormOrTmp True name -- | Try to resolve the list of base names in the given directory by -- looking for unique instances of base names applied with the given @@ -545,10 +547,15 @@ buildDir distDir = distDir relDirBuild -- NOTE: don't export this, only use it for valid paths based on -- component names. -componentNameToDir :: Text -> Path Rel Dir -componentNameToDir name = - fromMaybe (throw $ ComponentNotParsedBug sName) (parseRelDir sName) - where sName = T.unpack name +componentNameToDir :: StackUnqualCompName -> Path Rel Dir +componentNameToDir = componentNameToDirNormOrTmp False + +componentNameToDirNormOrTmp :: Bool -> StackUnqualCompName -> Path Rel Dir +componentNameToDirNormOrTmp isTemp name = + fromMaybe (throw $ ComponentNotParsedBug sName) (parseRelDir fullName) + where + fullName = if isTemp then sName <> "/" <> sName <> "-tmp" else sName + sName = unqualCompToString name -- | See 'Distribution.Simple.LocalBuildInfo.componentBuildDir' componentBuildDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 739a4c3f61..1f81c2be67 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -57,6 +57,7 @@ import Stack.Types.BuildConfig import Stack.Types.Compiler ( getGhcVersion ) import Stack.Types.CompilerPaths ( getGhcPkgExe ) import Stack.Types.CompCollection ( getBuildableSetText ) +import Stack.Types.ComponentUtils ( unqualCompToString ) import Stack.Types.BuildOptsCLI ( BuildOptsCLI (..), defaultBuildOptsCLI ) import Stack.Types.EnvConfig @@ -392,11 +393,13 @@ generateHpcReportForTargets opts tixFiles targetNames = do \case CTest testName -> (pkgPath ) <$> parseRelFile - ( T.unpack testName + ( testName' ++ "/" - ++ T.unpack testName + ++ testName' ++ ".tix" ) + where + testName' = unqualCompToString testName _ -> prettyThrowIO $ NonTestSuiteTarget name TargetAll PTProject -> do pkgPath <- hpcPkgPath name @@ -619,7 +622,7 @@ findPackageFieldForBuiltPackage pkgDir pkgId subLibs field = do let subLibNames = Set.map (LSubLibName . mkUnqualComponentName . T.unpack) subLibs libraryNames = Set.insert LMainLibName subLibNames - mungedPackageIds = Set.map (computeCompatPackageId pkgId) libraryNames + mungedPackageIds = Set.map (computeCompatPackageId pkgId) libraryNames distDir <- distDirFromDir pkgDir ghcPkgExe <- getGhcPkgExe let inplaceDir = distDir relDirPackageConfInplace @@ -640,7 +643,7 @@ findPackageFieldForBuiltPackage pkgDir pkgId subLibs field = do <> fromString (toFilePath inplaceDir) <> " for munged packages matching " <> fromString pkgIdStr - (errors, keys) <- + (errors, keys) <- partitionEithers <$> traverse extractField (Set.toList mungedPackageIds) case errors of (a:_) -> pure $ Left a -- the first error only, since they're repeated anyway diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs index 4f2c7a1171..2d7ea929b8 100644 --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -31,6 +31,8 @@ import Stack.Types.BuildOptsCLI ( BuildOptsCLI (..), defaultBuildOptsCLI ) import Stack.Types.CompilerPaths ( CompilerPaths (..), HasCompiler (..), getGhcPkgExe ) +import Stack.Types.ComponentUtils + ( unqualCompFromString, unqualCompToText ) import Stack.Types.Config ( Config (..), HasConfig (..) ) import Stack.Types.EnvConfig ( EnvConfig ) import Stack.Types.EnvSettings ( EnvSettings (..) ) @@ -181,17 +183,19 @@ execCmd opts = packages <- view $ buildConfigL . to (.smWanted.project) pkgComponents <- for (Map.elems packages) ppComponents let executables = concatMap (filter isCExe . Set.toList) pkgComponents - let (exe, args') = case args of + (exe, args') = case args of [] -> (firstExe, args) - x:xs -> case L.find (\y -> y == CExe (T.pack x)) executables of - Nothing -> (firstExe, args) - argExe -> (argExe, xs) + x:xs -> let matchesExecutable y = y == CExe (unqualCompFromString x) + in case L.find matchesExecutable executables of + Nothing -> (firstExe, args) + argExe -> (argExe, xs) where firstExe = listToMaybe executables case exe of Just (CExe exe') -> do - withNewLocalBuildTargets [T.cons ':' exe'] $ build Nothing - pure (T.unpack exe', args') + let textExeName = unqualCompToText exe' + withNewLocalBuildTargets [T.cons ':' textExeName] $ build Nothing + pure (T.unpack textExeName, args') _ -> prettyThrowIO ExecutableToRunNotFound getGhcCmd pkgs args = do diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index a75f4fce01..cfdd365756 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -46,7 +46,8 @@ import Stack.Ghci.Script , scriptToLazyByteString ) import Stack.Package - ( buildableExes, buildableForeignLibs, getPackageOpts + ( buildableExes, buildableForeignLibs, buildableSubLibs + , buildableTestSuites, buildableBenchmarks, getPackageOpts , hasBuildableMainLibrary, listOfPackageDeps , packageFromPackageDescription, readDotBuildinfo , resolvePackageDescription, topSortPackageComponent @@ -63,7 +64,6 @@ import qualified Stack.Types.BuildOpts as BenchmarkOpts ( BenchmarkOpts (..) ) import qualified Stack.Types.BuildOpts as TestOpts ( TestOpts (..) ) import Stack.Types.BuildOptsCLI ( ApplyCLIFlag (..), BuildOptsCLI (..), defaultBuildOptsCLI ) -import Stack.Types.CompCollection ( getBuildableListText ) import Stack.Types.CompilerPaths ( CompilerPaths (..), HasCompiler (..) ) import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL ) @@ -951,21 +951,27 @@ makeGhciPkgInfo installMap installedMap locals addPkgs mfileTargets pkgDesc = do -- (differently). wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent wantedPackageComponents _ (TargetComps cs) _ = cs -wantedPackageComponents bopts (TargetAll PTProject) pkg = S.fromList $ +wantedPackageComponents bopts (TargetAll PTProject) pkg = ( if hasBuildableMainLibrary pkg - then CLib : map CSubLib buildableForeignLibs' - else [] + then S.insert CLib (S.mapMonotonic CSubLib buildableForeignLibs') + else S.empty + ) + <> S.mapMonotonic CExe buildableExes' + <> S.mapMonotonic CSubLib buildableSubLibs' + <> ( if bopts.tests + then S.mapMonotonic CTest buildableTestSuites' + else S.empty + ) + <> ( if bopts.benchmarks + then S.mapMonotonic CBench buildableBenchmarks' + else S.empty ) - <> map CExe buildableExes' - <> map CSubLib buildableSubLibs - <> (if bopts.tests then map CTest buildableTestSuites else []) - <> (if bopts.benchmarks then map CBench buildableBenchmarks else []) where - buildableForeignLibs' = S.toList $ buildableForeignLibs pkg - buildableSubLibs = getBuildableListText pkg.subLibraries - buildableExes' = S.toList $ buildableExes pkg - buildableTestSuites = getBuildableListText pkg.testSuites - buildableBenchmarks = getBuildableListText pkg.benchmarks + buildableForeignLibs' = buildableForeignLibs pkg + buildableSubLibs' = buildableSubLibs pkg + buildableExes' = buildableExes pkg + buildableTestSuites' = buildableTestSuites pkg + buildableBenchmarks' = buildableBenchmarks pkg wantedPackageComponents _ _ _ = S.empty checkForIssues :: HasTerm env => [GhciPkgInfo] -> RIO env () diff --git a/src/Stack/Options/BuildMonoidParser.hs b/src/Stack/Options/BuildMonoidParser.hs index 0c36a40343..810d10add3 100644 --- a/src/Stack/Options/BuildMonoidParser.hs +++ b/src/Stack/Options/BuildMonoidParser.hs @@ -7,7 +7,6 @@ module Stack.Options.BuildMonoidParser , cabalVerbosityParser ) where -import qualified Data.Text as T import Distribution.Parsec ( eitherParsec ) import Options.Applicative ( Parser, eitherReader, flag, help, long, metavar, option @@ -27,6 +26,7 @@ import Stack.Types.BuildOptsMonoid ( BuildOptsMonoid (..), CabalVerbosity, readProgressBarFormat , toFirstCabalVerbosity ) +import Stack.Types.ComponentUtils ( unqualCompFromString ) buildOptsMonoidParser :: GlobalOptsContext -> Parser BuildOptsMonoid buildOptsMonoidParser hide0 = BuildOptsMonoid @@ -214,7 +214,7 @@ buildOptsMonoidParser hide0 = BuildOptsMonoid ++ splitObjsWarning ) hide - skipComponents = many (fmap T.pack (strOption + skipComponents = many (fmap unqualCompFromString (strOption ( long "skip" <> help "Skip given component (can be specified multiple times)." <> hide diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index ff5d1161dc..8e5e598562 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -35,7 +35,6 @@ module Stack.Package import qualified Data.Map.Strict as M import qualified Data.Set as S -import Data.STRef ( STRef, modifySTRef', readSTRef, newSTRef ) import qualified Data.Text as T import Distribution.CabalSpecVersion ( cabalSpecToVersionDigits ) import Distribution.Compiler @@ -50,6 +49,7 @@ import Distribution.PackageDescription , Library (..), PackageDescription (..), PackageFlag (..) , SetupBuildInfo (..), TestSuite (..), allLibraries , buildType, depPkgName, depVerRange + , unqualComponentNameToPackageName ) import qualified Distribution.PackageDescription as Executable ( Executable (..) ) @@ -71,25 +71,26 @@ import Stack.Component , isComponentBuildable, stackBenchmarkFromCabal , stackExecutableFromCabal, stackForeignLibraryFromCabal , stackLibraryFromCabal, stackTestFromCabal - , stackUnqualToQual ) import Stack.ComponentFile ( buildDir, componentAutogenDir, componentBuildDir , componentOutputDir, packageAutogenDir ) -import Stack.Constants (relFileCabalMacrosH, relDirLogs) +import Stack.Constants ( relFileCabalMacrosH, relDirLogs ) import Stack.Constants.Config ( distDirFromDir ) import Stack.PackageFile ( getPackageFile, stackPackageFileFromCabal ) import Stack.Prelude hiding ( Display (..) ) import Stack.Types.BuildConfig ( HasBuildConfig (..), getWorkDir ) import Stack.Types.CompCollection ( CompCollection, collectionLookup, foldAndMakeCollection - , foldComponentToAnotherCollection, getBuildableSetText + , foldComponentToAnotherCollection, getBuildableSet + , getBuildableSetText ) import Stack.Types.Compiler ( ActualCompiler (..) ) import Stack.Types.CompilerPaths ( cabalVersionL ) import Stack.Types.Component ( HasBuildInfo, HasComponentInfo, StackUnqualCompName (..) ) +import Stack.Types.ComponentUtils ( emptyCompName, toCabalName ) import qualified Stack.Types.Component as Component import Stack.Types.Config ( Config (..), HasConfig (..) ) import Stack.Types.Dependency @@ -112,7 +113,7 @@ import Stack.Types.Package ) import Stack.Types.PackageFile ( DotCabalPath, PackageComponentFile (..) ) -import Stack.Types.SourceMap (Target(..)) +import Stack.Types.SourceMap ( Target(..), PackageType (..) ) import Stack.Types.Version ( VersionRange, intersectVersionRanges, withinRange ) import System.FilePath ( replaceExtension ) @@ -205,7 +206,8 @@ getPackageOpts getPackageFile stackPackage cabalFP let subLibs = S.toList $ subLibComponents $ M.keysSet componentsModules - excludedSubLibs <- mapM (parsePackageNameThrowing . T.unpack) subLibs + excludedSubLibs = + map (unqualComponentNameToPackageName . toCabalName) subLibs componentsOpts <- generatePkgDescOpts installMap installedMap @@ -259,7 +261,7 @@ generatePkgDescOpts } let insertInMap name compVal = M.insert name (generate name compVal) let translatedInsertInMap constructor name = - insertInMap (stackUnqualToQual constructor name) + insertInMap (constructor name) let makeBuildInfoOpts selector constructor = foldOnNameAndBuildInfo (selector pkg) @@ -665,20 +667,20 @@ packageUnknownTools pkg = lib (bench <> tests <> flib <> sublib <> exe) gatherUnknownTools :: HasBuildInfo x => CompCollection x -> Set Text gatherUnknownTools = foldr' addUnknownTools mempty -buildableForeignLibs :: Package -> Set Text -buildableForeignLibs pkg = getBuildableSetText pkg.foreignLibraries +buildableForeignLibs :: Package -> Set StackUnqualCompName +buildableForeignLibs pkg = getBuildableSet pkg.foreignLibraries -buildableSubLibs :: Package -> Set Text -buildableSubLibs pkg = getBuildableSetText pkg.subLibraries +buildableSubLibs :: Package -> Set StackUnqualCompName +buildableSubLibs pkg = getBuildableSet pkg.subLibraries -buildableExes :: Package -> Set Text -buildableExes pkg = getBuildableSetText pkg.executables +buildableExes :: Package -> Set StackUnqualCompName +buildableExes pkg = getBuildableSet pkg.executables -buildableTestSuites :: Package -> Set Text -buildableTestSuites pkg = getBuildableSetText pkg.testSuites +buildableTestSuites :: Package -> Set StackUnqualCompName +buildableTestSuites pkg = getBuildableSet pkg.testSuites -buildableBenchmarks :: Package -> Set Text -buildableBenchmarks pkg = getBuildableSetText pkg.benchmarks +buildableBenchmarks :: Package -> Set StackUnqualCompName +buildableBenchmarks pkg = getBuildableSet pkg.benchmarks -- | Apply a generic processing function in a Monad over all of the Package's -- components. @@ -812,56 +814,75 @@ topSortPackageComponent :: -- actual targets in the result, only their deps. Using it with False here -- only in GHCi -> Seq NamedComponent -topSortPackageComponent package target includeDirectTarget = runST $ do - alreadyProcessedRef <- newSTRef (mempty :: Set NamedComponent) - let processInitialComponents c = case target of - TargetAll{} -> processComponent includeDirectTarget alreadyProcessedRef c +topSortPackageComponent package target includeDirectTarget = + topProcessPackageComponent package target processor mempty + where + processor packageType component + | not includeDirectTarget && packageType == PTProject = id + | otherwise = \v -> v |> component.qualifiedName + +-- | Process a package's internal components in the order of their topological sort. +-- The first iteration will effect the component depending on no other component etc, +-- iterating by increasing amount of required dependencies. +-- 'PackageType' with value 'PTProject' here means the component is a direct target +-- and 'PTDependency' means it's a dependency of a direct target. +topProcessPackageComponent :: forall b. + Package + -> Target + -> ( forall component. (HasComponentInfo component) + => PackageType + -> component + -> b + -> b + ) + -> b + -> b +topProcessPackageComponent package target fn res = do + let initialState = (mempty, res) + processInitialComponents c = case target of + TargetAll{} -> processComponent PTProject c TargetComps targetSet -> if S.member c.qualifiedName targetSet - then processComponent includeDirectTarget alreadyProcessedRef c + then processComponent PTProject c else id - processPackageComponent package processInitialComponents (pure mempty) + snd $ processPackageComponent package processInitialComponents initialState where - processComponent :: forall s component. HasComponentInfo component - => Bool + processComponent :: HasComponentInfo component + => PackageType -- ^ Finally add this component in the seq - -> STRef s (Set NamedComponent) -> component - -> ST s (Seq NamedComponent) - -> ST s (Seq NamedComponent) - processComponent finallyAddComponent alreadyProcessedRef component res = do + -> (Set NamedComponent, b) + -> (Set NamedComponent, b) + processComponent packageType component currentRes@(_a, !_b) = do let depMap = componentDependencyMap component internalDep = M.lookup package.name depMap - processSubDep = processOneDep alreadyProcessedRef internalDep res qualName = component.qualifiedName - processSubDepSaveName - | finallyAddComponent = (|> qualName) <$> processSubDep - | otherwise = processSubDep - -- This is an optimization, the only components we are likely to process - -- multiple times are the ones we can find in dependencies, otherwise we - -- only fold on a single version of each component by design. + alreadyProcessed = fst currentRes + !appendToResult = fn packageType component + -- This is an optimization, the only components we are likely to process + -- multiple times are the ones we can find in dependencies, otherwise we + -- only fold on a single version of each component by design. + processedDeps = processOneDep internalDep currentRes if isPotentialDependency qualName - then do - alreadyProcessed <- readSTRef alreadyProcessedRef + then if S.member qualName alreadyProcessed - then res - else modifySTRef' alreadyProcessedRef (S.insert qualName) - >> processSubDepSaveName - else processSubDepSaveName + then currentRes + else bimap (S.insert qualName) appendToResult processedDeps + else second appendToResult processedDeps lookupLibName isMain name = if isMain then package.library else collectionLookup name package.subLibraries - processOneDep alreadyProcessed mDependency res = + processOneDep mDependency res' = case (.depType) <$> mDependency of Just (AsLibrary (DepLibrary mainLibDep subLibDeps)) -> do let processMainLibDep = - case (mainLibDep, lookupLibName True mempty) of + case (mainLibDep, lookupLibName True emptyCompName) of (True, Just mainLib) -> - processComponent True alreadyProcessed mainLib + processComponent PTDependency mainLib _ -> id processSingleSubLib name = - case lookupLibName False name.unqualCompToText of - Just lib -> processComponent True alreadyProcessed lib + case lookupLibName False name of + Just lib -> processComponent PTDependency lib Nothing -> id processSubLibDep r = foldr' processSingleSubLib r subLibDeps - processSubLibDep (processMainLibDep res) - _ -> res + processSubLibDep (processMainLibDep res') + _ -> res' diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index d4aa6b3534..117884effa 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -34,7 +34,7 @@ import Stack.Component ( fromCabalName ) import Stack.GhcPkg ( createDatabase ) import Stack.Prelude import Stack.Types.CompilerPaths ( GhcPkgExe (..), HasCompiler (..) ) -import Stack.Types.Component ( StackUnqualCompName(..) ) +import Stack.Types.ComponentUtils ( unqualCompFromText ) import Stack.Types.DumpPackage ( DumpPackage (..), SublibDump (..) ) import Stack.Types.GhcPkgId ( GhcPkgId, parseGhcPkgId ) @@ -261,7 +261,7 @@ conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do fromCabalName libName' MungedPackageName _parentPackageName _ -> "" libName = - maybe getLibNameFromLegacyName StackUnqualCompName maybeLibName + maybe getLibNameFromLegacyName unqualCompFromText maybeLibName sublib = flip SublibDump libName <$> maybePackageName parseQuoted key = case mapM (P.parseOnly (argsParser NoEscaping)) val of diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 52214e103f..cf22f0ab89 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -58,6 +58,7 @@ import Stack.Types.BuildOpts ( BenchmarkOpts (..), BuildOpts (..), TestOpts (..) ) import Stack.Types.BuildOptsCLI ( BuildSubset (..), FileWatchOpts (..) ) +import Stack.Types.ComponentUtils ( StackUnqualCompName ) import Stack.Types.ConfigureOpts ( BaseConfigOpts, ConfigureOpts, PackageConfigureOpts , configureOpts @@ -230,7 +231,7 @@ data Plan = Plan -- ^ Final actions to be taken (test, benchmark, etc) , unregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Text)) -- ^ Text is reason we're unregistering, for display only - , installExes :: !(Map Text InstallLocation) + , installExes :: !(Map StackUnqualCompName InstallLocation) -- ^ Executables that should be installed after successful building } deriving Show diff --git a/src/Stack/Types/Build/ConstructPlan.hs b/src/Stack/Types/Build/ConstructPlan.hs index 7ca6962006..d50fab63fe 100644 --- a/src/Stack/Types/Build/ConstructPlan.hs +++ b/src/Stack/Types/Build/ConstructPlan.hs @@ -31,6 +31,7 @@ import Stack.Types.Build.Exception ( ConstructPlanException ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig(..) ) import Stack.Types.CompilerPaths ( HasCompiler (..) ) +import Stack.Types.ComponentUtils ( StackUnqualCompName ) import Stack.Types.Config ( HasConfig (..) ) import Stack.Types.ConfigureOpts ( BaseConfigOpts ) import Stack.Types.Curator ( Curator ) @@ -90,7 +91,7 @@ data W = W { wFinals :: !(Map PackageName (Either ConstructPlanException Task)) -- ^ A dictionary of package names, and either a final task to perform when -- building the package or an exception. - , wInstall :: !(Map Text InstallLocation) + , wInstall :: !(Map StackUnqualCompName InstallLocation) -- ^ A dictionary of executables to be installed, and location where the -- executable's binary is placed. , wDirty :: !(Map PackageName Text) diff --git a/src/Stack/Types/Build/Exception.hs b/src/Stack/Types/Build/Exception.hs index 52fd492dcb..944c82747e 100644 --- a/src/Stack/Types/Build/Exception.hs +++ b/src/Stack/Types/Build/Exception.hs @@ -32,6 +32,8 @@ import Stack.Prelude import Stack.Types.Compiler ( ActualCompiler, compilerVersionString ) import Stack.Types.CompilerBuild ( CompilerBuild, compilerBuildSuffix ) +import Stack.Types.ComponentUtils + ( StackUnqualCompName, unqualCompToString ) import Stack.Types.DumpPackage ( DumpPackage ) import Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) ) import Stack.Types.GHCVariant ( GHCVariant, ghcVariantSuffix ) @@ -54,7 +56,7 @@ data BuildException (Path Abs File) -- stack.yaml | TestSuiteFailure PackageIdentifier - (Map Text (Maybe ExitCode)) + (Map StackUnqualCompName (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString | TestSuiteTypeUnsupported TestSuiteInterface @@ -120,7 +122,7 @@ instance Exception BuildException where [ ["Test suite failure for package " ++ packageIdentifierString ident] , flip map (Map.toList codes) $ \(name, mcode) -> concat [ " " - , T.unpack name + , unqualCompToString name , ": " , case mcode of Nothing -> " executable not found" @@ -250,7 +252,7 @@ data BuildPrettyException | SomeTargetsNotBuildable [(PackageName, NamedComponent)] | InvalidFlagSpecification [UnusedFlags] | GHCProfOptionInvalid - | NotOnlyLocal [PackageName] [Text] + | NotOnlyLocal [PackageName] [StackUnqualCompName] | CompilerVersionMismatch (Maybe (ActualCompiler, Arch)) -- found (WantedCompiler, Arch) -- expected @@ -387,7 +389,7 @@ instance Pretty BuildPrettyException where fillSep ( "Executables:" : mkNarrativeList Nothing False - (map (fromString . T.unpack) exes :: [StyleDoc]) + (map (fromString . unqualCompToString) exes :: [StyleDoc]) ) <> line pretty ( CompilerVersionMismatch diff --git a/src/Stack/Types/BuildOpts.hs b/src/Stack/Types/BuildOpts.hs index b219a0f22e..d65b661698 100644 --- a/src/Stack/Types/BuildOpts.hs +++ b/src/Stack/Types/BuildOpts.hs @@ -16,6 +16,7 @@ module Stack.Types.BuildOpts import Stack.Prelude import Stack.Types.BuildOptsMonoid ( CabalVerbosity (..), ProgressBarFormat (..) ) +import Stack.Types.Component ( StackUnqualCompName ) -- | Build options that is interpreted by the build command. This is built up -- from BuildOptsCLI and BuildOptsMonoid @@ -79,7 +80,7 @@ data BuildOpts = BuildOpts -- ^ Ask Cabal to be verbose in its builds , splitObjs :: !Bool -- ^ Whether to enable split-objs. - , skipComponents :: ![Text] + , skipComponents :: ![StackUnqualCompName] -- ^ Which components to skip when building , interleavedOutput :: !Bool -- ^ Should we use the interleaved GHC output when building diff --git a/src/Stack/Types/BuildOptsMonoid.hs b/src/Stack/Types/BuildOptsMonoid.hs index 89169379e0..69ef105d88 100644 --- a/src/Stack/Types/BuildOptsMonoid.hs +++ b/src/Stack/Types/BuildOptsMonoid.hs @@ -31,6 +31,7 @@ import Distribution.Parsec ( Parsec (..), simpleParsec ) import Distribution.Verbosity ( Verbosity, normal, verbose ) import Generics.Deriving.Monoid ( mappenddefault, memptydefault ) import Stack.Prelude hiding ( trace ) +import Stack.Types.ComponentUtils ( StackUnqualCompName ) -- | Build options that may be specified in the stack.yaml or from the CLI data BuildOptsMonoid = BuildOptsMonoid @@ -64,7 +65,7 @@ data BuildOptsMonoid = BuildOptsMonoid , reconfigure :: !FirstFalse , cabalVerbose :: !(First CabalVerbosity) , splitObjs :: !FirstFalse - , skipComponents :: ![Text] + , skipComponents :: ![StackUnqualCompName] , interleavedOutput :: !FirstTrue , progressBar :: !(First ProgressBarFormat) , ddumpDir :: !(First Text) diff --git a/src/Stack/Types/Cache.hs b/src/Stack/Types/Cache.hs index 89ec139a9b..db0403506f 100644 --- a/src/Stack/Types/Cache.hs +++ b/src/Stack/Types/Cache.hs @@ -12,7 +12,8 @@ import Database.Persist.Sql , SqlType (..) ) import Stack.Prelude -import Stack.Types.GhcPkgId ( GhcPkgId, parseGhcPkgId, unGhcPkgId ) +import Stack.Types.GhcPkgId + ( GhcPkgId, ghcPkgIdToText, parseGhcPkgId ) -- | Type of config cache data ConfigCacheType @@ -24,7 +25,7 @@ data ConfigCacheType instance PersistField ConfigCacheType where toPersistValue ConfigCacheTypeConfig = PersistText "config" toPersistValue (ConfigCacheTypeFlagLibrary v) = - PersistText $ "lib:" <> unGhcPkgId v + PersistText $ "lib:" <> ghcPkgIdToText v toPersistValue (ConfigCacheTypeFlagExecutable v) = PersistText $ "exe:" <> T.pack (packageIdentifierString v) fromPersistValue (PersistText t) = diff --git a/src/Stack/Types/CompCollection.hs b/src/Stack/Types/CompCollection.hs index 87076f785d..6868e3fa2f 100644 --- a/src/Stack/Types/CompCollection.hs +++ b/src/Stack/Types/CompCollection.hs @@ -34,9 +34,9 @@ import qualified Data.Map as M import qualified Data.Set as Set import Stack.Prelude import Stack.Types.Component - ( HasBuildInfo, HasName, StackBuildInfo (..) - , StackUnqualCompName (..) - ) + ( HasBuildInfo, HasName, StackBuildInfo (..) ) +import Stack.Types.ComponentUtils + ( StackUnqualCompName, unqualCompToText ) -- | A type representing collections of components, distinguishing buildable -- components and non-buildable components. @@ -116,12 +116,12 @@ getBuildableSet = M.keysSet . (.buildableOnes) -- | Get the names of the buildable components in the given collection, as a -- 'Set' of 'Text'. getBuildableSetText :: CompCollection component -> Set Text -getBuildableSetText = Set.mapMonotonic (.unqualCompToText) . getBuildableSet +getBuildableSetText = Set.mapMonotonic unqualCompToText . getBuildableSet -- | Get the names of the buildable components in the given collection, as a -- list of 'Text. getBuildableListText :: CompCollection component -> [Text] -getBuildableListText = getBuildableListAs (.unqualCompToText) +getBuildableListText = getBuildableListAs unqualCompToText -- | Apply the given function to the names of the buildable components in the -- given collection, yielding a list. @@ -142,25 +142,24 @@ hasBuildableComponent = not . null . getBuildableSet -- components, yields 'Just' @component@ if the collection includes a buildable -- component of that name, and 'Nothing' otherwise. collectionLookup :: - Text + StackUnqualCompName -- ^ Name of the buildable component. -> CompCollection component -- ^ Collection of components. -> Maybe component -collectionLookup needle haystack = - M.lookup (StackUnqualCompName needle) haystack.buildableOnes +collectionLookup needle haystack = M.lookup needle haystack.buildableOnes -- | For a given collection of components, yields a list of pairs for buildable -- components of the name of the component and the component. -collectionKeyValueList :: CompCollection component -> [(Text, component)] -collectionKeyValueList haystack = - (\(StackUnqualCompName k, !v) -> (k, v)) - <$> M.toList haystack.buildableOnes +collectionKeyValueList :: + CompCollection component + -> [(StackUnqualCompName, component)] +collectionKeyValueList haystack = M.toList haystack.buildableOnes -- | Yields 'True' if, and only if, the given collection of components includes -- a buildable component with the given name. collectionMember :: - Text + StackUnqualCompName -- ^ Name of the buildable component. -> CompCollection component -- ^ Collection of components. diff --git a/src/Stack/Types/Component.hs b/src/Stack/Types/Component.hs index 01940bd837..dee4979e4f 100644 --- a/src/Stack/Types/Component.hs +++ b/src/Stack/Types/Component.hs @@ -34,7 +34,8 @@ import Distribution.Simple ( Extension, Language ) import Distribution.Utils.Path ( PackageDir, SourceDir, SymbolicPath ) import GHC.Records ( HasField (..) ) import Stack.Prelude -import Stack.Types.ComponentUtils ( StackUnqualCompName (..) ) +import Stack.Types.ComponentUtils + ( StackUnqualCompName (..), emptyCompName ) import Stack.Types.Dependency ( DepValue ) import Stack.Types.NamedComponent ( NamedComponent (..) ) @@ -166,22 +167,22 @@ type HasBuildInfo component = HasField "buildInfo" component StackBuildInfo instance HasField "qualifiedName" StackLibrary NamedComponent where getField v - | rawName == mempty = CLib + | rawName == emptyCompName = CLib | otherwise = CSubLib rawName where - rawName = v.name.unqualCompToText + rawName = v.name instance HasField "qualifiedName" StackForeignLibrary NamedComponent where - getField = CFlib . (.name.unqualCompToText) + getField = CFlib . (.name) instance HasField "qualifiedName" StackExecutable NamedComponent where - getField = CExe . (.name.unqualCompToText) + getField = CExe . (.name) instance HasField "qualifiedName" StackTestSuite NamedComponent where - getField = CTest . (.name.unqualCompToText) + getField = CTest . (.name) instance HasField "qualifiedName" StackBenchmark NamedComponent where - getField = CBench . (.name.unqualCompToText) + getField = CBench . (.name) -- | Type synonym for a 'HasField' constraint which represent a virtual field, -- computed from the type, the NamedComponent constructor and the name. diff --git a/src/Stack/Types/ComponentUtils.hs b/src/Stack/Types/ComponentUtils.hs index 35bdafd2aa..d9634ee780 100644 --- a/src/Stack/Types/ComponentUtils.hs +++ b/src/Stack/Types/ComponentUtils.hs @@ -12,15 +12,22 @@ -- component and related helper functions. module Stack.Types.ComponentUtils ( StackUnqualCompName (..) + , unqualCompToText + , unqualCompFromText + , unqualCompToString + , unqualCompFromString + , emptyCompName , fromCabalName , toCabalName ) where +import Data.Aeson ( FromJSON (..) ) +import Data.Hashable ( Hashable (..) ) +import Distribution.Compat.Binary ( decode, encode ) import Distribution.PackageDescription ( UnqualComponentName, mkUnqualComponentName - , unUnqualComponentName + , unUnqualComponentName, unUnqualComponentNameST ) -import RIO.Text (pack, unpack) import Stack.Prelude -- | Type representing the name of an \'unqualified\' component (that is, the @@ -33,15 +40,29 @@ import Stack.Prelude -- Ideally, we would use the Cabal-syntax type and not 'Text', to avoid -- unnecessary work, but there is no 'Hashable' instance for -- 'Distribution.Types.UnqualComponentName.UnqualComponentName' yet. -newtype StackUnqualCompName = StackUnqualCompName - { unqualCompToText :: Text - } - deriving (Data, Eq, Generic, Hashable, IsString, NFData, Ord, Read, Show, Typeable) +newtype StackUnqualCompName = StackUnqualCompName UnqualComponentName + deriving (Data, Eq, Generic, IsString, NFData, Ord, Read, Show, Typeable) + +instance Hashable StackUnqualCompName where + hashWithSalt a v = hashWithSalt a (show v) fromCabalName :: UnqualComponentName -> StackUnqualCompName -fromCabalName unqualName = - StackUnqualCompName $ pack . unUnqualComponentName $ unqualName +fromCabalName = StackUnqualCompName toCabalName :: StackUnqualCompName -> UnqualComponentName -toCabalName (StackUnqualCompName unqualName) = - mkUnqualComponentName (unpack unqualName) +toCabalName (StackUnqualCompName unqualName) = unqualName + +unqualCompToString :: StackUnqualCompName -> String +unqualCompToString = unUnqualComponentName . toCabalName +unqualCompFromString :: String -> StackUnqualCompName +unqualCompFromString = StackUnqualCompName . mkUnqualComponentName +unqualCompToText :: StackUnqualCompName -> Text +unqualCompToText = (decode . encode) . unUnqualComponentNameST . toCabalName +unqualCompFromText :: Text -> StackUnqualCompName +unqualCompFromText = StackUnqualCompName . decode . encode + +emptyCompName :: StackUnqualCompName +emptyCompName = StackUnqualCompName $ mkUnqualComponentName "" + +instance FromJSON StackUnqualCompName where + parseJSON = fmap (StackUnqualCompName . decode . encode) <$> parseJSON @Text diff --git a/src/Stack/Types/Dependency.hs b/src/Stack/Types/Dependency.hs index 776b74f2f5..b5fcd0616c 100644 --- a/src/Stack/Types/Dependency.hs +++ b/src/Stack/Types/Dependency.hs @@ -93,4 +93,4 @@ depValueToTarget dv = case dv.depType of where completeSet dlib = (if dlib.main then Set.insert CLib else id) $ sublibSet dlib - sublibSet dlib = Set.mapMonotonic (CSubLib . unqualCompToText) dlib.subLib + sublibSet dlib = Set.mapMonotonic CSubLib dlib.subLib diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs index d399eaf693..3cda6111f1 100644 --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -4,7 +4,7 @@ module Stack.Types.GhcPkgId ( GhcPkgId - , unGhcPkgId + , ghcPkgIdToText , ghcPkgIdParser , parseGhcPkgId , ghcPkgIdString @@ -16,8 +16,11 @@ import Data.Attoparsec.Text , satisfy ) import Data.Char ( isAlphaNum ) -import qualified Data.Text as T -import Database.Persist.Sql ( PersistField, PersistFieldSql ) +import Data.Hashable ( Hashable(..) ) +import Database.Persist.Sql + ( PersistField (..), PersistFieldSql (..) ) +import Distribution.Compat.Binary ( decode, encode ) +import Distribution.Types.UnitId ( UnitId, mkUnitId, unUnitId ) import Stack.Prelude import Text.Read ( Read (..) ) @@ -35,10 +38,18 @@ instance Exception GhcPkgIdParseFail where -- | A ghc-pkg package identifier. newtype GhcPkgId - = GhcPkgId Text - deriving (Data, Eq, Generic, Ord, PersistField, PersistFieldSql, Typeable) + = GhcPkgId UnitId + deriving (Data, Eq, Generic, Ord, Typeable) -instance Hashable GhcPkgId +instance PersistField GhcPkgId where + toPersistValue = toPersistValue . ghcPkgIdToText + fromPersistValue = (fmap . fmap) ghcPkgIdFromText fromPersistValue + +instance PersistFieldSql GhcPkgId where + sqlType _ = sqlType @Text Proxy + +instance Hashable GhcPkgId where + hashWithSalt a (GhcPkgId v) = hashWithSalt a (encode v) instance NFData GhcPkgId @@ -46,7 +57,7 @@ instance Show GhcPkgId where show = show . ghcPkgIdString instance Read GhcPkgId where - readsPrec i = map (first (GhcPkgId . T.pack)) . readsPrec i + readsPrec i = map (first (GhcPkgId . mkUnitId)) . readsPrec i instance FromJSON GhcPkgId where parseJSON = withText "GhcPkgId" $ \t -> @@ -70,7 +81,7 @@ parseGhcPkgId x = go x ghcPkgIdParser :: Parser GhcPkgId ghcPkgIdParser = let elements = "_.-" :: String - in GhcPkgId . T.pack <$> + in GhcPkgId . mkUnitId <$> many1 (choice [alphaNum, satisfy (`elem` elements)]) -- | Parse an alphanumerical character, as recognised by `isAlphaNum`. @@ -80,8 +91,11 @@ alphaNum = satisfy isAlphaNum "alphanumeric" -- | Get a string representation of GHC package id. ghcPkgIdString :: GhcPkgId -> String -ghcPkgIdString (GhcPkgId x) = T.unpack x - --- | Get a text value of GHC package id -unGhcPkgId :: GhcPkgId -> Text -unGhcPkgId (GhcPkgId v) = v +ghcPkgIdString (GhcPkgId x) = unUnitId x + +-- | Get a text value of GHC package id. +ghcPkgIdToText :: GhcPkgId -> Text +ghcPkgIdToText (GhcPkgId v) = decode . encode $ v +-- | Create GhcPkgId from Text. +ghcPkgIdFromText :: Text -> GhcPkgId +ghcPkgIdFromText = GhcPkgId . decode . encode diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs index 8877062d2b..cb9df1f79c 100644 --- a/src/Stack/Types/NamedComponent.hs +++ b/src/Stack/Types/NamedComponent.hs @@ -4,6 +4,7 @@ -- | Module exporting the 'NamedComponent' type and related functions. module Stack.Types.NamedComponent ( NamedComponent (..) + , componentCachePath , renderComponent , renderComponentTo , renderPkgComponents @@ -24,20 +25,23 @@ module Stack.Types.NamedComponent import qualified Data.Set as Set import qualified Data.Text as T import Stack.Prelude +import Stack.Types.ComponentUtils + ( StackUnqualCompName, unqualCompToString, unqualCompToText + ) -- | Type representing components of a fully-resolved Cabal package. data NamedComponent = CLib -- The \'main\' unnamed library component. - | CSubLib !Text + | CSubLib !StackUnqualCompName -- A named \'subsidiary\' or \'ancillary\` library component (sub-library). - | CFlib !Text + | CFlib !StackUnqualCompName -- A foreign library. - | CExe !Text + | CExe !StackUnqualCompName -- A named executable component. - | CTest !Text + | CTest !StackUnqualCompName -- A named test-suite component. - | CBench !Text + | CBench !StackUnqualCompName -- A named benchmark component. deriving (Eq, Ord, Show) @@ -48,11 +52,19 @@ renderComponentTo = fromString . T.unpack . renderComponent renderComponent :: NamedComponent -> Text renderComponent CLib = "lib" -renderComponent (CSubLib x) = "sub-lib:" <> x -renderComponent (CFlib x) = "flib:" <> x -renderComponent (CExe x) = "exe:" <> x -renderComponent (CTest x) = "test:" <> x -renderComponent (CBench x) = "bench:" <> x +renderComponent (CSubLib x) = "sub-lib:" <> unqualCompToText x +renderComponent (CFlib x) = "flib:" <> unqualCompToText x +renderComponent (CExe x) = "exe:" <> unqualCompToText x +renderComponent (CTest x) = "test:" <> unqualCompToText x +renderComponent (CBench x) = "bench:" <> unqualCompToText x + +componentCachePath :: NamedComponent -> String +componentCachePath CLib = "lib" +componentCachePath (CSubLib x) = "sub-lib-" <> unqualCompToString x +componentCachePath (CFlib x) = "flib-" <> unqualCompToString x +componentCachePath (CExe x) = "exe-" <> unqualCompToString x +componentCachePath (CTest x) = "test-" <> unqualCompToString x +componentCachePath (CBench x) = "bench-" <> unqualCompToString x renderPkgComponents :: [(PackageName, NamedComponent)] -> Text renderPkgComponents = T.intercalate " " . map renderPkgComponent @@ -61,25 +73,25 @@ renderPkgComponent :: (PackageName, NamedComponent) -> Text renderPkgComponent (pkg, comp) = fromPackageName pkg <> ":" <> renderComponent comp -exeComponents :: Set NamedComponent -> Set Text +exeComponents :: Set NamedComponent -> Set StackUnqualCompName exeComponents = Set.fromList . mapMaybe mExeName . Set.toList where mExeName (CExe name) = Just name mExeName _ = Nothing -testComponents :: Set NamedComponent -> Set Text +testComponents :: Set NamedComponent -> Set StackUnqualCompName testComponents = Set.fromList . mapMaybe mTestName . Set.toList where mTestName (CTest name) = Just name mTestName _ = Nothing -benchComponents :: Set NamedComponent -> Set Text +benchComponents :: Set NamedComponent -> Set StackUnqualCompName benchComponents = Set.fromList . mapMaybe mBenchName . Set.toList where mBenchName (CBench name) = Just name mBenchName _ = Nothing -subLibComponents :: Set NamedComponent -> Set Text +subLibComponents :: Set NamedComponent -> Set StackUnqualCompName subLibComponents = Set.fromList . mapMaybe mSubLibName . Set.toList where mSubLibName (CSubLib name) = Just name @@ -115,13 +127,13 @@ isPotentialDependency v = isCLib v || isCSubLib v || isCExe v -- often than not, you can keep/parse the components split from the start. splitComponents :: [NamedComponent] - -> ( Set Text + -> ( Set StackUnqualCompName -- ^ Sub-libraries. - , Set Text + , Set StackUnqualCompName -- ^ Executables. - , Set Text + , Set StackUnqualCompName -- ^ Test-suites. - , Set Text + , Set StackUnqualCompName -- ^ Benchmarks. ) splitComponents = diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs index 4b363a5c1d..ddbe623c0d 100644 --- a/src/Stack/Types/SourceMap.hs +++ b/src/Stack/Types/SourceMap.hs @@ -39,6 +39,7 @@ import qualified Pantry.SHA256 as SHA256 import Path ( parent, parseRelDir ) import Stack.Prelude import Stack.Types.Compiler ( ActualCompiler ) +import Stack.Types.ComponentUtils ( fromCabalName ) import Stack.Types.NamedComponent ( NamedComponent (..) ) -- | Settings common to dependency packages ('Stack.Types.SourceMap.DepPackage') @@ -191,16 +192,12 @@ ppComponentsMaybe compType pp = do gpd <- ppGPD pp pure $ Set.fromList $ concat [ maybe [] (const $ catMaybes [compType CLib]) (C.condLibrary gpd) - , go (compType . CExe) (fst <$> C.condExecutables gpd) - , go (compType . CTest) (fst <$> C.condTestSuites gpd) - , go (compType . CBench) (fst <$> C.condBenchmarks gpd) + , mapMaybe ((compType . CExe . fromCabalName) . fst) (C.condExecutables gpd) + , mapMaybe ((compType . CTest . fromCabalName) . fst) (C.condTestSuites gpd) + , mapMaybe + ((compType . CBench . fromCabalName) . fst) + (C.condBenchmarks gpd) ] - where - go :: - (T.Text -> Maybe NamedComponent) - -> [C.UnqualComponentName] - -> [NamedComponent] - go wrapper = mapMaybe (wrapper . T.pack . C.unUnqualComponentName) -- | Version for the given 'ProjectPackage ppVersion :: MonadIO m => ProjectPackage -> m Version diff --git a/stack.cabal b/stack.cabal index 7b93f78bc0..5b8d89c617 100644 --- a/stack.cabal +++ b/stack.cabal @@ -381,6 +381,7 @@ library , fsnotify >=0.4.1 , generic-deriving , ghc-boot + , hashable , hi-file-parser >=0.1.6.0 , hpack >=0.36.0 , hpc @@ -503,6 +504,7 @@ executable stack , fsnotify >=0.4.1 , generic-deriving , ghc-boot + , hashable , hi-file-parser >=0.1.6.0 , hpack >=0.36.0 , hpc @@ -604,6 +606,7 @@ executable stack-integration-test , fsnotify >=0.4.1 , generic-deriving , ghc-boot + , hashable , hi-file-parser >=0.1.6.0 , hpack >=0.36.0 , hpc @@ -721,6 +724,7 @@ test-suite stack-unit-test , fsnotify >=0.4.1 , generic-deriving , ghc-boot + , hashable , hi-file-parser >=0.1.6.0 , hpack >=0.36.0 , hpc