module Darcs.UI.Defaults ( applyDefaults ) where
import Data.Char ( isSpace )
import Data.Functor.Compose ( Compose(..) )
import Data.List ( nub )
import Data.Maybe ( catMaybes )
import qualified Data.Map as M
import System.Console.GetOpt
import System.IO ( stderr, hPutStrLn )
import System.Exit ( exitFailure )
import Text.Regex.Applicative
( (<$>), (<*>), (*>), (<|>)
, match, pure, many, some
, psym, anySym, string )
import Darcs.UI.Flags ( DarcsFlag )
import Darcs.UI.Options ( DarcsOptDescr )
import Darcs.UI.Commands
( DarcsCommand(..), commandAlloptions, extractAllCommands
, WrappedCommand(..)
)
import Darcs.UI.TheCommands ( commandControlList )
import Darcs.Repository.Prefs ( getGlobal, getPreflist )
import Darcs.Util.Path
( AbsolutePath
, getCurrentDirectory )
applyDefaults :: Maybe String
-> DarcsCommand pf
-> [DarcsFlag]
-> IO [DarcsFlag]
applyDefaults msuper cmd flags = do
cwd <- getCurrentDirectory
let cmd_name = mkCmdName msuper (commandName cmd)
builtin_defs = commandDefaults cmd
check_opts = commandCheckOptions cmd
opts = uncurry (++) $ commandAlloptions cmd
get_flags source = handleEither . parseDefaults source cwd cmd_name opts check_opts
handleEither (Left err) = hPutStrLn stderr err >> exitFailure
handleEither (Right x) = return x
cl_flags <- handleEither $ checkConflictingOptions "command line" check_opts flags
user_defs <- getGlobal "defaults" >>= get_flags "user defaults"
repo_defs <- getPreflist "defaults" >>= get_flags "repo defaults"
return $ cl_flags ++ repo_defs ++ user_defs ++ builtin_defs
data CmdName = NormalCmd String | SuperCmd String String
mkCmdName :: Maybe String -> String -> CmdName
mkCmdName Nothing cmd = NormalCmd cmd
mkCmdName (Just super) sub = SuperCmd super sub
showCmdName :: CmdName -> String
showCmdName (SuperCmd super sub) = unwords [super,sub]
showCmdName (NormalCmd name) = name
checkConflictingOptions :: String -> ([DarcsFlag] -> [String]) -> [DarcsFlag] -> Either String [DarcsFlag]
checkConflictingOptions source check fs = case check fs of
[] -> Right fs
es -> Left $ unlines (source:es)
parseDefaults :: String
-> AbsolutePath
-> CmdName
-> [DarcsOptDescr DarcsFlag]
-> ([DarcsFlag] -> [String])
-> [String]
-> Either String [DarcsFlag]
parseDefaults source cwd cmd opts check_opts def_lines = do
cmd_flags <- flags_for (M.keys opt_map) cmd_defs >>=
checkConflictingOptions (source++" for command '"++showCmdName cmd++"'") check_opts
all_flags <- flags_for allOptionSwitches all_defs >>=
checkConflictingOptions (source++" for ALL commands") check_opts
return $ cmd_flags ++ all_flags
where
opt_map = optionMap opts
cmd_defs = parseDefaultsLines cmd def_lines
all_defs = parseDefaultsLines (NormalCmd "ALL") def_lines
to_flag all_switches (switch,arg) =
if switch `notElem` all_switches then
Left $ "Bad default option in "++source++": command '"++showCmdName cmd
++"' has no option '"++switch++"'."
else
defaultToFlag cwd opt_map (switch,arg)
flags_for all_switches = fmap catMaybes . mapM (to_flag all_switches)
type Default = (String, String)
parseDefaultsLines :: CmdName -> [String] -> [Default]
parseDefaultsLines cmd = catMaybes . map matchLine
where
matchLine = match $ (,) <$> (match_cmd cmd *> spaces *> opt_dashes *> word) <*> rest
match_cmd (NormalCmd name) = string name
match_cmd (SuperCmd super sub) = string super *> spaces *> string sub
opt_dashes = string "--" <|> pure ""
word = some $ psym (not.isSpace)
spaces = some $ psym isSpace
rest = spaces *> many anySym <|> pure ""
defaultToFlag :: AbsolutePath
-> OptionMap
-> Default
-> Either String (Maybe DarcsFlag)
defaultToFlag cwd opts (switch, arg) = case M.lookup switch opts of
Nothing -> Right Nothing
Just opt -> fmap Just $ flag_from $ getArgDescr $ getCompose opt
where
getArgDescr (Option _ _ a _) = a
flag_from (NoArg mkFlag) =
if null arg then
Right $ mkFlag cwd
else
Left $ "Bad default option: '"++switch++"' takes no argument, but '"++arg++"' argument given."
flag_from (OptArg mkFlag _) =
Right $ mkFlag (if null arg then Nothing else Just arg) cwd
flag_from (ReqArg mkFlag _) =
if null arg then
Left $ "Bad default option: '"++switch++"' requires an argument, but no "++"argument given."
else
Right $ mkFlag arg cwd
optionSwitches :: [DarcsOptDescr DarcsFlag] -> [String]
optionSwitches = concatMap sel where
sel (Compose (Option _ switches _ _)) = switches
type OptionMap = M.Map String (DarcsOptDescr DarcsFlag)
optionMap :: [DarcsOptDescr DarcsFlag] -> OptionMap
optionMap = M.fromList . concatMap sel where
add_option opt switch = (switch, opt)
sel o@(Compose (Option _ switches _ _)) = map (add_option o) switches
allOptionSwitches :: [String]
allOptionSwitches = nub $ optionSwitches $
concatMap (\(WrappedCommand c) -> uncurry (++) . commandAlloptions $ c) $
extractAllCommands commandControlList