content: {- Copyright (c) 2011 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, getEnv )
  import System.IO.Error ( catchIOError )
  import System.SetEnv (setEnv)
  import System.FilePath ((</>), searchPathSeparator)
  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, getSandbox, getEnvVars
                                )
  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
    envConf <- getEnvVars
    (globalFlags, args, errs) <- parseGlobalFlags `fmap` getArgs
    unless (null errs) $ do
           mapM_ putStrLn errs
           putStr =<< globalUsage
           exitWith (ExitFailure 1)
  
    let cfg = fromFlags envConf globalFlags
  
    -- add sandbox bin dir to PATH, so that custom preprocessors that are
    -- installed into the sandbox are found
    let binDir = getSandbox cfg </> "bin"
    mPath <- maybeGetEnv "PATH"
    let path = maybe binDir ((binDir ++ [searchPathSeparator]) ++) mPath
    setEnv "PATH" path
  
    case [f|(Version f) <- globalFlags] of
      (True:_) -> printNumericVersion
      (False:_) -> printVersion
      [] -> return ()
  
    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
  
  -- Return the value of the environment variable with the given name
  -- or Nothing if the variable is not defined.
  -- Probably should be replaced with System.Environment.lookupEnv
  -- when the base library is upgraded >= 4.6
  maybeGetEnv :: String -> IO (Maybe String)
  maybeGetEnv name = (Just `fmap` getEnv name) `catchIOError` const (return Nothing)
  