refactoring: use cabal's unqualcompname underneath stack newtype

Author: theobat

src/Stack/Build/Cache.hs

@@ -74,7 +74,7 @@ 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 )
@@ -135,13 +135,7 @@ buildCacheFile dir component = do
   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.

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,7 @@ 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 ()
 

src/Stack/Build/ExecutePackage.hs

@@ -109,6 +109,8 @@ import           Stack.Types.CompilerPaths
                    , cpWhich, getGhcPkgExe
                    )
 import qualified Stack.Types.Component as Component
+import           Stack.Types.ComponentUtils
+                   ( StackUnqualCompName, unqualCompToText, unqualCompToString, toCabalName )
 import           Stack.Types.Config ( Config (..), HasConfig (..) )
 import           Stack.Types.ConfigureOpts
                    ( BaseConfigOpts (..), ConfigureOpts (..) )
@@ -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)
@@ -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'

src/Stack/Build/Source.hs

@@ -25,7 +25,7 @@ import qualified Pantry.SHA256 as SHA256
 import           Stack.Build.Cache ( tryGetBuildCache )
 import           Stack.Build.Haddock ( shouldHaddockDeps )
 import           Stack.Package
-                   ( buildableBenchmarks, buildableExes, buildableTestSuites
+                   ( buildableBenchmarksComp, buildableExesComp, buildableTestSuitesComp
                    , hasBuildableMainLibrary, resolvePackage
                    )
 import           Stack.PackageFile ( getPackageFile )
@@ -361,17 +361,17 @@ loadLocalPackage pp = do
             let (_s, e, t, b) = splitComponents $ Set.toList comps
             in  (e, t, b)
           Just (TargetAll _packageType) ->
-            ( buildableExes pkg
+            ( buildableExesComp pkg
             , if    bopts.tests
                  && maybe True (Set.notMember name . (.skipTest)) mcurator
-                then buildableTestSuites pkg
+                then buildableTestSuitesComp pkg
                 else Set.empty
             , if    bopts.benchmarks
                  && maybe
                       True
                       (Set.notMember name . (.skipBenchmark))
                       mcurator
-                then buildableBenchmarks pkg
+                then buildableBenchmarksComp pkg
                 else Set.empty
             )
           Nothing -> mempty
@@ -466,9 +466,9 @@ loadLocalPackage pp = do
       -- through component parsing, but the components aren't present, then they
       -- must not be buildable.
     , unbuildable = toComponents
-        (exes `Set.difference` buildableExes pkg)
-        (tests `Set.difference` buildableTestSuites pkg)
-        (benches `Set.difference` buildableBenchmarks pkg)
+        (exes `Set.difference` buildableExesComp pkg)
+        (tests `Set.difference` buildableTestSuitesComp pkg)
+        (benches `Set.difference` buildableBenchmarksComp pkg)
     }
 
 -- | Compare the current filesystem state to the cached information, and

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

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

src/Stack/ComponentFile.hs

@@ -55,6 +55,7 @@ import           Stack.Types.Component
                    , StackExecutable (..), StackLibrary (..)
                    , StackTestSuite (..), StackUnqualCompName (..)
                    )
+import           Stack.Types.ComponentUtils ( unqualCompToString, emptyCompName )
 import           Stack.Types.Config
                    ( Config (..), HasConfig (..), prettyStackDevL )
 import           Stack.Types.NamedComponent ( NamedComponent (..) )
@@ -77,7 +78,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 +93,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 +109,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 +123,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 +342,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 +546,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

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,12 @@ 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

src/Stack/Exec.hs

@@ -31,6 +31,7 @@ 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 (..) )
@@ -183,15 +184,16 @@ execCmd opts =
     let executables = concatMap (filter isCExe . Set.toList) pkgComponents
     let (exe, args') = case args of
           [] -> (firstExe, args)
-          x:xs -> case L.find (\y -> y == CExe (T.pack x)) executables of
+          x:xs -> case L.find (\y -> y == CExe (unqualCompFromString x)) 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

src/Stack/Ghci.hs

@@ -46,7 +46,8 @@ import           Stack.Ghci.Script
                    , scriptToLazyByteString
                    )
 import           Stack.Package
-                   ( buildableExes, buildableForeignLibs, getPackageOpts
+                   ( buildableForeignLibsComp, buildableSubLibsComp, buildableExesComp
+                   , buildableTestSuitesComp, buildableBenchmarksComp, 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,21 @@ 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
      )
-  <> map CExe buildableExes'
-  <> map CSubLib buildableSubLibs
-  <> (if bopts.tests then map CTest buildableTestSuites else [])
-  <> (if bopts.benchmarks then map CBench buildableBenchmarks else [])
+  <> 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)
  where
-  buildableForeignLibs' = S.toList $ buildableForeignLibs pkg
-  buildableSubLibs = getBuildableListText pkg.subLibraries
-  buildableExes' = S.toList $ buildableExes pkg
-  buildableTestSuites = getBuildableListText pkg.testSuites
-  buildableBenchmarks = getBuildableListText pkg.benchmarks
+  buildableForeignLibs' = buildableForeignLibsComp pkg
+  buildableSubLibs = buildableSubLibsComp pkg
+  buildableExes' = buildableExesComp pkg
+  buildableTestSuites = buildableTestSuitesComp pkg
+  buildableBenchmarks = buildableBenchmarksComp pkg
 wantedPackageComponents _ _ _ = S.empty
 
 checkForIssues :: HasTerm env => [GhciPkgInfo] -> RIO env ()