File: Defaults.hs

package info (click to toggle)
darcs 2.12.4-2
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 5,748 kB
  • sloc: haskell: 42,936; sh: 11,086; ansic: 837; perl: 129; makefile: 8
file content (242 lines) | stat: -rw-r--r-- 9,674 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
module Darcs.UI.Defaults ( applyDefaults ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad.Writer
import Data.Char ( isSpace )
import Data.Functor.Compose ( Compose(..) )
import Data.List ( nub, intercalate )
import Data.Maybe ( catMaybes )
import qualified Data.Map as M
import System.Console.GetOpt
import Text.Regex.Applicative
    ( (<|>)
    , match, 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.Util.Path ( AbsolutePath )

-- | Apply defaults from all sources to a list of 'DarcsFlag's (e.g. from the
-- command line), given the command (and possibly super command) name, and a
-- list of all options for the command.
-- 
-- Sources for defaults are
-- 
--  * the builtin (hard-coded) defaults,
-- 
--  * the defaults file in the user's configuration, and
-- 
--  * the defaults file in the current repository.
-- 
-- Note that the pseudo command @ALL@ is allowed in defaults files to specify
-- that an option should be the default for all commands to which it applies.
-- 
-- The order of precedence for conflicting options (i.e. those belonging to
-- same group of mutually exclusive options) is from less specific to more
-- specific. In other words, options from the command line override all
-- defaults, per-repo defaults override per-user defaults, which in turn
-- override the built-in defaults. Inside the options from a defaults file,
-- options for the given command override options for the @ALL@ pseudo command.
-- 
-- Conflicting options at the same level of precedence are not allowed.
--
-- Errors encountered during processing of command line or defaults flags
-- are formatted and added as (separate) strings to the list of error messages
-- that are returned together with the resulting flag list.
applyDefaults :: Maybe String
              -> DarcsCommand pf
              -> AbsolutePath
              -> [String]
              -> [String]
              -> [DarcsFlag]
              -> ([DarcsFlag], [String])
applyDefaults msuper cmd cwd user repo flags = runWriter $ do
    cl_flags  <- runChecks "Command line" check_opts flags
    user_defs <- get_flags "User defaults" user
    repo_defs <- get_flags "Repo defaults" repo
    return $ cl_flags ++ repo_defs ++ user_defs ++ builtin_defs
  where
    cmd_name = mkCmdName msuper (commandName cmd)
    builtin_defs = commandDefaults cmd
    check_opts = commandCheckOptions cmd
    opts = uncurry (++) $ commandAlloptions cmd
    get_flags source = parseDefaults source cwd cmd_name opts check_opts

-- | Name of a normal command, or name of super and sub command.
data CmdName = NormalCmd String | SuperCmd String String

-- | Make a 'CmdName' from a possible super command name and a sub command name.
mkCmdName :: Maybe String -> String -> CmdName
mkCmdName Nothing cmd = NormalCmd cmd
mkCmdName (Just super) sub = SuperCmd super sub

-- | Turn a 'CmdName' into a 'String'. For a 'SuperCmd' concatenate with a space in between.
showCmdName :: CmdName -> String
showCmdName (SuperCmd super sub) = unwords [super,sub]
showCmdName (NormalCmd name) = name

runChecks :: String -> ([DarcsFlag] -> [String]) -> [DarcsFlag] -> Writer [String] [DarcsFlag]
runChecks source check fs = case check fs of
  [] -> return fs
  es -> do
    tell [intercalate "\n" $ map ((source++": ")++) es]
    return fs

-- | Parse a list of lines from a defaults file, returning a list of 'DarcsFlag',
-- given the current working directory, the command name, and a list of 'DarcsOption'
-- for the command.
--
-- In the result, defaults for the given command come first, then come defaults
-- for @ALL@ commands.
--
-- We check that matching options actually exist.
--
--  * lines matching the command name: the option must exist in the command's
--    option map.
--
--  * lines matching @ALL@: there must be at least *some* darcs command with
--    that option.
--
-- It is debatable whether these checks are useful. On the one hand they can help
-- detect typos in defaults files. On the other hand they make it difficult to
-- use different versions of darcs in parallel: a default for an option that is
-- only available in a later version will make the earlier version produce an
-- error. Maybe reduce this to a warning?
parseDefaults :: String
              -> AbsolutePath
              -> CmdName
              -> [DarcsOptDescr DarcsFlag]
              -> ([DarcsFlag] -> [String])
              -> [String]
              -> Writer [String] [DarcsFlag]
parseDefaults source cwd cmd opts check_opts def_lines = do
    cmd_flags <- flags_for (M.keys opt_map) cmd_defs >>=
      runChecks (source++" for command '"++showCmdName cmd++"'") check_opts
    all_flags <- flags_for allOptionSwitches all_defs >>=
      runChecks (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 do
        tell [source++": command '"++showCmdName cmd
             ++"' has no option '"++switch++"'."]
        return Nothing
      else
        mapErrors ((source++" for command '"++showCmdName cmd++"':"):)
          $ defaultToFlag cwd opt_map (switch,arg)
    -- the catMaybes filters out options that are not defined
    -- for this command
    flags_for all_switches = fmap catMaybes . mapM (to_flag all_switches)
    mapErrors f = mapWriter (\(r, es) -> (r, if null es then [] else f es))

-- | Result of parsing a defaults line: switch and argument(s).
type Default = (String, String)

-- | Extract 'Default's from lines of a defaults file that match the given 'CmdName'.
-- 
-- The syntax is
--
-- @
--  supercmd subcmd [--]switch [args...]
-- @
--
-- for (super) commands with a sub command, and
--
-- @
--  cmd default [--]default [args...]
-- @
--
-- for normal commands (including the @ALL@ pseudo command).
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 ""

{- $note
This definition is a bit simpler, and doesn't need Text.Regex.Applicative,
but it has two disadvantages over the one above:

 * Flag arguments are split and joined again with words/unwords, which means
   that whitespace inside an argument is not preserved literally.

 * It is less easily extendable with new syntax.

> parseDefaultsLines :: CmdName -> [String] -> [(String, String)]
> parseDefaultsLines name entries = case name of
>     SuperCmd super sub -> [ mk_def d as | (s:c:d:as) <- map words entries, s == super, c == sub ]
>     NormalCmd cmd ->      [ mk_def d as | (c:d:as) <- map words entries, c == cmd ]
>   where
>     mk_def d as = (drop_dashes d, unwords as)
>     drop_dashes ('-':'-':switch) = switch
>     drop_dashes switch = switch
-}

-- | Search an option list for a switch. If found, apply the flag constructor
-- from the option to the arg, if any. The first parameter is the current working
-- directory, which, depending on the option type, may be needed to create a flag
-- from an argument.
-- 
-- Fails if (default has argument /= corresponding option has argument).
defaultToFlag :: AbsolutePath
              -> OptionMap
              -> Default
              -> Writer [String] (Maybe DarcsFlag)
defaultToFlag cwd opts (switch, arg) = case M.lookup switch opts of
    -- This case is not impossible! A default flag defined for ALL commands
    -- is not necessarily defined for the concrete command in question.
    Nothing -> return Nothing
    Just opt -> flag_from $ getArgDescr $ getCompose opt
  where
    getArgDescr (Option _ _ a _) = a
    flag_from (NoArg mkFlag) = do
      if not (null arg) then do
        tell ["'"++switch++"' takes no argument, but '"++arg++"' argument given."]
        return Nothing
      else
        return $ Just $ mkFlag cwd
    flag_from (OptArg mkFlag _) =
      return $ Just $ mkFlag (if null arg then Nothing else Just arg) cwd
    flag_from (ReqArg mkFlag _) = do
      if null arg then do
        tell ["'"++switch++"' requires an argument, but no "++"argument given."]
        return Nothing
      else
        return $ Just $ mkFlag arg cwd

-- | Get all the longSwitches from a list of options.
optionSwitches :: [DarcsOptDescr DarcsFlag] -> [String]
optionSwitches = concatMap sel where
  sel (Compose (Option _ switches _ _)) = switches

-- | A finite map from long switches to 'DarcsOptDescr's.
type OptionMap = M.Map String (DarcsOptDescr DarcsFlag)

-- | Build an 'OptionMap' from a list of 'DarcsOption's.
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

-- | List of option switches of all commands (except help but that has no options).
allOptionSwitches :: [String]
allOptionSwitches = nub $ optionSwitches $
  concatMap (\(WrappedCommand c) -> uncurry (++) . commandAlloptions $ c) $
            extractAllCommands commandControlList