Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Already on GitHub? Sign in to your account

Allow selection of the appropriate target context for ghci invocation. #70

Merged
merged 1 commit into from May 28, 2013
Jump to file or symbol
Failed to load files and symbols.
+55 −14
Split
@@ -2,12 +2,14 @@ module Distribution.Dev.Ghci
( actions )
where
+import Control.Applicative ( (<$>), (<|>) )
+import Data.List ( stripPrefix )
import Distribution.Simple.Program ( emptyProgramConfiguration
, runProgram
, requireProgram
, ghcProgram
)
-import System.Console.GetOpt ( OptDescr )
+import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) )
import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) )
import Distribution.Dev.Flags ( Config, getVerbosity )
@@ -16,22 +18,61 @@ import Distribution.Dev.BuildOpts ( getBuildArgs )
actions :: CommandActions
actions = CommandActions
{ cmdDesc = "Run ghci configured as per the specified cabal file."
- , cmdRun = \cfg _ args -> invokeGhci cfg args
- , cmdOpts = [] :: [OptDescr ()]
+ , cmdRun = \cfg opts args -> invokeGhci cfg opts args
+ , cmdOpts = [ Option "t" ["target"] (ReqArg id "TARGET") $
+ "Use TARGET executable or test suite's context " ++
+ "instead of the package."
+ ]
, cmdPassFlags = True
}
-invokeGhci :: Config -> [String] -> IO CommandResult
-invokeGhci cfg args = do
+invokeGhci :: Config -> [String] -> [String] -> IO CommandResult
+invokeGhci cfg opts args = do
let v = getVerbosity cfg
+ let target = foldl (const Just) Nothing opts
res <- getBuildArgs cfg args
- case res of
+
+ case res >>= selectArgs target 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"
+ 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
+
+-- |Select the GHC arguments for a given target if specified, the
+-- package arguments if the package target is configured, or the first
+-- set otherwise.
+selectArgs :: Maybe String -> [[String]] -> Either String [String]
+selectArgs targetName argsList = do
+ byTarget <- argsByTarget argsList
+ case targetName of
+ Just t -> case lookup (Executable t) byTarget of
+ Just as -> Right as
+ Nothing -> Left ("No target " ++ t ++ " defined")
+ Nothing -> case lookup Package byTarget of
+ Just as -> Right as
+ Nothing -> case byTarget of
+ (x:_) -> Right $ snd x
+ [] -> Left "Failed to extract GHC build arguments"
+
+data Target = Package | Executable String
+ deriving Eq
+
+argsByTarget :: [[String]] -> Either String [(Target, [String])]
+argsByTarget = mapM (\a -> fmap (flip (,) a) $ inferTarget a)
+ where inferTarget args = case exec args <|> package args of
+ Just t -> Right t
+ Nothing -> Left "Failed to infer target for GHC build arguments"
+
+ exec args =
+ case break (== "-o") args of
+ (_, _:path:_) -> Executable . takeWhile (/= '/') <$>
+ stripPrefix "dist/build/" path
+ (_, _) -> Nothing
+ package args =
+ case break (== "-package-name") args of
+ (_, _:_pkg:_) -> Just Package
+ (_, _) -> Nothing