InvokeCabal.hs

{-# LANGUAGE CPP #-}
module Distribution.Dev.InvokeCabal
    ( actions
    , setup
    , extraArgs
    , cabalArgs
    )
where

import Control.Applicative ( (<$>) )
import Distribution.Verbosity ( Verbosity, showForCabal )
import Distribution.Simple.Program ( Program( programFindLocation )
                                   , ConfiguredProgram
                                   , emptyProgramConfiguration
                                   , locationPath
                                   , programLocation
                                   , requireProgram
                                   , runProgram
                                   , simpleProgram
                                   )
import Distribution.Simple.Utils ( writeUTF8File, debug, cabalVersion)
import Distribution.ParseUtils ( Field )
import Distribution.Version ( Version(..) )
import System.Console.GetOpt  ( OptDescr )

import Distribution.Dev.Command            ( CommandActions(..)
                                           , CommandResult(..)
                                           )
import Distribution.Dev.Flags              ( Config, getCabalConfig
                                           , getVerbosity, passthroughArgs
                                           , cfgCabalInstall, extraConfigFiles
                                           , useUserConfig
                                           )
import Distribution.Dev.InitPkgDb          ( initPkgDb )
import qualified Distribution.Dev.RewriteCabalConfig as R
import qualified Distribution.Dev.CabalInstall as CI
import Distribution.Dev.Sandbox            ( resolveSandbox
                                           , cabalConf
                                           , Sandbox
                                           , KnownVersion
                                           , PackageDbType(..)
                                           , getVersion
                                           , pkgConf
                                           , sandbox
                                           )
import Distribution.Dev.Utilities          ( ensureAbsolute )
import Distribution.Dev.MergeCabalConfig   ( mergeFields, removeFlaggedFields )

actions :: CI.CabalCommand -> CommandActions
actions cc = CommandActions
              { cmdDesc = "Invoke cabal-install with the development configuration"
              , cmdRun = \flgs _ args -> invokeCabal flgs cc args
              , cmdOpts = [] :: [OptDescr ()]
              , cmdPassFlags = True
              }

invokeCabal :: Config -> CI.CabalCommand -> [String] -> IO CommandResult
invokeCabal flgs cc args = do
  let v = getVerbosity flgs
  cabal <- CI.findOnPath v $ cfgCabalInstall flgs
  res <- cabalArgs cabal flgs cc
  case res of
    Left err -> return $ CommandError err
    Right args' -> do
             runProgram v cabal $ args' ++ args
             return CommandOk

cabalArgs :: ConfiguredProgram -> Config -> CI.CabalCommand -> IO (Either String [String])
cabalArgs cabal flgs cc = do
  let v = getVerbosity flgs
  s <- initPkgDb v =<< resolveSandbox flgs
  setup s cabal flgs cc

getUserConfigFields :: CI.CabalFeatures -> IO [Field]
getUserConfigFields fs =
    -- If we fail to read the file, then it could be that it doesn't yet
    -- exist, and it's OK to ignore.
    either (const []) id <$> (R.readConfigF =<< CI.getUserConfig fs)

-- XXX: this should return an error string instead of calling "error"
-- on failure.
getDevConfigFields :: Config -> IO [Field]
getDevConfigFields cfg = R.readConfigF_ =<< getCabalConfig cfg

setup :: Sandbox KnownVersion -> ConfiguredProgram -> Config ->
         CI.CabalCommand -> IO (Either String [String])
setup s cabal flgs cc = do
  let v = getVerbosity flgs
  cVer <- CI.getFeatures v cabal
  devFields <- getDevConfigFields flgs
  extraConfigs <- mapM R.readConfigF_ $ extraConfigFiles flgs
  let cfgOut = cabalConf s
  case cVer of
    Left err -> return $ Left err
    Right features -> do
      userFields <- if useUserConfig flgs
                    then getUserConfigFields features
                    else return []
      cabalHome <- CI.configDir features
      let rew = R.Rewrite cabalHome (sandbox s) (pkgConf s) (CI.needsQuotes features)
          cOut = show $ R.ppTopLevel $ concat $
                 R.rewriteCabalConfig rew $
                 removeFlaggedFields $
                 foldr (flip mergeFields) userFields (devFields:extraConfigs)

      writeUTF8File cfgOut cOut
      (gOpts, cOpts) <- extraArgs v cfgOut (getVersion s)
      let gFlags = map toArg gOpts
          cFlags = map toArg $ filter (CI.supportsLongOption cc . fst) cOpts
          args = concat
                 [ -- global cabal-install flags, as
                   -- generated by cabal-dev
                   gFlags

                 -- The cabal command name
                 , [ CI.commandToString cc ]

                 -- command-specific flags, as generated
                 -- by cabal-dev
                 , cFlags

                 -- Arguments that the user specified
                 -- that we pass through
                 , passthroughArgs flgs
                 ]

      debug v $ "Complete arguments to cabal-install: " ++ show args
      return $ Right args

toArg :: Option -> String
toArg (a, mb) = showString "--" .
                showString a $ maybe "" ('=':) mb

-- option name, value
type Option = (String, Maybe String)
type Options = [Option]

extraArgs :: Verbosity -> FilePath -> PackageDbType -> IO (Options, Options)
extraArgs v cfg pdb =
    do pdbArgs <- getPdbArgs
       return ([cfgFileArg], verbosityArg:pdbArgs)
    where
      longArg s = (,) s . Just
      cfgFileArg = longArg "config-file" cfg
      verbosityArg = longArg "verbose" $ showForCabal v
      withGhcPkg = longArg "with-ghc-pkg"
      getPdbArgs =
          case pdb of
            (GHC_6_8_Db loc) | needsGHC68Compat -> do
                     -- Make Cabal call the wrapper that removes the
                     -- bad argument to ghc-pkg 6.8
                     debug v $ "Using GHC 6.8 compatibility wrapper for Cabal shortcoming"
                     (ghcPkgCompat, _) <-
                         requireProgram v ghcPkgCompatProgram emptyProgramConfiguration
                     return $ [ longArg "ghc-pkg-options" $ toArg $ withGhcPkg loc
                              , withGhcPkg $ locationPath $
                                programLocation ghcPkgCompat
                              ]
            _ -> return []

-- XXX: this is very imprecise. Right now, we require a specific
-- version of Cabal, so this is ok (and is equivalent to True). Note
-- that this is the version of Cabal that THIS PROGRAM is being built
-- against, rather than the version that CABAL-INSTALL was built
-- against.
needsGHC68Compat :: Bool
needsGHC68Compat = cabalVersion < Version [1, 9] []

ghcPkgCompatProgram :: Program
ghcPkgCompatProgram  = p { programFindLocation =
                           \v -> do
                             res <- programFindLocation p v
                             case res of
                               Nothing -> return Nothing
                               Just loc -> Just `fmap` ensureAbsolute loc
                         }
    where
      p = simpleProgram "ghc-pkg-6_8-compat"