Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Branch: master
Fetching contributors…

Cannot retrieve contributors at this time

94 lines (81 sloc) 3.087 kB
module Main where
import CmdDB
import Control.Applicative
import Control.Exception
import Control.Monad
import Data.Maybe
import Prelude hiding (catch)
import System.Cmd
import System.Console.GetOpt
import System.Environment
import System.Exit
import Env
import Types
import Utils
----------------------------------------------------------------
main :: IO ()
main = flip catches handlers $ do
unsetEnv "GHC_PACKAGE_PATH"
oargs <- getArgs
let pargs = parseArgs getOptDB oargs
checkOptions1 pargs illegalOptionsAndExit
let Right (args,opts0) = pargs
when (args == []) helpAndExit
when (OptHelp `elem` opts0) $ helpCommandAndExit undefined args undefined
let opts1 = filter (/= OptHelp) opts0
act:params = args
mcmdspec = commandSpecByName act commandDB
when (isNothing mcmdspec) (illegalCommandAndExit act)
let Just cmdspec = mcmdspec
checkOptions2 opts1 cmdspec oargs illegalOptionsAndExit
opts <- sandboxEnv cmdspec opts1
run cmdspec params opts
where
handlers = [Handler handleExit]
handleExit :: ExitCode -> IO ()
handleExit _ = return ()
----------------------------------------------------------------
parseArgs :: [GetOptSpec] -> [Arg] -> ParsedArgs
parseArgs db args = case getOpt' Permute db args of
(o,n,[],[]) -> Right (n,o)
(_,_,unknowns,_) -> Left unknowns
checkOptions1 :: ParsedArgs -> ([UnknownOpt] -> IO ()) -> IO ()
checkOptions1 (Left es) func = func es
checkOptions1 _ _ = return ()
checkOptions2 :: [Option] -> CommandSpec -> [Arg] -> ([UnknownOpt] -> IO ()) -> IO ()
checkOptions2 opts cmdspec oargs func = do
let unknowns = check specified supported
when (unknowns /= []) $ func (concatMap (resolveOptionString oargs) unknowns)
where
check [] _ = []
check (x:xs) ys
| x `elem` ys = check xs ys
| otherwise = x : check xs ys
specified = map toSwitch opts
supported = map fst $ switches cmdspec
sandboxEnv :: CommandSpec -> [Option] -> IO [Option]
sandboxEnv cmdspec opts =
if hasSandboxOption cmdspec && command cmdspec /= Env
then tryEnv `catch` ignore
else return opts
where
tryEnv = (\path -> OptSandbox path : opts) <$> getEnv cabEnvVar
ignore :: SomeException -> IO [Option]
ignore _ = return opts
hasSandboxOption :: CommandSpec -> Bool
hasSandboxOption cmdspec = isJust $ lookup SwSandbox (switches cmdspec)
----------------------------------------------------------------
run :: CommandSpec -> [Arg] -> [Option] -> IO ()
run cmdspec params opts = case routing cmdspec of
RouteFunc func -> func cmdspec params opts
RouteCabal subargs -> callProcess pro subargs params opts sws
where
pro = cabalCommand opts
sws = switches cmdspec
callProcess :: String -> [String] -> [Arg] -> [Option] -> [SwitchSpec] -> IO ()
callProcess pro args0 args1 opts sws = system script >> return ()
where
swchs = optionsToString opts sws
script = joinBy " " $ pro : args0 ++ cat args1 ++ swchs
cat [pkg,ver] = [pkg ++ "-" ++ ver]
cat x = x
Jump to Line
Something went wrong with that request. Please try again.