Resolve component targets using readBuildTargets

Bodigrim · Dec 30, 2023 · 7228a98 · 7228a98
1 parent 00e0e7b
commit 7228a98
Show file tree

Hide file tree

Showing 3 changed files with 100 additions and 0 deletions.
diff --git a/cabal-add.cabal b/cabal-add.cabal
@@ -33,6 +33,7 @@ library
     build-depends:
         base <5,
         bytestring <0.13,
+        Cabal >=3.8 && <3.11,
         Cabal-syntax >=3.8 && <3.11,
         containers <0.8,
         mtl <2.4

diff --git a/src/Distribution/Client/Add.hs b/src/Distribution/Client/Add.hs
@@ -48,12 +48,14 @@ import Distribution.PackageDescription (
   componentNameString,
   unUnqualComponentName,
  )
+import Distribution.PackageDescription.Configuration (flattenPackageDescription)
 import Distribution.PackageDescription.Parsec (
   parseGenericPackageDescription,
   parseGenericPackageDescriptionMaybe,
   runParseResult,
  )
 import Distribution.Parsec (Position (..), eitherParsec, showPError)
+import Distribution.Simple.BuildTarget (BuildTarget (BuildTargetComponent), readUserBuildTargets, resolveBuildTargets)
 
 -- | Just a newtype wrapper, since @Cabal-syntax@ does not provide any.
 newtype CommonStanza = CommonStanza {unCommonStanza :: ByteString}
@@ -216,6 +218,14 @@ parseCabalFile fileName contents = do
 
   pure (fields, packDescr)
 
+readBuildTarget :: PackageDescription -> String -> Maybe ComponentName
+readBuildTarget pkg targetStr = do
+  let (_, utargets) = readUserBuildTargets [targetStr]
+  [utarget] <- pure utargets
+  let (_, btargets) = resolveBuildTargets pkg [(utarget, False)]
+  [BuildTargetComponent btarget] <- pure btargets
+  pure btarget
+
 -- | Resolve a raw component name.
 resolveComponent
   :: MonadError String m
@@ -227,6 +237,9 @@ resolveComponent
   -- ^ Component name (default component if 'Nothing').
   -> m (Either CommonStanza ComponentName)
   -- ^ Resolved component.
+resolveComponent _ (_, gpd) (Just component)
+  | Just cmp <- readBuildTarget (flattenPackageDescription gpd) component =
+      pure $ Right cmp
 resolveComponent
   fileName
   (extractCommonStanzas -> commonStanzas, extractComponentNames -> componentNames)

diff --git a/tests/Main.hs b/tests/Main.hs
@@ -545,6 +545,90 @@ executable baz
 |]
       }
 
+caseTestTarget1 :: TestTree
+caseTestTarget1 =
+  mkTest $
+    CabalAddTest
+      { catName = "test target 1"
+      , catArgs = ["-c", "baz", "foo < 1 && >0.7", "quux < 1"]
+      , catInput =
+          [s|
+name:          dummy
+version:       0.1.0.0
+cabal-version: 2.0
+build-type:    Simple
+
+common baz
+  language: Haskell2010
+
+test-suite baz
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  build-depends:
+    base >=4.15 && <5
+|]
+      , catOutput =
+          [s|
+name:          dummy
+version:       0.1.0.0
+cabal-version: 2.0
+build-type:    Simple
+
+common baz
+  language: Haskell2010
+
+test-suite baz
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  build-depends:
+    foo < 1 && >0.7,
+    quux < 1,
+    base >=4.15 && <5
+|]
+      }
+
+caseTestTarget2 :: TestTree
+caseTestTarget2 =
+  mkTest $
+    CabalAddTest
+      { catName = "test target 2"
+      , catArgs = ["-c", "test:baz", "foo < 1 && >0.7", "quux < 1"]
+      , catInput =
+          [s|
+name:          dummy
+version:       0.1.0.0
+cabal-version: 2.0
+build-type:    Simple
+
+common baz
+  language: Haskell2010
+
+test-suite baz
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  build-depends:
+    base >=4.15 && <5
+|]
+      , catOutput =
+          [s|
+name:          dummy
+version:       0.1.0.0
+cabal-version: 2.0
+build-type:    Simple
+
+common baz
+  language: Haskell2010
+
+test-suite baz
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  build-depends:
+    foo < 1 && >0.7,
+    quux < 1,
+    base >=4.15 && <5
+|]
+      }
+
 caseCommonStanzaTarget1 :: TestTree
 caseCommonStanzaTarget1 =
   mkTest $
@@ -1210,6 +1294,8 @@ main =
       , caseExecutableTarget2
       , caseExecutableTarget3
       , caseExecutableTarget4
+      , caseTestTarget1
+      , caseTestTarget2
       , caseCommonStanzaTarget1
       , caseCommonStanzaTarget2
       , caseTwoSpacesInStanza