Add support for reading plan.json from new-build in test suite.

This information is useful for determining where the build products
are placed, so we can, e.g., run the built executables.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

cabal-testsuite/Test/Cabal/Monad.hs

@@ -31,6 +31,7 @@ module Test.Cabal.Monad (
 ) where
 
 import Test.Cabal.Script
+import Test.Cabal.Plan
 
 import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..), compilerFlavor)
 import Distribution.Simple.Program.Db
@@ -179,7 +180,8 @@ runTestM m = do
                     testRelativeCurrentDir = ".",
                     testHavePackageDb = False,
                     testCabalInstallAsSetup = False,
-                    testCabalProjectFile = "cabal.project"
+                    testCabalProjectFile = "cabal.project",
+                    testPlan = Nothing
                 }
     runReaderT (cleanup >> m) env
   where
@@ -238,6 +240,9 @@ data TestEnv = TestEnv
     , testCabalInstallAsSetup :: Bool
     -- | Says what cabal.project file to use (probed)
     , testCabalProjectFile :: FilePath
+    -- | Cached record of the plan metadata from a new-build
+    -- invocation; controlled by 'withPlan'.
+    , testPlan :: Maybe Plan
     }
 
 getTestEnv :: TestM TestEnv

cabal-testsuite/Test/Cabal/Plan.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- | Utilities for understanding @plan.json@.
+module Test.Cabal.Plan (
+    Plan,
+    planDistDir,
+) where
+
+import Distribution.Text
+import Distribution.Types.ComponentName
+import Distribution.Package
+import qualified Data.Text as Text
+import Data.Aeson
+import Data.Aeson.Types
+import Control.Monad
+
+-- TODO: index this
+data Plan = Plan { planInstallPlan :: [InstallItem] }
+
+data InstallItem
+    = APreExisting
+    | AConfigured Configured
+
+data Configured = Configured
+    { configuredDistDir       :: FilePath
+    , configuredPackageName   :: PackageName
+    , configuredComponentName :: Maybe ComponentName }
+
+instance FromJSON Plan where
+    parseJSON (Object v) = fmap Plan (v .: "install-plan")
+    parseJSON invalid = typeMismatch "Plan" invalid
+
+instance FromJSON InstallItem where
+    parseJSON obj@(Object v) = do
+        t <- v .: "type"
+        case t :: String of
+            "pre-existing" -> return APreExisting
+            "configured"   -> AConfigured `fmap` parseJSON obj
+            _              -> fail "unrecognized value of 'type' field"
+    parseJSON invalid = typeMismatch "InstallItem" invalid
+
+instance FromJSON Configured where
+    parseJSON (Object v) = do
+        dist_dir <- v .: "dist-dir"
+        pkg_name <- v .: "pkg-name"
+        component_name <- v .:? "component-name"
+        return (Configured dist_dir pkg_name component_name)
+    parseJSON invalid = typeMismatch "Configured" invalid
+
+instance FromJSON PackageName where
+    parseJSON (String t) = return (mkPackageName (Text.unpack t))
+    parseJSON invalid = typeMismatch "PackageName" invalid
+
+instance FromJSON ComponentName where
+    parseJSON (String t) =
+        case simpleParse s of
+            Nothing -> fail ("could not parse component-name: " ++ s)
+            Just r  -> return r
+      where s = Text.unpack t
+    parseJSON invalid = typeMismatch "ComponentName" invalid
+
+planDistDir :: Plan -> PackageName -> ComponentName -> FilePath
+planDistDir plan pkg_name cname =
+    case concatMap p (planInstallPlan plan) of
+        [x] -> x
+        []  -> error $ "planDistDir: could not find component " ++ display cname
+                    ++ " of package " ++ display pkg_name ++ " in install plan"
+        _   -> error $ "planDistDir: found multiple copies of component " ++ display cname
+                    ++ " of package " ++ display pkg_name ++ " in install plan"
+  where
+    p APreExisting = []
+    p (AConfigured conf) = do
+        guard (configuredPackageName conf == pkg_name)
+        guard $ case configuredComponentName conf of
+                    Nothing     -> True
+                    Just cname' -> cname == cname'
+        return (configuredDistDir conf)

cabal-testsuite/Test/Cabal/Prelude.hs

@@ -17,6 +17,7 @@ module Test.Cabal.Prelude (
 import Test.Cabal.Script
 import Test.Cabal.Run
 import Test.Cabal.Monad
+import Test.Cabal.Plan
 
 import Distribution.Compat.Time (calibrateMtimeChangeDelay)
 import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..))
@@ -29,6 +30,8 @@ import Distribution.Simple.Utils
 import Distribution.Simple.Configure
     ( getPersistBuildConfig )
 import Distribution.Version
+import Distribution.Package
+import Distribution.Types.UnqualComponentName
 import Distribution.Types.LocalBuildInfo
 import Distribution.PackageDescription
 import Distribution.PackageDescription.Parse
@@ -38,6 +41,8 @@ import Distribution.Compat.Stack
 
 import Text.Regex.Posix
 
+import qualified Data.Aeson as JSON
+import qualified Data.ByteString.Lazy as BSL
 import Control.Monad
 import Control.Monad.Trans.Reader
 import Control.Monad.IO.Class
@@ -237,6 +242,32 @@ withProjectFile :: FilePath -> TestM a -> TestM a
 withProjectFile fp m =
     withReaderT (\env -> env { testCabalProjectFile = fp }) m
 
+-- | Assuming we've successfully configured a new-build project,
+-- read out the plan metadata so that we can use it to do other
+-- operations.
+withPlan :: TestM a -> TestM a
+withPlan m = do
+    env0 <- getTestEnv
+    Just plan <- JSON.decode `fmap`
+                    liftIO (BSL.readFile (testWorkDir env0 </> "cache" </> "plan.json"))
+    withReaderT (\env -> env { testPlan = Just plan }) m
+
+-- | Run an executable from a package.  Requires 'withPlan' to have
+-- been run so that we can find the dist dir.
+runPlanExe :: String {- package name -} -> String {- component name -}
+           -> [String] -> TestM ()
+runPlanExe pkg_name cname args = void $ runPlanExe' pkg_name cname args
+
+-- | Run an executable from a package.  Requires 'withPlan' to have
+-- been run so that we can find the dist dir.  Also returns 'Result'.
+runPlanExe' :: String {- package name -} -> String {- component name -}
+            -> [String] -> TestM Result
+runPlanExe' pkg_name cname args = do
+    Just plan <- testPlan `fmap` getTestEnv
+    let dist_dir = planDistDir plan (mkPackageName pkg_name)
+                        (CExeName (mkUnqualComponentName cname))
+    runM (dist_dir </> "build" </> cname </> cname) args
+
 ------------------------------------------------------------------------
 -- * Running ghc-pkg
 

cabal-testsuite/cabal-testsuite.cabal

@@ -27,10 +27,13 @@ library
     Test.Cabal.Workdir
     Test.Cabal.Script
     Test.Cabal.Run
+    Test.Cabal.Plan
     Test.Cabal.Prelude
     Test.Cabal.Server
     Test.Cabal.Monad
   build-depends:
+    aeson,
+    attoparsec,
     async,
     base,
     bytestring,
@@ -40,6 +43,7 @@ library
     directory,
     filepath,
     regex-posix,
+    text,
     Cabal >= 1.25
   ghc-options: -Wall -fwarn-tabs
   if !os(windows)