{- Copyright (c) 2010 Galois, Inc -}
module Main
( main )
where
import Data.Char ( isSpace, isLetter )
import Data.List ( intercalate, transpose )
import Data.Maybe ( listToMaybe )
import Data.Version ( showVersion )
import Control.Monad ( unless )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName )
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
, GlobalFlag(Version), getOpt'', fromFlags
, getVerbosity, Config
)
import qualified Distribution.Dev.AddSource as AddSource
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 )
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 = (CI.commandToString s, InvokeCabal.actions s)
allCommands :: [(String, CommandActions)]
allCommands = [(s, a) | (s, a, _) <- cabalDevCommands] ++ cabalInstallCommands
printVersion :: IO ()
printVersion = do
putStr versionString
exitWith ExitSuccess
versionString :: String
versionString = unlines $
[ "cabal-dev " ++ showVersion version
, "built with Cabal " ++ display cabalVersion
]
printNumericVersion :: IO ()
printNumericVersion = do
putStrLn $ showVersion version
exitWith ExitSuccess
main :: IO ()
main = do
(globalFlags, args, errs) <- parseGlobalFlags `fmap` getArgs
unless (null errs) $ do
mapM_ putStrLn errs
putStr =<< globalUsage
exitWith (ExitFailure 1)
case [f|(Version f) <- globalFlags] of
(True:_) -> printNumericVersion
(False:_) -> printVersion
[] -> return ()
let cfg = fromFlags globalFlags
debug (getVerbosity cfg) versionString
case args of
(name:args') ->
case nameCmd name of
Just cmdAct | helpRequested globalFlags ->
do putStrLn $ cmdDesc cmdAct
putStr =<< globalUsage
exitWith ExitSuccess
| otherwise -> runCmd cmdAct cfg args'
Nothing -> do putStrLn $ "Unknown command: " ++ show name
putStr =<< globalUsage
exitWith (ExitFailure 1)
_ | helpRequested globalFlags -> do
putStr =<< globalUsage
exitWith ExitSuccess
| otherwise -> do
putStrLn "Missing command name"
putStr =<< globalUsage
exitWith (ExitFailure 1)
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:"
] ++ fmtCommands cabalDevCommands ++
[ ""
, "or any cabal-install command (see cabal --help for documentation)."
, ""
, "Options to cabal-dev:"
]
return $ usageInfo preamble globalOpts
nameCmd :: String -> Maybe CommandActions
nameCmd s = listToMaybe [a | (n, a) <- allCommands, n == s]
runCmd :: CommandActions -> Config -> [String] -> IO ()
runCmd cmdAct cfg args =
do res <- run
case res of
CommandOk -> exitWith ExitSuccess
CommandError msg -> showError [msg]
where
showError msgs = do
putStr $ unlines $ "FAILED:":msgs ++ [replicate 50 '-', cmdDesc cmdAct]
putStr =<< globalUsage
exitWith (ExitFailure 1)
run = case cmdAct of
(CommandActions _ r o passFlags) ->
let (cmdFlags, cmdArgs, cmdErrs) =
if passFlags
then getOpt'' o args
else getOpt Permute o args
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