Only pass supported options to cabal-install for the specified comman…

…d (pass e.g. --verbose only when the underlying command supports it)

cabal-dev.cabal

@@ -1,5 +1,5 @@
 Name:                cabal-dev
-Version:             0.7.4.1
+Version:             0.8
 Synopsis:            Manage sandboxed Haskell build environments
 
 Description:         cabal-dev is a tool for managing development builds of
@@ -25,7 +25,7 @@ Description:         cabal-dev is a tool for managing development builds of
                      @cabal-dev add-source@ also supports importing tarballs
                      into a local cabal repository.
                      .
-                     This tool has been tested with GHC 6.8-7.0.1.
+                     This tool has been tested with GHC 6.8-7.0.3.
 
 License:             BSD3
 License-file:        LICENSE

src/Distribution/Dev/CabalInstall.hs

@@ -8,12 +8,18 @@ module Distribution.Dev.CabalInstall
        , hasOnlyDependencies
        , configDir
        , CabalCommand(..)
+       , LongOption(..)
+       , matchOption
        , commandToString
        , stringToCommand
        , allCommands
+       , commandOptions
+       , supportsOption
+       , supportedOptions
        )
 where
 
+import Data.List ( tails, isPrefixOf )
 import Control.Applicative ( (<$>) )
 import Distribution.Version ( Version(..), withinRange
                             , earlierVersion, orLaterVersion )
@@ -34,7 +40,8 @@ import Distribution.Text ( display, simpleParse )
 
 import System.Directory ( getAppUserDataDirectory )
 
-import Distribution.Dev.TH.DeriveCabalCommands ( deriveCabalCommands )
+import Distribution.Dev.TH.DeriveCabalCommands
+    ( deriveCabalCommands, LongOption(..) )
 
 -- XXX This is duplicated in Setup.hs
 -- |Definition of the cabal-install program
@@ -103,6 +110,20 @@ hasOnlyDependencies =
 
 $(deriveCabalCommands)
 
+supportsOption :: CabalCommand -> String -> Bool
+supportsOption cc s = any (`matchOption` s) $ supportedOptions cc
+
+matchOption :: LongOption -> String -> Bool
+matchOption (LongOption s) = (== s)
+matchOption (ProgBefore s) = any (== ('-':s)) . tails
+matchOption (ProgAfter s) = ((s ++ "-") `isPrefixOf`)
+
+supportedOptions :: CabalCommand -> [LongOption]
+supportedOptions cc = commonOptions ++ commandOptions cc
+
+commonOptions :: [LongOption]
+commonOptions = [LongOption "config-file"]
+
 -- |What is the configuration directory for this cabal-install executable?
 
 -- XXX: This needs to do something different for certain platforms for

src/Distribution/Dev/InstallDependencies.hs

@@ -30,7 +30,7 @@ installDependencies flgs pkgNames = do
   s <- initPkgDb v =<< resolveSandbox flgs
   (cabal, _) <- requireProgram v CI.program emptyProgramDb
   eFeatures <- CI.getFeatures v cabal
-  setupRes <- setup s cabal flgs
+  setupRes <- setup s cabal flgs CI.Install
   case (setupRes, eFeatures) of
     (Left err, _) -> return $ CommandError err
     (_, Left err) -> return $ CommandError err

src/Distribution/Dev/InvokeCabal.hs

@@ -42,35 +42,36 @@ import Distribution.Dev.Sandbox            ( resolveSandbox
                                            )
 import Distribution.Dev.Utilities          ( ensureAbsolute )
 
-actions :: String -> CommandActions
-actions act = CommandActions
+actions :: CI.CabalCommand -> CommandActions
+actions cc = CommandActions
               { cmdDesc = "Invoke cabal-install with the development configuration"
-              , cmdRun = \flgs _ args -> invokeCabal flgs (act:args)
+              , cmdRun = \flgs _ args -> invokeCabal flgs cc args
               , cmdOpts = [] :: [OptDescr ()]
               , cmdPassFlags = True
               }
 
-invokeCabal :: Config -> [String] -> IO CommandResult
-invokeCabal flgs args = do
+invokeCabal :: Config -> CI.CabalCommand -> [String] -> IO CommandResult
+invokeCabal flgs cc args = do
   let v = getVerbosity flgs
   s <- initPkgDb v =<< resolveSandbox flgs
   cabal <- CI.findOnPath v
-  res <- setup s cabal flgs
+  res <- setup s cabal flgs cc
   case res of
     Left err -> return $ CommandError err
     Right args' -> do
              runProgram v cabal $ args' ++ args
              return CommandOk
 
-cabalArgs :: ConfiguredProgram -> Config -> IO (Either String [String])
-cabalArgs cabal flgs = do
+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
+  setup s cabal flgs cc
 
 setup :: Sandbox KnownVersion -> ConfiguredProgram -> Config ->
-         IO (Either String [String])
-setup s cabal flgs = do
+         CI.CabalCommand -> IO (Either String [String])
+setup s cabal flgs cc = do
   let v = getVerbosity flgs
   cfgIn <- getCabalConfig flgs
   cVer <- CI.getFeatures v cabal
@@ -87,15 +88,28 @@ setup s cabal flgs = do
                   "Error processing cabal config file " ++ cfgIn ++ ": " ++ err
                Right cOut -> do
                   writeUTF8File cfgOut cOut
-                  args <- extraArgs v cfgOut (getVersion s)
+                  (gOpts, cOpts) <- extraArgs v cfgOut (getVersion s)
+                  let gFlags = map toArg gOpts
+                      cFlags = map toArg $
+                               filter (CI.supportsOption cc . fst) cOpts
+                      args = concat [ gFlags, [CI.commandToString cc], cFlags ]
+                  debug v $ "Complete arguments to cabal-install: " ++ show args
                   return $ Right args
 
-extraArgs :: Verbosity -> FilePath -> PackageDbType -> IO [String]
+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
+       return ([cfgFileArg], verbosityArg:pdbArgs)
     where
-      longArg s = showString "--" . showString s . ('=':)
+      longArg s = (,) s . Just
       cfgFileArg = longArg "config-file" cfg
       verbosityArg = longArg "verbose" $ showForCabal v
       withGhcPkg = longArg "with-ghc-pkg"
@@ -107,7 +121,7 @@ extraArgs v cfg pdb =
                      debug v $ "Using GHC 6.8 compatibility wrapper for Cabal shortcoming"
                      (ghcPkgCompat, _) <-
                          requireProgram v ghcPkgCompatProgram emptyProgramConfiguration
-                     return $ [ longArg "ghc-pkg-options" $ withGhcPkg loc
+                     return $ [ longArg "ghc-pkg-options" $ toArg $ withGhcPkg loc
                               , withGhcPkg $ locationPath $
                                 programLocation ghcPkgCompat
                               ]

src/Distribution/Dev/TH/DeriveCabalCommands.hs

@@ -8,7 +8,7 @@ module Distribution.Dev.TH.DeriveCabalCommands
 where
 
 import Control.Applicative ( (<$>) )
-import Data.Char ( toUpper, isSpace, isAsciiLower, ord )
+import Data.Char ( toUpper, isSpace, isAsciiUpper, isAsciiLower, ord )
 import Data.List ( isPrefixOf, sort )
 import Control.Monad ( guard )
 import Data.Maybe ( mapMaybe )
@@ -29,10 +29,14 @@ parseCabalHelp = map (CabalCommandStr . extractName) .
       dropTillCommands = drop 1 .
                          dropWhile (not . ("Commands:" `isPrefixOf`))
 
-newtype LongOption = LongOption { longOptStr :: String }
+data LongOption
+    = LongOption String
+    | ProgBefore String
+    | ProgAfter  String
+      deriving (Eq, Show)
 
 optParseFlags :: String -> [LongOption]
-optParseFlags = map LongOption . extractLongOptions . findOptionLines . lines
+optParseFlags = extractLongOptions . findOptionLines . lines
     where
       findOptionLines = takeWhile (not . all isSpace) .
                         drop 1 .
@@ -52,38 +56,90 @@ optParseFlags = map LongOption . extractLongOptions . findOptionLines . lines
       findDoubleDash _ []              = Nothing
       findDoubleDash n (_:xs)          = let n' = n + 1
                                          in n' `seq` findDoubleDash n' xs
-      parseDoubleOpts ('-':'-':xs) =
-          let (optName, rest) = break (not . optChar) xs
-              eoc = case take 1 rest of
-                      "=" -> dropWhile (not . (`elem` ", ")) rest
-                      _   -> rest
-          in case eoc of
-               (',':' ':rest') -> optName:parseDoubleOpts rest'
-               (' ':_)         -> [optName]
-               []              -> [optName]
-               _               -> []
+      parseDoubleOpts ('-':'-':xs) = do
+        (optName, rest) <- plainOpt xs ++ progBefore xs ++ progAfter xs
+        let eoc = case take 2 rest of
+                    ['=',_] -> dropWhile isAsciiUpper $ drop 1 rest
+                    "[=" -> drop 1 $ dropWhile isAsciiUpper $ drop 2 rest
+                    _   -> rest
+        case eoc of
+          (',':' ':rest') -> optName:parseDoubleOpts rest'
+          (' ':_)         -> [optName]
+          []              -> [optName]
+          _               -> []
+
       parseDoubleOpts _ = []
+
       optChar c = ord c < 128 && (isAsciiLower c || c == '-')
 
+      plainOpt s = let (c, rest) = break (not . optChar) s
+                   in do guard $ not $ null c
+                         return (LongOption c, rest)
+
+      progBefore s = case break (== '-') s of
+                       ("PROG", '-':rest) ->
+                           do (LongOption n, rest') <- plainOpt rest
+                              return (ProgBefore n, rest')
+                       _ -> []
+      progAfter s = do (LongOption n, rest) <- plainOpt s
+                       guard $ take 1 (reverse n) == "-"
+                       case break (not . isAsciiUpper) rest of
+                         ("PROG", rest') -> return (ProgAfter $ init n, rest')
+                         _               -> []
+
+mkLO :: LongOption -> Exp
+mkLO lo = let (cn, o) = case lo of
+                          LongOption s -> ("LongOption", s)
+                          ProgBefore s -> ("ProgBefore", s)
+                          ProgAfter  s -> ("ProgAfter",  s)
+          in AppE (ConE (mkName cn)) $ LitE $ StringL o
+
+mkSupportedOptionClause :: CabalCommandStr -> String -> Clause
+mkSupportedOptionClause cStr helpOutput =
+    let supportedFlags = ListE . map mkLO .
+                         optParseFlags $ helpOutput
+    in Clause [ConP (commandConsName cStr) []] (NormalB supportedFlags) []
+
+getCabalCommandHelp :: CabalCommandStr -> IO String
+getCabalCommandHelp c = rawSystemStdout verbose "cabal" [ccStr c, "--help"]
+
+mkGetSupportedOptions :: [(CabalCommandStr, String)] -> [Dec]
+mkGetSupportedOptions cs =
+    let n = mkName "commandOptions"
+    in [ SigD n $ ccT ~~> AppT ListT (ConT (mkName "LongOption"))
+       , FunD n $ map (uncurry mkSupportedOptionClause) cs
+       ]
+
+mkGetSupportedOptionsIO :: [CabalCommandStr] -> IO [Dec]
+mkGetSupportedOptionsIO ccs =
+    mkGetSupportedOptions . zip ccs <$> mapM getCabalCommandHelp ccs
+
 getCabalHelp :: IO String
 getCabalHelp = rawSystemStdout verbose "cabal" ["--help"]
 
 getCabalCommands :: IO [CabalCommandStr]
 getCabalCommands = parseCabalHelp <$> getCabalHelp
 
-mkCabalCommandsDef :: [CabalCommandStr] -> [Dec]
+mkCabalCommandsDef :: [CabalCommandStr] -> IO [Dec]
 mkCabalCommandsDef strs =
-    concat $ map ($ strs) [return . cabalCommandsDef, mkStrToCmd, mkCmdToStr, mkAllCommands]
+    do putStrLn "Interrogating cabal-install executable:"
+       concat <$> mapM ($ strs)
+                  [ return . return . cabalCommandsDef
+                  , return . mkStrToCmd
+                  , return . mkCmdToStr
+                  , return . mkAllCommands
+                  , mkGetSupportedOptionsIO
+                  ]
 
 deriveCabalCommands :: Q [Dec]
-deriveCabalCommands = mkCabalCommandsDef <$> runIO getCabalCommands
+deriveCabalCommands = runIO $ mkCabalCommandsDef =<< getCabalCommands
 
 mkAllCommands :: [CabalCommandStr] -> [Dec]
 mkAllCommands cmds =
     let n = mkName "allCommands"
-    in [ SigD n $ AppT ListT strT
+    in [ SigD n $ AppT ListT ccT
        , FunD n
-         [ Clause [] (NormalB (ListE $ map (LitE . ccL) cmds)) []
+         [ Clause [] (NormalB (ListE $ map (ConE . commandConsName) cmds)) []
          ]
        ]
 

src/Main.hs

@@ -30,7 +30,7 @@ allCommands = [ ("add-source", AddSource.actions)
               , ("ghci", Ghci.actions)
               ] ++ map cabal CI.allCommands
     where
-      cabal s = (s, InvokeCabal.actions s)
+      cabal s = (CI.commandToString s, InvokeCabal.actions s)
 
 printVersion :: IO ()
 printVersion = do