cabal-testsuite/src/Test/Cabal/Plan.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Utilities for understanding @plan.json@.
   4 module Test.Cabal.Plan (
   5     Plan,
   6     DistDirOrBinFile(..),
   7     planDistDir,
   8     buildInfoFile,
   9 ) where
  10
  11 import Distribution.Parsec (simpleParsec)
  12 import Distribution.Pretty (prettyShow)
  13 import Distribution.Types.ComponentName
  14 import Distribution.Package
  15 import qualified Data.Text as Text
  16 import Data.Aeson
  17 import Data.Aeson.Types
  18 import Control.Monad
  19
  20 -- TODO: index this
  21 data Plan = Plan { planInstallPlan :: [InstallItem] }
  22   deriving Show
  23
  24 data InstallItem
  25     = APreExisting
  26     | AConfiguredGlobal ConfiguredGlobal
  27     | AConfiguredInplace ConfiguredInplace
  28   deriving Show
  29
  30 -- local or inplace package
  31 data ConfiguredInplace = ConfiguredInplace
  32     { configuredInplaceDistDir       :: FilePath
  33     , configuredInplaceBuildInfo     :: Maybe FilePath
  34     , configuredInplacePackageName   :: PackageName
  35     , configuredInplaceComponentName :: Maybe ComponentName }
  36   deriving Show
  37
  38 data ConfiguredGlobal = ConfiguredGlobal
  39     { configuredGlobalBinFile       :: Maybe FilePath
  40     , configuredGlobalPackageName   :: PackageName
  41     , configuredGlobalComponentName :: Maybe ComponentName }
  42   deriving Show
  43
  44 instance FromJSON Plan where
  45     parseJSON (Object v) = fmap Plan (v .: "install-plan")
  46     parseJSON invalid = typeMismatch "Plan" invalid
  47
  48 instance FromJSON InstallItem where
  49     parseJSON obj@(Object v) = do
  50         t <- v .: "type"
  51         case t :: String of
  52             "pre-existing" -> return APreExisting
  53             "configured"   -> do
  54                 s <- v .: "style"
  55                 case s :: String of
  56                   "global"  -> AConfiguredGlobal `fmap` parseJSON obj
  57                   "inplace" -> AConfiguredInplace `fmap` parseJSON obj
  58                   "local"   -> AConfiguredInplace `fmap` parseJSON obj
  59                   _         -> fail $ "unrecognized value of 'style' field: " ++ s
  60             _              -> fail "unrecognized value of 'type' field"
  61     parseJSON invalid = typeMismatch "InstallItem" invalid
  62
  63 instance FromJSON ConfiguredInplace where
  64     parseJSON (Object v) = do
  65         dist_dir <- v .: "dist-dir"
  66         build_info <- v .:? "build-info"
  67         pkg_name <- v .: "pkg-name"
  68         component_name <- v .:? "component-name"
  69         return (ConfiguredInplace dist_dir build_info pkg_name component_name)
  70     parseJSON invalid = typeMismatch "ConfiguredInplace" invalid
  71
  72 instance FromJSON ConfiguredGlobal where
  73     parseJSON (Object v) = do
  74         bin_file <- v .:? "bin-file"
  75         pkg_name <- v .: "pkg-name"
  76         component_name <- v .:? "component-name"
  77         return (ConfiguredGlobal bin_file pkg_name component_name)
  78     parseJSON invalid = typeMismatch "ConfiguredGlobal" invalid
  79
  80 instance FromJSON PackageName where
  81     parseJSON (String t) = return (mkPackageName (Text.unpack t))
  82     parseJSON invalid = typeMismatch "PackageName" invalid
  83
  84 instance FromJSON ComponentName where
  85     parseJSON (String t) =
  86         case simpleParsec s of
  87             Nothing -> fail ("could not parse component-name: " ++ s)
  88             Just r  -> return r
  89       where s = Text.unpack t
  90     parseJSON invalid = typeMismatch "ComponentName" invalid
  91
  92 data DistDirOrBinFile = DistDir FilePath | BinFile FilePath
  93
  94 planDistDir :: Plan -> PackageName -> ComponentName -> DistDirOrBinFile
  95 planDistDir plan pkg_name cname =
  96     case concatMap p (planInstallPlan plan) of
  97         [x] -> x
  98         []  -> error $ "planDistDir: component " ++ prettyShow cname
  99                     ++ " of package " ++ prettyShow pkg_name ++ " either does not"
 100                     ++ " exist in the install plan or does not have a dist-dir nor bin-file"
 101         _   -> error $ "planDistDir: found multiple copies of component " ++ prettyShow cname
 102                     ++ " of package " ++ prettyShow pkg_name ++ " in install plan"
 103   where
 104     p APreExisting      = []
 105     p (AConfiguredGlobal conf) = do
 106         guard (configuredGlobalPackageName conf == pkg_name)
 107         guard $ case configuredGlobalComponentName conf of
 108                     Nothing     -> True
 109                     Just cname' -> cname == cname'
 110         case configuredGlobalBinFile conf of
 111             Nothing -> []
 112             Just bin_file -> return $ BinFile bin_file
 113     p (AConfiguredInplace conf) = do
 114         guard (configuredInplacePackageName conf == pkg_name)
 115         guard $ case configuredInplaceComponentName conf of
 116                     Nothing     -> True
 117                     Just cname' -> cname == cname'
 118         return $ DistDir $ configuredInplaceDistDir conf
 119
 120 buildInfoFile :: Plan -> PackageName -> ComponentName -> FilePath
 121 buildInfoFile plan pkg_name cname =
 122     case concatMap p (planInstallPlan plan) of
 123         [Just x] -> x
 124         [Nothing] -> error $ "buildInfoFile: component " ++ prettyShow cname
 125                     ++ " of package " ++ prettyShow pkg_name ++ " does not"
 126                     ++ " have a build info-file"
 127         []  -> error $ "buildInfoFile: component " ++ prettyShow cname
 128                     ++ " of package " ++ prettyShow pkg_name ++ " either does not"
 129                     ++ " exist in the install plan or build info-file"
 130         _   -> error $ "buildInfoFile: found multiple copies of component " ++ prettyShow cname
 131                     ++ " of package " ++ prettyShow pkg_name ++ " in install plan"
 132   where
 133     p APreExisting      = []
 134     p (AConfiguredGlobal _) = []
 135     p (AConfiguredInplace conf) = do
 136         guard (configuredInplacePackageName conf == pkg_name)
 137         guard $ case configuredInplaceComponentName conf of
 138                     Nothing     -> True
 139                     Just cname' -> cname == cname'
 140         return $ configuredInplaceBuildInfo conf