cabal-dev 0.7.4.1 → 0.8
raw patch · 18 files changed
+1066/−202 lines, 18 filesdep +template-haskelldep +transformersdep ~Cabaldep ~basedep ~containersnew-component:exe:fake-ghc-cabal-dev
Dependencies added: template-haskell, transformers
Dependency ranges changed: Cabal, base, containers, network, pretty
Files
- admin/cabal-config.in +1/−3
- cabal-dev.cabal +81/−48
- src/Distribution/Dev/AddSource.hs +1/−0
- src/Distribution/Dev/BuildOpts.hs +46/−0
- src/Distribution/Dev/CabalInstall.hs +54/−7
- src/Distribution/Dev/Flags.hs +79/−8
- src/Distribution/Dev/GhcArgs.hs +63/−0
- src/Distribution/Dev/GhcPkg.hs +42/−0
- src/Distribution/Dev/Ghci.hs +21/−43
- src/Distribution/Dev/InstallDependencies.hs +5/−5
- src/Distribution/Dev/InterrogateCabalInstall.hs +170/−0
- src/Distribution/Dev/InvokeCabal.hs +75/−30
- src/Distribution/Dev/MergeCabalConfig.hs +90/−0
- src/Distribution/Dev/RewriteCabalConfig.hs +38/−23
- src/Distribution/Dev/TH/DeriveCabalCommands.hs +130/−0
- src/FakeGhc.hs +16/−0
- src/Main.hs +144/−26
- test/RunTests.hs +10/−9
admin/cabal-config.in view
@@ -22,8 +22,6 @@ -- . "dot" means 'the sandbox directory that cabal-dev is using' -- -remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive-remote-repo-cache: ~/packages local-repo: ./packages -- local-repo: -- verbose: 1@@ -55,7 +53,7 @@ -- symlink-bindir: build-summary: ./logs/build.log -- build-log:-remote-build-reporting: anonymous+-- remote-build-reporting: anonymous -- username: -- password:
cabal-dev.cabal view
@@ -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@@ -24,8 +24,6 @@ . @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. License: BSD3 License-file: LICENSE@@ -39,6 +37,7 @@ Data-Files: admin/cabal-config.in, admin/00-index.tar+Tested-with: GHC == 6.12.3, GHC == 6.10.4, GHC == 7.0.3 source-repository head type: git@@ -58,46 +57,6 @@ Default: False Manual: True -Executable ghc-pkg-6_8-compat- Main-is: GhcPkgCompat.hs- Build-Depends:- base < 5,- Cabal >=1.2 && < 1.11-- GHC-Options: -Wall- HS-Source-Dirs: src--Executable cabal-dev-test- Main-is: RunTests.hs- GHC-Options: -Wall- HS-Source-Dirs: src, test- if flag(no-cabal-dev) || !flag(build-tests)- Buildable: False- else- if impl(ghc >= 6.10)- Build-depends:- base >= 4 && < 5- else- Build-depends:- base >= 3 && < 4-- Build-depends:- MonadRandom >= 0.1 && < 0.2,- random >= 1 && < 1.1,- test-framework >= 0.3 && < 0.4,- test-framework-hunit >= 0.2,- HUnit >= 1.2 && <2,--- These dependencies are needed for the cabal-install--- code that is pulled in automatically by the userhooks- containers >= 0.1 && < 0.4,- network >= 1 && < 3,- array >= 0.1 && < 0.4,- pretty >= 1 && < 1.1-- if os(windows)- build-depends: Win32 >= 2.1 && < 2.3-- Executable cabal-dev HS-Source-Dirs: src Main-is: Main.hs@@ -113,6 +72,22 @@ Build-depends: base >= 3 && < 4 + -- Containers 0.2 did not specify a constraint on base, so we+ -- avoid using it:+ if impl(ghc >= 6.12)+ Build-depends:+ containers >= 0.3 && < 0.5++ -- Require this specific version that came with GHC 6.10 because+ -- of packaging problems with containers-0.2+ if impl(ghc == 6.10)+ Build-depends:+ containers == 0.2.0.1++ if impl(ghc == 6.8)+ Build-depends:+ containers == 0.1.0.2+ Build-depends: bytestring >= 0.9 && < 0.10, directory >= 1.0 && < 1.3,@@ -124,8 +99,15 @@ pretty >= 1.0 && < 1.1, process >= 1.0 && < 1.1, tar >= 0.3 && < 0.4,- zlib >= 0.5 && < 0.6+ zlib >= 0.5 && < 0.6,+ transformers >= 0.2 && < 0.3, + -- Template haskell is special: the compiler will die if a+ -- version other than the one that is shipped with the compiler+ -- is used. Here, we don't constrain the version and hope that+ -- there will be only one.+ template-haskell+ if os(windows) build-depends: Win32 >= 2.1 && < 2.3 @@ -134,13 +116,64 @@ Other-modules: Distribution.Dev.AddSource,- Distribution.Dev.Sandbox,- Distribution.Dev.Command,+ Distribution.Dev.BuildOpts, Distribution.Dev.CabalInstall,+ Distribution.Dev.Command, Distribution.Dev.Flags, Distribution.Dev.Ghci,- Distribution.Dev.InvokeCabal,+ Distribution.Dev.GhcPkg,+ Distribution.Dev.GhcArgs,+ Distribution.Dev.InitPkgDb, Distribution.Dev.InstallDependencies,+ Distribution.Dev.InterrogateCabalInstall,+ Distribution.Dev.InvokeCabal,+ Distribution.Dev.MergeCabalConfig, Distribution.Dev.RewriteCabalConfig,- Distribution.Dev.InitPkgDb,+ Distribution.Dev.Sandbox,+ Distribution.Dev.TH.DeriveCabalCommands, Distribution.Dev.Utilities++Executable ghc-pkg-6_8-compat+ Main-is: GhcPkgCompat.hs+ Build-Depends:+ base < 5,+ Cabal >=1.2 && < 1.11++ GHC-Options: -Wall+ HS-Source-Dirs: src++Executable cabal-dev-test+ Main-is: RunTests.hs+ GHC-Options: -Wall+ HS-Source-Dirs: src, test+ if flag(no-cabal-dev) || !flag(build-tests)+ Buildable: False+ else+ if impl(ghc >= 6.10)+ Build-depends:+ base >= 4 && < 5+ else+ Build-depends:+ base >= 3 && < 4++ Build-depends:+ MonadRandom >= 0.1 && < 0.2,+ random >= 1 && < 1.1,+ test-framework >= 0.3 && < 0.4,+ test-framework-hunit >= 0.2,+ HUnit >= 1.2 && <2,+-- These dependencies are needed for the cabal-install+-- code that is pulled in automatically by the userhooks+ containers >= 0.1 && < 0.4,+ network >= 1 && < 3,+ array >= 0.1 && < 0.4,+ pretty >= 1 && < 1.1++ if os(windows)+ build-depends: Win32 >= 2.1 && < 2.3+++Executable fake-ghc-cabal-dev+ HS-Source-Dirs: src/+ Build-depends: base+ Main-is: FakeGhc.hs
src/Distribution/Dev/AddSource.hs view
@@ -309,6 +309,7 @@ ] go = do+ debug v =<< getCurrentDirectory fns <- getDirectoryContents d case filter isCabalFile fns of [c] -> processCabalFile c
+ src/Distribution/Dev/BuildOpts.hs view
@@ -0,0 +1,46 @@+module Distribution.Dev.BuildOpts+ ( getBuildArgs+ , actions+ )+where++import Distribution.Dev.GhcArgs ( extractGHCArgs, formatGHCArgs )+import Control.Applicative ( (<$>) )+import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) )+import Distribution.Dev.Flags ( Config, getVerbosity, cfgCabalInstall )+import Distribution.Simple.Program ( getProgramOutput )+import System.Console.GetOpt ( OptDescr )++import qualified Distribution.Dev.CabalInstall as CI+import Distribution.Dev.InvokeCabal ( cabalArgs )++actions :: CommandActions+actions = CommandActions+ { cmdDesc = "Output the build arguments that Cabal would give to GHC."+ , cmdRun = \cfg _ args -> run cfg args+ , cmdOpts = [] :: [OptDescr ()]+ , cmdPassFlags = True+ }++run :: Config -> [String] -> IO CommandResult+run cfg args = do+ res <- getBuildArgs cfg args+ case res of+ Left err -> return $ CommandError err+ Right argLists ->+ do mapM_ (putStr . formatGHCArgs) argLists+ return CommandOk++getBuildArgs :: Config -> [String] -> IO (Either String [[String]])+getBuildArgs cfg args = do+ let v = getVerbosity cfg+ cabal <- CI.findOnPath v $ cfgCabalInstall cfg+ res <- cabalArgs cabal cfg CI.Build+ case res of+ Left err -> return $ Left err+ Right args' ->+ do let fakeBuildArgs = args' ++ args ++ ["--with-ghc=fake-ghc-cabal-dev"]++ -- Invoke "cabal build" with our argument-sniffing program+ -- acting as GHC+ Right . extractGHCArgs <$> getProgramOutput v cabal fakeBuildArgs
src/Distribution/Dev/CabalInstall.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} module Distribution.Dev.CabalInstall ( findOnPath , program@@ -6,10 +7,25 @@ , needsQuotes , hasOnlyDependencies , configDir+ , CabalCommand(..)+ , Option(..)+ , OptionName(..)+ , ArgType(..)+ , matchLongOption+ , commandToString+ , stringToCommand+ , allCommands+ , commandOptions+ , supportsLongOption+ , supportedOptions+ , getUserConfig ) where -import Control.Applicative ( (<$>) )+import Data.Maybe ( fromMaybe )+import Control.Applicative ( (<$>), pure )+import System.FilePath ( (</>) )+import System.Environment ( getEnvironment ) import Distribution.Version ( Version(..), withinRange , earlierVersion, orLaterVersion ) import Distribution.Verbosity ( Verbosity )@@ -29,18 +45,23 @@ import System.Directory ( getAppUserDataDirectory ) +import Distribution.Dev.InterrogateCabalInstall+ ( Option(..), OptionName(..), ArgType(..) )+import Distribution.Dev.TH.DeriveCabalCommands+ ( deriveCabalCommands )+ -- XXX This is duplicated in Setup.hs -- |Definition of the cabal-install program-program :: Program-program =- (simpleProgram "cabal") { programFindVersion =+program :: Maybe String -> Program+program p =+ (simpleProgram $ fromMaybe "cabal" p) { programFindVersion = findProgramVersion "--numeric-version" id } -- |Find cabal-install on the user's PATH-findOnPath :: Verbosity -> IO ConfiguredProgram-findOnPath v = do- (cabal, _) <- requireProgram v program emptyProgramConfiguration+findOnPath :: Verbosity -> Maybe FilePath -> IO ConfiguredProgram+findOnPath v ci = do+ (cabal, _) <- requireProgram v (program ci) emptyProgramConfiguration debug v $ concat [ "Using cabal-install " , maybe "(unknown version)" display $ programVersion cabal , " at "@@ -94,6 +115,24 @@ hasOnlyDependencies = (`withinRange` orLaterVersion (mkVer [0, 10])) . cfExeVersion +$(deriveCabalCommands)++supportsLongOption :: CabalCommand -> String -> Bool+supportsLongOption cc s = any ((`matchLongOption` s) . optionName) $ supportedOptions cc++optionName :: Option -> OptionName+optionName (Option n _) = n++supportedOptions :: CabalCommand -> [Option]+supportedOptions cc = commonOptions ++ commandOptions cc++matchLongOption :: OptionName -> String -> Bool+matchLongOption (Short _) = const False+matchLongOption (LongOption s) = (== s)++commonOptions :: [Option]+commonOptions = [Option (LongOption "config-file") Req]+ -- |What is the configuration directory for this cabal-install executable? -- XXX: This needs to do something different for certain platforms for@@ -101,3 +140,11 @@ -- cabal-dev repo) configDir :: CabalFeatures -> IO FilePath configDir _ = getAppUserDataDirectory "cabal"++getUserConfig :: CabalFeatures -> IO FilePath+getUserConfig cf = do+ env <- lookup "CABAL_CONFIG" <$> getEnvironment+ case env of+ Nothing -> (</> "config") <$> configDir cf+ Just f -> pure f+
src/Distribution/Dev/Flags.hs view
@@ -9,6 +9,10 @@ , sandboxSpecified , getVerbosity , fromFlags+ , passthroughArgs+ , cfgCabalInstall+ , extraConfigFiles+ , useUserConfig , globalOpts , parseGlobalFlags@@ -20,7 +24,7 @@ import Control.Monad ( mplus ) import Data.Monoid ( Monoid(..) ) import Data.List ( intercalate )-import Data.Maybe ( fromMaybe, isJust )+import Data.Maybe ( fromMaybe, isJust, maybeToList, listToMaybe ) import Data.Foldable ( foldMap ) import System.FilePath ( (</>) ) import Distribution.ReadE ( runReadE )@@ -30,11 +34,17 @@ , getOpt', getOpt ) +import qualified Distribution.Dev.CabalInstall as CI+ data GlobalFlag = Help | Verbose (Maybe String) | Sandbox FilePath | CabalConf FilePath | Version Bool+ | CabalInstallArg String+ | WithCabalInstall FilePath+ | ExtraConfig FilePath+ | NoUserConfig deriving (Eq, Show) globalOpts :: [OptDescr GlobalFlag]@@ -49,8 +59,49 @@ "Show the version of this program" , Option "" ["numeric-version"] (NoArg (Version True)) "Show a machine-readable version number"+ , Option "" ["cabal-install-arg"] (ReqArg CabalInstallArg "ARG") $+ "Pass this argument through to cabal-install untouched (in " +++ "case an argument to cabal-install conflicts with an " +++ "argument to cabal-dev"+ , Option "" ["with-cabal-install"] (ReqArg WithCabalInstall "PATH") $+ "The location of the specific cabal-install to invoke " +++ "(defaults to looking on your PATH)"+ , Option "" ["extra-config-file"] (ReqArg ExtraConfig "PATH") $+ "Additional cabal-install configuration files to merge " +++ "with the user configuration file and the cabal-dev " +++ "configuration file. These settings override any that " +++ "exist in a previously-loaded configuration file."+ , Option "" ["no-user-config"] (NoArg NoUserConfig) $+ "Do not use any settings from the default cabal-install " +++ "config file." ] +cabalArgToOptDescr :: CI.Option -> OptDescr GlobalFlag+cabalArgToOptDescr (CI.Option cn ty) =+ Option shortName longName parse "<internal implementation>"+ where+ shortName = case cn of+ CI.Short c -> [c]+ _ -> []++ longName = case cn of+ CI.LongOption s -> [s]+ _ -> []++ optName = case cn of+ CI.Short c -> ['-',c]+ CI.LongOption s -> '-':'-':s++ noArg = NoArg $ CabalInstallArg optName+ withArg s = case cn of+ CI.Short _ -> optName ++ s+ CI.LongOption _ -> optName ++ '=':s+ parse =+ case ty of+ CI.NoArg -> noArg+ CI.Req -> ReqArg (CabalInstallArg . withArg) "INTERNAL"+ CI.Opt -> OptArg (CabalInstallArg . maybe optName withArg) "INTERNAL"+ getOpt'' :: [OptDescr a] -> [String] -> ([a], [String], [String]) getOpt'' opts args = case break (== "--") args of@@ -81,8 +132,21 @@ "Impossible outcome from break: " ++ show impossible parseGlobalFlags :: [String] -> ([GlobalFlag], [String], [String])-parseGlobalFlags = getOpt'' globalOpts+parseGlobalFlags args = getOpt'' (globalOpts ++ defs) args+ where+ cmd = CI.stringToCommand =<< listToMaybe (dropWhile isOpt args)+ defs = dropDuplicateDefs globalOpts $+ map cabalArgToOptDescr $ CI.commandOptions =<< maybeToList cmd+ isOpt = (== "-") . take 1+ dropDuplicateDefs defs1 = map (\d -> dropDuplicate d defs1)+ dropDuplicate = foldr dropDuplicate1+ dropDuplicate1 (Option ss1 ls1 _ _) (Option ss2 ls2 o d) = Option ss' ls' o d+ where+ diffList l1 l2 = filter (not . (`elem` l2)) l1+ ss' = diffList ss2 ss1+ ls' = diffList ls2 ls1 + helpRequested :: [GlobalFlag] -> Bool helpRequested = (Help `elem`) @@ -106,23 +170,30 @@ data Config = Config { cfgVerbosity :: Maybe Verbosity , cfgCabalConfig :: Maybe FilePath , cfgSandbox :: Maybe FilePath+ , cfgCabalInstall :: Maybe FilePath+ , passthroughArgs :: [String]+ , extraConfigFiles :: [String]+ , useUserConfig :: Bool } instance Monoid Config where- mempty = Config Nothing Nothing Nothing- mappend (Config v1 c1 s1) (Config v2 c2 s2) =- Config (v2 `mplus` v1) (c2 `mplus` c1) (s2 `mplus` s1)+ mempty = Config Nothing Nothing Nothing Nothing [] [] True+ mappend (Config v1 c1 s1 ci1 a1 e1 u1) (Config v2 c2 s2 ci2 a2 e2 u2) =+ Config (v2 `mplus` v1) (c2 `mplus` c1) (s2 `mplus` s1) (ci1 `mplus` ci2) (a1 ++ a2) (e1 ++ e2) (u1 && u2) fromFlag :: GlobalFlag -> Config-fromFlag (CabalConf p) = mempty { cfgCabalConfig = Just p }-fromFlag (Sandbox s) = mempty { cfgSandbox = Just s }-fromFlag (Verbose s) = mempty { cfgVerbosity = v }+fromFlag (CabalConf p) = mempty { cfgCabalConfig = Just p }+fromFlag (Sandbox s) = mempty { cfgSandbox = Just s }+fromFlag (WithCabalInstall p) = mempty { cfgCabalInstall = Just p }+fromFlag (ExtraConfig f) = mempty { extraConfigFiles = [f] }+fromFlag (Verbose s) = mempty { cfgVerbosity = v } where v = case runReadE flagToVerbosity `fmap` s of Nothing -> Just verbose Just (Right x) -> Just x Just _ -> Nothing -- XXX: we are ignoring -- verbosity parse errors+fromFlag (CabalInstallArg a) = mempty { passthroughArgs = [a] } fromFlag _ = mempty fromFlags :: [GlobalFlag] -> Config
+ src/Distribution/Dev/GhcArgs.hs view
@@ -0,0 +1,63 @@+{-|++Mark up and extract command-line arguments in a simple text format.++>>> formatGHCArgs ["foo"] == unlines [marker start, "foo", marker end]+True+>>> let check args = [args] == extractGHCArgs (formatGHCArgs args)+>>> check ["foo"]+True+>>> check ["-Wall", "-Werror"]+True++-}+module Distribution.Dev.GhcArgs+ ( formatGHCArgs+ , extractGHCArgs+ )+where++import Data.List ( unfoldr )++-- |Format the arguments, bracketed by start end end markers, in a way+-- that can be easily parsed.+--+-- Each argument is on its own line to avoid having to escape/parse+-- strings. This assumes that there are no newlines in the arguments.+formatGHCArgs :: [String] -> String+formatGHCArgs = unlines . (++ [marker end]) . (marker start:)++-- |Extract the output from formatGHCArgs out of a String containing+-- program output.+--+-- If there were multiple invocations of GHC, then return multiple+-- sets of arguments.+extractGHCArgs :: String -> [[String]]+extractGHCArgs = unfoldr step . lines+ where+ step ls =+ case findMarkers ls of+ (args, (_endMarker:rest)) -> Just (args, rest)+ (_, []) -> Nothing -- No end marker was found++ findMarkers =+ break (isMarker end) . drop 1 . dropWhile (not . isMarker start)++-- |Format a start or end marker+--+-- This is used to extract GHC arguments out of the output from+-- cabal-install, where there may be multiple invocations of GHC as+-- well as much other output.+marker :: Marker -> String+marker (Marker s) = concat ["== GHC Arguments: ", s, " =="]++isMarker :: Marker -> String -> Bool+isMarker m = (== marker m)++end :: Marker+end = Marker "End"++start :: Marker+start = Marker "Start"++newtype Marker = Marker String
+ src/Distribution/Dev/GhcPkg.hs view
@@ -0,0 +1,42 @@+{-|++Invoke ghc-pkg with the appropriate arguments to run in the cabal-dev+sandbox.++-}+module Distribution.Dev.GhcPkg+ ( actions+ )+where++import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) )+import System.Console.GetOpt ( OptDescr )+import Distribution.Dev.Flags ( Config, getVerbosity )+import Distribution.Dev.InitPkgDb ( initPkgDb )+import Distribution.Dev.Sandbox ( resolveSandbox, getVersion+ , PackageDbType(..), pkgConf )+import Distribution.Simple.Program ( emptyProgramConfiguration+ , requireProgram+ , runProgram+ , ghcPkgProgram+ )++actions :: CommandActions+actions = CommandActions+ { cmdDesc = "Invoke ghc-pkg on the package database in"+ , cmdRun = \cfg _ args -> invokeGhcPkg cfg args+ , cmdOpts = [] :: [OptDescr ()]+ , cmdPassFlags = True+ }++invokeGhcPkg :: Config -> [String] -> IO CommandResult+invokeGhcPkg cfg args = do+ let v = getVerbosity cfg+ s <- initPkgDb v =<< resolveSandbox cfg+ (ghcPkg, _) <- requireProgram v ghcPkgProgram emptyProgramConfiguration+ let extraArgs = case getVersion s of+ GHC_6_8_Db _ -> id+ _ -> ("--no-user-package-conf":)++ runProgram v ghcPkg $ extraArgs $ "--global" : "--package-conf" : pkgConf s : args+ return CommandOk
src/Distribution/Dev/Ghci.hs view
@@ -2,58 +2,36 @@ ( actions ) where -import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) )-import Distribution.Dev.Flags ( Config, getVerbosity, getSandbox )-import Distribution.Dev.InitPkgDb ( initPkgDb )-import Distribution.Dev.Sandbox ( pkgConf, Sandbox, KnownVersion, resolveSandbox )-import Distribution.Simple.Program ( Program( programFindVersion- )- , ConfiguredProgram( programDefaultArgs )- , emptyProgramConfiguration- , findProgramVersion+import Distribution.Simple.Program ( emptyProgramConfiguration , runProgram , requireProgram- , simpleProgram- , programVersion- , programLocation- , locationPath+ , ghcProgram )-import Distribution.Simple.Utils ( debug )-import Distribution.Text ( display )-import System.Console.GetOpt ( OptDescr )-import System.FilePath ((</>))+import System.Console.GetOpt ( OptDescr ) +import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) )+import Distribution.Dev.Flags ( Config, getVerbosity )+import Distribution.Dev.BuildOpts ( getBuildArgs )+ actions :: CommandActions actions = CommandActions- { cmdDesc = "Run ghci with the proper package database."+ { cmdDesc = "Run ghci configured as per the specified cabal file." , cmdRun = \cfg _ args -> invokeGhci cfg args , cmdOpts = [] :: [OptDescr ()] , cmdPassFlags = True } -ghciArgs :: Sandbox KnownVersion -> [String]-ghciArgs sandbox = [ "-package-conf", pkgConf sandbox- , "-no-user-package-conf"- ]--configureGhci :: Config -> IO ConfiguredProgram-configureGhci cfg = do (ghci, _) <- requireProgram (getVerbosity cfg) ghciProgram emptyProgramConfiguration- sandbox <- initPkgDb (getVerbosity cfg) =<< (resolveSandbox cfg)- return ghci { programDefaultArgs = ghciArgs sandbox }---- XXX This invocation pattern is repeated in at least two places (see InvokeCabal) invokeGhci :: Config -> [String] -> IO CommandResult-invokeGhci cfg args = do let v = getVerbosity cfg- ghci <- configureGhci cfg- debug v $ concat [ "Using ghci "- , maybe "(unknown version)" display $ programVersion ghci- , " at "- , show (locationPath $ programLocation ghci)- ]- runProgram v ghci args- return CommandOk--ghciProgram :: Program-ghciProgram = (simpleProgram "ghci") {- programFindVersion = findProgramVersion "--numeric-version" id- }+invokeGhci cfg args = do+ let v = getVerbosity cfg+ res <- getBuildArgs cfg args+ case res of+ Left err -> return $ CommandError err+ Right (buildArgs:_) ->+ do -- Use the arguments that cabal-install passed to GHC to+ -- invoke ghci instead+ let ghciArgs = "--interactive" : filter (/= "--make") buildArgs+ (ghc, _) <- requireProgram v ghcProgram emptyProgramConfiguration+ runProgram v ghc ghciArgs+ return CommandOk+ Right [] -> return $ CommandError "Failed to extract GHC build arguments"
src/Distribution/Dev/InstallDependencies.hs view
@@ -4,7 +4,7 @@ import System.Console.GetOpt ( OptDescr(..) ) import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) )-import Distribution.Dev.Flags ( Config, getVerbosity )+import Distribution.Dev.Flags ( Config, getVerbosity, cfgCabalInstall ) import Distribution.Dev.Sandbox ( resolveSandbox ) import Distribution.Dev.InitPkgDb ( initPkgDb ) import Distribution.Dev.InvokeCabal ( setup )@@ -28,9 +28,9 @@ installDependencies flgs pkgNames = do let v = getVerbosity flgs s <- initPkgDb v =<< resolveSandbox flgs- (cabal, _) <- requireProgram v CI.program emptyProgramDb+ (cabal, _) <- requireProgram v (CI.program $ cfgCabalInstall flgs) 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@@ -40,7 +40,7 @@ \the --only-dependencies flag to the install command.\ \ Invoking that instead..." runProgram v cabal $ concat [ args- , ["install", "--only-dependencies"]+ , ["--only-dependencies"] , pkgNames ] return CommandOk@@ -49,7 +49,7 @@ \ less than 0.10" out <- getProgramOutput v cabal $ concat [ args- , ["install", "--dry-run", "--verbose=1"]+ , ["--dry-run", "--verbose=1"] , pkgNames ] let -- Drop the lines that say:
+ src/Distribution/Dev/InterrogateCabalInstall.hs view
@@ -0,0 +1,170 @@+{-|++Support for determining the interface of cabal-install via its --help+output.++ -}+module Distribution.Dev.InterrogateCabalInstall+ ( CabalCommandStr+ , ccStr+ , parseCabalHelp+ , Option(..)+ , OptionName(..)+ , ArgType(..)+ , optParseFlags+ , getCabalCommandHelp+ , getCabalHelp+ , getCabalCommands+ , Program+ , progStr+ , getCabalProgs+ )+where++import Control.Applicative ( (<$>) )+import Data.Char ( isSpace, isAsciiUpper, isAsciiLower, ord, isLetter )+import Data.List ( isPrefixOf, sort )+import Control.Monad ( guard )+import Data.Maybe ( mapMaybe )+import Distribution.Simple.Utils ( rawSystemStdout )+import Distribution.Verbosity ( verbose )++-- |A cabal-install command name+newtype CabalCommandStr = CabalCommandStr { ccStr :: String }++newtype Program = Program { progStr :: String } deriving (Show, Eq)++-- |Get the command names from a String containing the output of+-- cabal-install --help+parseCabalHelp :: String -> [CabalCommandStr]+parseCabalHelp = map (CabalCommandStr . extractName) .+ takeCommands .+ dropTillCommands .+ lines+ where+ extractName = takeWhile (not . isSpace) . dropWhile isSpace+ takeCommands = takeWhile (not . all isSpace)+ dropTillCommands = drop 1 .+ dropWhile (not . ("Commands:" `isPrefixOf`))++-- |The kinds of options supported by cabal-install+--+-- XXX: this should also record whether an argument is required.+--+-- XXX: this should also parse short options+data OptionName+ = LongOption String+ | Short Char+ deriving (Eq, Show)++progBeforeOpt :: [Program] -> String -> [OptionName]+progBeforeOpt progs s = map (\p -> LongOption $ progStr p ++ '-':s) progs++progAfterOpt :: [Program] -> String -> [OptionName]+progAfterOpt progs s = map (LongOption . (s ++) . ('-':) . progStr) progs++data Option = Option OptionName ArgType deriving (Show, Eq)++data ArgType = Req | Opt | NoArg deriving (Eq, Show)++parseProgs :: String -> [Program]+parseProgs = map Program . words . concat . takeWhile (not . all isSpace) .+ drop 1 . dropWhile (not . isProgIntro) . lines+ where+ isProgIntro s = (reverse "can be used with the following programs:")+ `isPrefixOf` (dropWhile isSpace $ reverse s)++-- |Parse the output of 'cabal foo --help' to determine the valid+-- options for 'cabal foo'+--+-- Note that the --config-file flag is never documented.+optParseFlags :: [Program] -> String -> [Option]+optParseFlags progs = extractLongOptions . findOptionLines . lines+ where+ findOptionLines = takeWhile (not . all isSpace) .+ drop 1 .+ dropWhile (not . ("Flags for " `isPrefixOf`))++ leftmostDoubleDash = take 1 . sort . mapMaybe (findDoubleDash 0)++ extractLongOptions ls = do+ i <- leftmostDoubleDash ls+ guard $ checkLoc i ls+ (soptStr, (' ':l@('-':'-':_))) <- splitAt i <$> ls+ let (doubleOpts, tys) = unzip $ parseDoubleOpts l+ ty = case tys of+ (t:_) -> t+ [] -> NoArg+ map (\n -> Option n ty) $ parseSingleOpts soptStr ++ doubleOpts++ -- Check that the spot that we picked to split is either the+ -- start of a long option description or whitespace+ checkLoc i = all (`elem` [" --", " "]) . map (take 3 . drop i)++ findDoubleDash n (' ':'-':'-':_) = Just n+ findDoubleDash _ [] = Nothing+ findDoubleDash n (_:xs) = let n' = n + 1+ in n' `seq` findDoubleDash n' xs++ parseDoubleOpts ('-':'-':xs) = do+ (optName, rest) <- plainOpt xs ++ progBefore xs ++ progAfter xs+ let (eoc, ty) =+ case take 2 rest of+ ['=',_] -> (dropWhile isLetter $ drop 1 rest, Req)+ "[=" -> (drop 1 $ dropWhile isLetter $ drop 2 rest, Opt)+ _ -> (rest, NoArg)+ opt = (optName, ty)+ case eoc of+ (',':' ':rest') -> opt:parseDoubleOpts rest'+ (' ':_) -> [opt]+ [] -> [opt]+ _ -> []++ parseDoubleOpts _ = []++ parseSingleOpts s =+ case dropWhile isSpace s of+ ('-':c:rest)+ | isAsciiLower c || isAsciiUpper c ->+ case rest of+ (',':' ':s') -> Short c:parseSingleOpts s'+ [] -> [Short c]+ (' ':_) -> [Short c]+ _ -> []+ _ -> []++ 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+ o <- progBeforeOpt progs n+ return (o, rest')+ _ -> []++ progAfter s = do (LongOption n, rest) <- plainOpt s+ guard $ take 1 (reverse n) == "-"+ case break (not . isAsciiUpper) rest of+ ("PROG", rest') -> do o <- progAfterOpt progs $ init n+ return (o, rest')+ _ -> []++-- |Obtain the --help output for a particular cabal-install command+getCabalCommandHelp :: CabalCommandStr -> IO String+getCabalCommandHelp c = rawSystemStdout verbose "cabal" [ccStr c, "--help"]++-- |Obtain the top-level --help output for cabal-install+getCabalHelp :: IO String+getCabalHelp = rawSystemStdout verbose "cabal" ["--help"]++-- |Invoke cabal-install in order to determine what commands it+-- supports.+getCabalCommands :: IO [CabalCommandStr]+getCabalCommands = parseCabalHelp <$> getCabalHelp++getCabalProgs :: IO [Program]+getCabalProgs = parseProgs <$> getCabalCommandHelp (CabalCommandStr "install")
src/Distribution/Dev/InvokeCabal.hs view
@@ -7,6 +7,7 @@ ) where +import Control.Applicative ( (<$>) ) import Distribution.Verbosity ( Verbosity, showForCabal ) import Distribution.Simple.Program ( Program( programFindLocation ) , ConfiguredProgram@@ -17,8 +18,9 @@ , runProgram , simpleProgram )-import Distribution.Simple.Utils ( withUTF8FileContents, writeUTF8File- , debug, cabalVersion )+import Distribution.Simple.Utils ( writeUTF8File, debug, cabalVersion+ , readUTF8File )+import Distribution.ParseUtils ( ParseResult(..), Field, readFields ) import Distribution.Version ( Version(..) ) import System.Console.GetOpt ( OptDescr ) @@ -26,7 +28,9 @@ , CommandResult(..) ) import Distribution.Dev.Flags ( Config, getCabalConfig- , getVerbosity+ , getVerbosity, passthroughArgs+ , cfgCabalInstall, extraConfigFiles+ , useUserConfig ) import Distribution.Dev.InitPkgDb ( initPkgDb ) import qualified Distribution.Dev.RewriteCabalConfig as R@@ -41,61 +45,102 @@ , sandbox ) import Distribution.Dev.Utilities ( ensureAbsolute )+import Distribution.Dev.MergeCabalConfig ( mergeFields ) -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+ 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 -> 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 +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 ->- 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+ 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)- withUTF8FileContents cfgIn $ \cIn ->- do cfgRes <- R.rewriteCabalConfig rew cIn- case cfgRes of- Left err -> return $ Left $- "Error processing cabal config file " ++ cfgIn ++ ": " ++ err- Right cOut -> do- writeUTF8File cfgOut cOut- args <- extraArgs v cfgOut (getVersion s)- return $ Right args+ cOut = show $ R.ppTopLevel $ concat $+ R.rewriteCabalConfig rew $+ foldr (flip mergeFields) userFields (devFields:extraConfigs) -extraArgs :: Verbosity -> FilePath -> PackageDbType -> IO [String]+ 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+ 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 +152,7 @@ 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/MergeCabalConfig.hs view
@@ -0,0 +1,90 @@+{-|++Merge configuration files for Cabal (and cabal-install).++-}+module Distribution.Dev.MergeCabalConfig+ ( mergeFields+ )+where++import Data.Maybe ( fromMaybe )+import Control.Applicative ( Applicative, Alternative, pure, empty, (<|>), (<$>) )+import Distribution.ParseUtils ( Field(..) )++-- |Merge two lists of fields.+--+-- The fields from the second list are merged into the first list of+-- fields.+--+-- >>> mergeFields [F 1 "foo" "bar"] [F 2 "baz" "quux"]+-- [F 2 "baz" "quux", F 1 "foo" "bar"]+-- >>> mergeFields [F 1 "foo" "bar"] [F 2 "foo" "quux"]+-- [F 2 "foo" "quux"]+mergeFields :: [Field] -- ^Starting fields+ -> [Field] -- ^New fields+ -> [Field] -- ^Merged fields (preferring fields from the+ -- second argument)+mergeFields = foldr $ \f fs ->+ fromMaybe (f:fs) $ replace (mergeField mergeFields f) fs++-- |Attempt to merge two fields.+--+-- * Two fields can be merged if they have the same type and the same+-- identifiers.+-- * If two sections match, their fields are merged recursively.+-- * If two fields match, the value of the first field is taken.+--+-- >>> let m = mergeField mergeFields :: Field -> Field -> Maybe Field+-- >>> let fooF1 = F 1 "foo" "bar"+-- >>> let fooF2 = F 2 "foo" "baz"+-- >>> let fooSec1 = Section 3 "foo" "bar" [F 4 "a" "b"]+-- >>> let fooSec2 = Section 5 "foo" "bar" [F 6 "x" "y"]+-- >>> m fooF1 fooF2+-- Just (F 1 "foo" "bar")+-- >>> m fooF2 fooF1+-- Just (F 2 "foo" "baz")+-- >>> m fooF1 fooSec1+-- Nothing+-- >>> m fooSec1 fooF1+-- Nothing+-- >>> m fooSec1 fooSec2+-- Just (Section "foo" "bar" [F 2 "x" "y", F 1 "a" "b"])+-- >>> m fooSec2 fooSec1+-- Just (Section "foo" "bar" [F 1 "a" "b", F 2 "x" "y"])+mergeField :: (Applicative f, Alternative f) =>+ ([Field] -> [Field] -> [Field])+ -> Field -> Field -> f Field+mergeField _ (F l k v) (F _ k' _)+ | k == k' = pure $ F l k v+mergeField m (Section l n a fs') (Section _ n' a' fs'')+ | n == n' && a == a' = pure $ Section l n a $ m fs'' fs'+mergeField _ _ _+ = empty++-- | Attempt to replace a value in a list with a given a replacement+-- function.+--+-- The first value that does not yield 'empty' for the replacement+-- function is replaced by the value. At this point, the computation+-- short-circuits. If no value yields a replacement, empty is returned.+--+-- >>> replace (`lookup` [(3,5)]) [1..5] :: Maybe [Int]+-- Just [1,2,5,4,5]+-- >>> replace (`lookup` [(3,5)]) [3,3,3] :: Maybe [Int]+-- Just [5,3,3]+-- >>> replace (`lookup` [(11,5)]) [1..5] :: Maybe [Int]+-- Nothing+-- >>> replace (\x -> if x == 11 then [5,9] else []) [1..5] :: [[Int]]+-- []+-- >>> replace (\x -> if x == 3 then [5,9] else []) [1..5] :: [[Int]]+-- [[1,2,5,4,5],[1,2,9,4,5]]+-- >>> replace (const $ Just "hello") [undefined, "world"] :: Maybe [String]+-- Just ["hello","world"]+replace :: (Applicative f, Alternative f) => (a -> f a) -> [a] -> f [a]+replace f = go id+ where+ go _ [] = empty+ go acc (x:xs) = (rebuild <$> f x) <|> go (acc . (x:)) xs+ where+ rebuild x' = acc $ x' : xs
src/Distribution/Dev/RewriteCabalConfig.hs view
@@ -12,12 +12,17 @@ module Distribution.Dev.RewriteCabalConfig ( rewriteCabalConfig , Rewrite(..)+ , ppTopLevel+ , readConfigF+ , readConfigF_ ) where +import Control.Applicative ( Applicative, pure, (<$>) ) import Data.Maybe ( fromMaybe )-import Control.Monad ( liftM )-import Distribution.ParseUtils ( readFields, ParseResult(..), Field(..) )+import Data.Traversable ( traverse, Traversable )+import Distribution.ParseUtils ( Field(..), readFields, ParseResult(..) )+import Distribution.Simple.Utils ( readUTF8File ) import Text.PrettyPrint.HughesPJ data Rewrite = Rewrite { homeDir :: FilePath@@ -26,22 +31,31 @@ , quoteInstallDirs :: Bool } +readConfig :: String -> Either String [Field]+readConfig s = case readFields s of+ ParseOk _ fs -> Right fs+ ParseFailed e -> Left $ show e++-- XXX: we should avoid this lazy IO that leaks a file handle.+readConfigF :: FilePath -> IO (Either String [Field])+readConfigF fn =+ (readConfig <$> readUTF8File fn) `catch` \e -> return $ Left $ show e++readConfigF_ :: FilePath -> IO [Field]+readConfigF_ fn = either error id <$> readConfigF fn+ -- |Rewrite a cabal-install config file so that all paths are made -- absolute and canonical.-rewriteCabalConfig :: Rewrite -> String -> IO (Either String String)+rewriteCabalConfig :: Applicative f => Rewrite -> [Field] -> f [Field] rewriteCabalConfig r = rewriteConfig expand (setPackageDb $ packageDb r) where expand = expandCabalConfig (quoteInstallDirs r) (homeDir r) (sandboxDir r) -- |Given an expansion configuration, read the input config file and -- write the expansion into the output config file-rewriteConfig :: Expand IO -> ([Field] -> [Field]) -> String- -> IO (Either String String)-rewriteConfig expand proc s =- case readFields s of- ParseFailed err -> return $ Left $ show err- ParseOk _ fs ->- (Right . show . ppTopLevel . proc) `fmap` rewriteTopLevel expand fs+rewriteConfig :: Applicative f =>+ Expand f -> ([Field] -> [Field]) -> [Field] -> f [Field]+rewriteConfig expand proc fs = proc <$> rewriteTopLevel expand fs setPackageDb :: FilePath -> [Field] -> [Field] setPackageDb pkgDb = (F 0 "package-db" pkgDb:) . filter (not . isPackageDb)@@ -49,21 +63,21 @@ isPackageDb (F _ "package-db" _) = True isPackageDb _ = False -rewriteTopLevel :: Monad m => Expand m -> [Field] -> m [Field]-rewriteTopLevel = mapM . rewriteField+rewriteTopLevel :: Applicative f => Expand f -> [Field] -> f [Field]+rewriteTopLevel = traverse . rewriteField -rewriteField :: Monad m => Expand m -> Field -> m Field+rewriteField :: Applicative m => Expand m -> Field -> m Field rewriteField expand field = case field of- F l name val -> F l name `liftM` rewriteLeaf name val- Section l name key fs -> Section l name key `liftM`+ F l name val -> F l name <$> rewriteLeaf name val+ Section l name key fs -> Section l name key <$> rewriteSection name fs _ -> error $ "Only top-level fields and sections \ \supported. Not: " ++ show field where rewriteLeaf name val | name `elem` eLeaves expand = eExpand expand val- | otherwise = return val+ | otherwise = pure val rewriteSection s = rewriteTopLevel $ fromMaybe don'tExpand $@@ -84,9 +98,9 @@ -------------------------------------------------- -- Expanding fields -data Expand m = Expand { eExpand :: String -> m String+data Expand f = Expand { eExpand :: String -> f String , eLeaves :: [String]- , eSections :: [(String, Expand m)]+ , eSections :: [(String, Expand f)] } -- |Replace a tilde as an initial path segment with a path.@@ -102,8 +116,8 @@ _ -> s -- |Identity expansion-don'tExpand :: Monad m => Expand m-don'tExpand = Expand return [] []+don'tExpand :: Applicative f => Expand f+don'tExpand = Expand pure [] [] -- This is the part that's specific to the cabal-install config file: -- These are the parts of the config file that are paths into the@@ -114,12 +128,13 @@ -- -- If the cabal-install config file changes, or if this list is not -- complete, this code will have to be updated.-expandCabalConfig :: Bool -- ^Whether the install-dirs section of the+expandCabalConfig :: Applicative f =>+ Bool -- ^Whether the install-dirs section of the -- cabal config file will quote paths. -- Versions of cabal-install prior to 0.9 -- required quoting. Versions 0.9 and later -- forbit it.- -> FilePath -> FilePath -> Expand IO+ -> FilePath -> FilePath -> Expand f expandCabalConfig shouldQuote home sandbox = Expand { eExpand = ePath , eLeaves = [ "remote-repo-cache"@@ -160,4 +175,4 @@ quote | shouldQuote = fmap show | otherwise = id - ePath = return . expandDot sandbox . expandTilde home+ ePath = pure . expandDot sandbox . expandTilde home
+ src/Distribution/Dev/TH/DeriveCabalCommands.hs view
@@ -0,0 +1,130 @@+module Distribution.Dev.TH.DeriveCabalCommands+ ( getCabalCommands+ , deriveCabalCommands+ , mkCabalCommandsDef+ , optParseFlags+ )+where++import Control.Applicative ( (<$>), (<*>) )+import Data.Char ( toUpper )+import Language.Haskell.TH+import Distribution.Dev.InterrogateCabalInstall+ ( Option(..), OptionName(..), ArgType(..), CabalCommandStr, ccStr+ , optParseFlags, getCabalCommandHelp, getCabalCommands, Program+ , getCabalProgs+ )++mkLO :: Option -> Exp+mkLO (Option on ty) =+ let (cn, o) = case on of+ Short c -> ("Short", CharL c)+ LongOption s -> ("LongOption", StringL s)++ tyE = ConE $ mkName $+ case ty of+ Req -> "Req"+ Opt -> "Opt"+ NoArg -> "NoArg"++ nE = appC cn $ LitE o++ optC n t = AppE (appC "Option" n) t++ appC n = AppE $ ConE $ mkName n++ in optC nE tyE++mkSupportedOptionClause :: [Program] -> CabalCommandStr -> String -> Clause+mkSupportedOptionClause progs cStr helpOutput =+ let supportedFlags = ListE . map mkLO $+ optParseFlags progs helpOutput+ in Clause [ConP (commandConsName cStr) []] (NormalB supportedFlags) []++mkGetSupportedOptions :: [Program] -> [(CabalCommandStr, String)] -> [Dec]+mkGetSupportedOptions progs cs =+ let n = mkName "commandOptions"+ in [ SigD n $ ccT ~~> AppT ListT (ConT (mkName "Option"))+ , FunD n $ map (uncurry (mkSupportedOptionClause progs)) cs+ ]++mkGetSupportedOptionsIO :: [CabalCommandStr] -> IO [Dec]+mkGetSupportedOptionsIO ccs =+ (mkGetSupportedOptions <$> getCabalProgs)+ <*> (zip ccs <$> mapM getCabalCommandHelp ccs)++mkCabalCommandsDef :: [CabalCommandStr] -> IO [Dec]+mkCabalCommandsDef strs =+ do putStrLn "Interrogating cabal-install executable:"+ concat <$> mapM ($ strs)+ [ return . return . cabalCommandsDef+ , return . mkStrToCmd+ , return . mkCmdToStr+ , return . mkAllCommands+ , mkGetSupportedOptionsIO+ ]++deriveCabalCommands :: Q [Dec]+deriveCabalCommands = runIO $ mkCabalCommandsDef =<< getCabalCommands++mkAllCommands :: [CabalCommandStr] -> [Dec]+mkAllCommands cmds =+ let n = mkName "allCommands"+ in [ SigD n $ AppT ListT ccT+ , FunD n+ [ Clause [] (NormalB (ListE $ map (ConE . commandConsName) cmds)) []+ ]+ ]++ccL :: CabalCommandStr -> Lit+ccL = StringL . ccStr++mkCmdToStr :: [CabalCommandStr] -> [Dec]+mkCmdToStr =+ fromCommandClauses "commandToString" (ccT ~~> strT) $ map $ \n ->+ Clause [ConP (commandConsName n) []] (NormalB (LitE $ ccL n)) []++mkStrToCmd :: [CabalCommandStr] -> [Dec]+mkStrToCmd =+ fromCommandClauses "stringToCommand" (strT ~~> maybeT ccT) $ \ccs ->+ map toClause ccs ++ [nothing]+ where+ toClause n =+ Clause [LitP (ccL n)] (NormalB (justE $ ccE n)) []+ justE = AppE $ ConE $ mkName "Just"+ ccE = ConE . commandConsName+ nothing = Clause [WildP] (NormalB (ConE (mkName "Nothing"))) []++cabalCommandsDef :: [CabalCommandStr] -> Dec+cabalCommandsDef strs = DataD [] ccN [] (map cStrToCon strs) [mkName "Eq", mkName "Show"]++ccN :: Name+ccN = mkName "CabalCommand"++commandConsName :: CabalCommandStr -> Name+commandConsName = mkName . capitalize . ccStr+ where+ capitalize (c:cs) = toUpper c : cs+ capitalize [] = []++cStrToCon :: CabalCommandStr -> Con+cStrToCon c = NormalC (commandConsName c) []++fromCommandClauses :: String -> Type -> ([CabalCommandStr] -> [Clause])+ -> [CabalCommandStr] -> [Dec]+fromCommandClauses funName funTy mkClause cmdStrs =+ [ SigD n funTy, FunD n $ mkClause cmdStrs ]+ where+ n = mkName funName++(~~>) :: Type -> Type -> Type+t1 ~~> t2 = AppT (AppT ArrowT t1) t2++strT :: Type+strT = ConT $ mkName "String"++ccT :: Type+ccT = ConT ccN++maybeT :: Type -> Type+maybeT = AppT (ConT $ mkName "Maybe")
+ src/FakeGhc.hs view
@@ -0,0 +1,16 @@+{-|++Program to invoke "as ghc" in order to snoop the arguments that+cabal-install passes, so that we can use them to run ghci. This trick+was lifted from Leksah.++-}+module Main ( main ) where++import System.Environment ( getArgs )+import Distribution.Dev.GhcArgs ( formatGHCArgs )++-- |Take the command line arguments and format them in an+-- easily-parsed way.+main :: IO ()+main = putStr . formatGHCArgs =<< getArgs
src/Main.hs view
@@ -3,6 +3,8 @@ ( main ) where +import Data.Char ( isSpace, isLetter )+import Data.List ( intercalate, transpose ) import Data.Maybe ( listToMaybe ) import Data.Version ( showVersion ) import Control.Monad ( unless )@@ -11,6 +13,7 @@ import System.Console.GetOpt ( usageInfo, getOpt, ArgOrder(Permute) ) import Distribution.Simple.Utils ( cabalVersion, debug ) import Distribution.Text ( display )+import Control.Monad.Trans.State ( evalState, gets, modify ) import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) ) import Distribution.Dev.Flags ( parseGlobalFlags, helpRequested, globalOpts@@ -21,31 +24,58 @@ import qualified Distribution.Dev.Ghci as Ghci import qualified Distribution.Dev.InvokeCabal as InvokeCabal import qualified Distribution.Dev.InstallDependencies as InstallDeps+import qualified Distribution.Dev.BuildOpts as BuildOpts+import qualified Distribution.Dev.GhcPkg as GhcPkg+import qualified Distribution.Dev.CabalInstall as CI import Paths_cabal_dev ( version ) -allCommands :: [(String, CommandActions)]-allCommands = [ ("add-source", AddSource.actions)- , ("install-deps", InstallDeps.actions)- , ("ghci", Ghci.actions)- , cabal "build"- , cabal "clean"- , cabal "configure"- , cabal "copy"- , cabal "fetch"- , cabal "haddock"- , cabal "info"- , cabal "init"- , cabal "install"- , cabal "list"- , cabal "register"- , cabal "unpack"- , cabal "update"- , cabal "hscolour"- , cabal "sdist"- ]+import qualified Data.Map as Map++cabalDevCommands :: [(String, CommandActions, String)]+cabalDevCommands = [ ( "add-source"+ , AddSource.actions+ , "Make a package available for cabal-install to " +++ "install (in a sandbox-local Hackage repository). " +++ "Note that this command does NOT install the " +++ "package in the sandbox, and does require the " +++ "package to have a working sdist."+ )+ , ( "install-deps"+ , InstallDeps.actions+ , "Install the packages that depend on the specified " +++ "packages, but not the packages themselves. " +++ "(Equivalent to install --only-dependencies for " +++ "cabal-install > 0.10)"+ )+ , ( "ghci"+ , Ghci.actions+ , "Start ghci with the sandbox's GHC package " +++ "repository available. This command does not " +++ "yet take into account the contents of the .cabal " +++ "file (e.g. source directories, available packages " +++ "LANGUAGE pragmas)."+ )+ , ( "buildopts"+ , BuildOpts.actions+ , "Extract the options that would be passed to the " +++ "compiler when building"+ )+ , ( "ghc-pkg"+ , GhcPkg.actions+ , "Invoke ghc-pkg including the appropriate " +++ "--package-conf argument to run on the sandbox's " +++ "package database."+ )+ ]++cabalInstallCommands :: [(String, CommandActions)]+cabalInstallCommands = map cabal CI.allCommands where- cabal s = (s, InvokeCabal.actions s)+ cabal s = (CI.commandToString s, InvokeCabal.actions s) +allCommands :: [(String, CommandActions)]+allCommands = [(s, a) | (s, a, _) <- cabalDevCommands] ++ cabalInstallCommands+ printVersion :: IO () printVersion = do putStr versionString@@ -101,21 +131,22 @@ globalUsage :: IO String globalUsage = do progName <- getProgName+ let fmtCommands cmds =+ fmtTable " " [ [[""], [n], wrap 60 d] | (n, _, d) <- cmds ] let preamble = unlines $ [ "" , "Usage: " ++ progName ++ " <command>" , "" , "Where <command> is one of:"- ] ++ map (" " ++) allCommandNames +++ ] ++ fmtCommands cabalDevCommands ++ [ ""- , "Options:"+ , "or any cabal-install command (see cabal --help for documentation)."+ , ""+ , "Options to cabal-dev:" ] return $ usageInfo preamble globalOpts -allCommandNames :: [String]-allCommandNames = map fst allCommands- nameCmd :: String -> Maybe CommandActions nameCmd s = listToMaybe [a | (n, a) <- allCommands, n == s] @@ -140,3 +171,90 @@ in if null cmdErrs then r cfg cmdFlags cmdArgs else showError cmdErrs++-- |Format a table+fmtTable :: String -- ^Column separator+ -> [[[String]]] -- ^Table rows (each cell may have more than+ -- one line)+ -> [String] -- ^Lines of output+fmtTable colSep rows = map fmtLine $ fmtRow =<< rows+ where+ fmtRow cs = transpose $ map (pad [] (maximum $ map length cs)) cs+ fmtLine l = intercalate colSep $ zipWith (pad ' ') widths l+ widths = map (maximum . map length . concat) $ transpose rows+ pad c w s = take w $ s ++ repeat c++-- |Wrap a String of text to lines shorter than the specified number.+--+-- This function has heuristics for human-readability, such as+-- avoiding splitting in the middle of words when possible.+wrap :: Int -- ^Maximum line length+ -> String -- ^Text to wrap+ -> [String] -- ^Wrapped lines+wrap _ "" = []+wrap w orig = snd $ evalState (go 0 orig) Map.empty+ where+ go loc s = do+ precomputed <- gets $ Map.lookup loc+ case precomputed of+ Nothing -> bestAnswer loc =<< mapM (scoreSplit loc) (splits w s)+ Just answer -> return answer++ scoreSplit loc (offset, lineScore, line, s') =+ case s' of+ "" -> return (lineScore, [line])+ _ -> do+ (restScore, lines_) <- go (loc + offset) s'+ return (lineScore + restScore, line:lines_)++ bestAnswer _ [] = error "No splits found!"+ bestAnswer loc answers = do+ let answer = minimum answers+ modify $ Map.insert loc answer+ return answer++-- Find all the locations that make sense to split the next line, and+-- score them.+splits :: Int -> String -> [(Int, Int, String, String)]+splits w s = map (\k -> score k $ splitAt k s) [w - 1,w - 2..1]+ where+ score k ([], cs) = (k, w * w, [], cs)+ score k (r, []) = (k, 0, r, [])+ score k (r, cs@(c:_)) = let (sps, cs') = countDropSpaces 0 cs+ spaceLeft = w - length r+ in ( -- How much of the string was consumed?+ k + sps++ -- How much does it cost to split here?+ , penalty (last r) c + spaceLeft * spaceLeft++ -- The text of the line that results+ -- from this split+ , r++ -- The text that has not yet been split+ , cs'+ )++ countDropSpaces i (c:cs) | isSpace c = countDropSpaces (i + 1) cs+ countDropSpaces i cs = (i, cs)++ -- Characters that want to stick to non-whitespace characters to+ -- their right+ rbind = (`elem` "\"'([<")++ -- How much should it cost to make a split between these+ -- characters?+ penalty b c+ -- Don't penalize boundaries between space and non-space+ | not (isSpace b) && isSpace c = 0+ | isSpace b && not (isSpace c) = 2+ | rbind b && not (isSpace c) = w `div` 2+ -- Penalize splitting a word heavily+ | isLetter b && isLetter c = w * 2+ -- Prefer splitting after a letter if it's not+ -- followed by a letter+ | isLetter c = 3+ -- Other kinds of splits are not as bad as splitting+ -- between words, but are still pretty harmful.+ | otherwise = w
test/RunTests.hs view
@@ -27,7 +27,7 @@ import Distribution.Text ( simpleParse, display ) import Distribution.Verbosity ( normal, Verbosity, showForCabal, verbose ) import Distribution.Version ( Version(..) )-import Distribution.Dev.Flags ( parseGlobalFlags )+import Distribution.Dev.Flags ( parseGlobalFlags, GlobalFlag(CabalInstallArg) ) import Distribution.Dev.InitPkgDb ( initPkgDb ) import Distribution.Dev.Sandbox ( newSandbox, pkgConf, Sandbox, KnownVersion, sandbox, indexTar ) import System.IO ( withBinaryFile, IOMode(ReadMode) )@@ -51,18 +51,18 @@ import Data.Function ( on ) -tests :: FilePath -> [Test]-tests p =+tests :: Verbosity -> FilePath -> [Test]+tests v p = [ testGroup "Basic invocation tests" $ testBasicInvocation p , testGroup "Sandboxed" $ [ testCase "add-source stays sandboxed (no-space dir)" $- addSourceStaysSandboxed normal p "fake-package."+ addSourceStaysSandboxed v p "fake-package." , testCase "add-source stays sandboxed (dir with spaces)" $- addSourceStaysSandboxed normal p "fake package."+ addSourceStaysSandboxed v p "fake package." , testCase "Builds ok regardless of the state of the logs directory" $- assertLogLocationOk normal p+ assertLogLocationOk v p , testCase "Index tar files contain all contents" $- assertTarFileOk normal p+ assertTarFileOk v p ] , testGroup "Parsing and serializing" $ [ testCase "simple round-trip test" $@@ -102,7 +102,7 @@ (x:xs) -> (x, xs) [] -> ("cabal-dev", []) - defaultMainWithArgs (tests cabalDev) testFrameworkArgs+ defaultMainWithArgs (tests normal cabalDev) testFrameworkArgs -- |Test that parsing and serializing a cabal-install SavedConfig with -- spaces in the paths preserves the spaces properly.@@ -172,7 +172,7 @@ -- command line arg parser (and then, presumably, to cabal-install). -- Created due to issue 6: https://github.com/creswick/cabal-dev/issues#issue/6 assertShortFlags :: HUnit.Assertion-assertShortFlags = (parseGlobalFlags $ words "install -f-curl") @?= ([],["install", "-f-curl"],[])+assertShortFlags = (parseGlobalFlags $ words "install -f-curl") @?= ([CabalInstallArg "-f-curl"],["install"],[]) fst3 :: (a, b, c) -> a fst3 (x, _, _) = x@@ -279,6 +279,7 @@ let lsMsg msg = when (v >= verbose) $ do putStrLn msg+ print ("ls", ["-ld", logsPth]) _ <- rawSystem "ls" ["-ld", logsPth] return () let withCabalDev f aa = do