← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to compiler/main/CmdLineParser.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
compiler/main/CmdLineParser.hs
 
1
-----------------------------------------------------------------------------
 
2
--
 
3
-- Command-line parser
 
4
--
 
5
-- This is an abstract command-line parser used by both StaticFlags and
 
6
-- DynFlags.
 
7
--
 
8
-- (c) The University of Glasgow 2005
 
9
--
 
10
-----------------------------------------------------------------------------
 
11
 
 
12
module CmdLineParser (
 
13
        processArgs, OptKind(..),
 
14
        CmdLineP(..), getCmdLineState, putCmdLineState,
 
15
        Flag(..), 
 
16
        errorsToGhcException,
 
17
 
 
18
        EwM, addErr, addWarn, getArg, liftEwM, deprecate
 
19
  ) where
 
20
 
 
21
#include "HsVersions.h"
 
22
 
 
23
import Util
 
24
import Outputable
 
25
import Panic
 
26
import Bag
 
27
import SrcLoc
 
28
 
 
29
import Data.List
 
30
 
 
31
--------------------------------------------------------
 
32
--         The Flag and OptKind types
 
33
--------------------------------------------------------
 
34
 
 
35
data Flag m = Flag
 
36
    {   flagName    :: String,       -- Flag, without the leading "-"
 
37
        flagOptKind :: OptKind m     -- What to do if we see it
 
38
    }
 
39
 
 
40
-------------------------------
 
41
data OptKind m                      -- Suppose the flag is -f
 
42
 = NoArg     (EwM m ())                 -- -f all by itself
 
43
 | HasArg    (String -> EwM m ())       -- -farg or -f arg
 
44
 | SepArg    (String -> EwM m ())       -- -f arg
 
45
 | Prefix    (String -> EwM m ())       -- -farg
 
46
 | OptPrefix (String -> EwM m ())       -- -f or -farg (i.e. the arg is optional)
 
47
 | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn
 
48
 | IntSuffix (Int -> EwM m ())          -- -f or -f=n; pass n to fn
 
49
 | PassFlag  (String -> EwM m ())       -- -f; pass "-f" fn
 
50
 | AnySuffix (String -> EwM m ())       -- -f or -farg; pass entire "-farg" to fn
 
51
 | PrefixPred    (String -> Bool) (String -> EwM m ())
 
52
 | AnySuffixPred (String -> Bool) (String -> EwM m ())
 
53
 
 
54
 
 
55
--------------------------------------------------------
 
56
--         The EwM monad 
 
57
--------------------------------------------------------
 
58
 
 
59
type Err   = Located String
 
60
type Warn  = Located String
 
61
type Errs  = Bag Err
 
62
type Warns = Bag Warn
 
63
 
 
64
-- EwM (short for "errors and warnings monad") is a
 
65
-- monad transformer for m that adds an (err, warn) state
 
66
newtype EwM m a = EwM { unEwM :: Located String     -- Current arg
 
67
                              -> Errs -> Warns
 
68
                              -> m (Errs, Warns, a) }
 
69
 
 
70
instance Monad m => Monad (EwM m) where
 
71
  (EwM f) >>= k = EwM (\l e w -> do { (e', w', r) <- f l e w 
 
72
                                    ; unEwM (k r) l e' w' })
 
73
  return v = EwM (\_ e w -> return (e, w, v))
 
74
 
 
75
setArg :: Located String -> EwM m a -> EwM m a
 
76
setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
 
77
 
 
78
addErr :: Monad m => String -> EwM m ()
 
79
addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ()))
 
80
 
 
81
addWarn :: Monad m => String -> EwM m ()
 
82
addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ()))
 
83
  where
 
84
    w = "Warning: " ++ msg
 
85
 
 
86
deprecate :: Monad m => String -> EwM m ()
 
87
deprecate s 
 
88
  = do { arg <- getArg
 
89
       ; addWarn (arg ++ " is deprecated: " ++ s) }
 
90
 
 
91
getArg :: Monad m => EwM m String
 
92
getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
 
93
 
 
94
liftEwM :: Monad m => m a -> EwM m a
 
95
liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
 
96
 
 
97
-- -----------------------------------------------------------------------------
 
98
-- A state monad for use in the command-line parser
 
99
-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
 
100
 
 
101
newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
 
102
 
 
103
instance Monad (CmdLineP s) where
 
104
        return a = CmdLineP $ \s -> (a, s)
 
105
        m >>= k  = CmdLineP $ \s -> let
 
106
                (a, s') = runCmdLine m s
 
107
                in runCmdLine (k a) s'
 
108
 
 
109
getCmdLineState :: CmdLineP s s
 
110
getCmdLineState   = CmdLineP $ \s -> (s,s)
 
111
putCmdLineState :: s -> CmdLineP s ()
 
112
putCmdLineState s = CmdLineP $ \_ -> ((),s)
 
113
 
 
114
 
 
115
--------------------------------------------------------
 
116
--         Processing arguments
 
117
--------------------------------------------------------
 
118
 
 
119
processArgs :: Monad m
 
120
            => [Flag m] -- cmdline parser spec
 
121
            -> [Located String]      -- args
 
122
            -> m (
 
123
                  [Located String],  -- spare args
 
124
                  [Located String],  -- errors
 
125
                  [Located String]   -- warnings
 
126
                 )
 
127
processArgs spec args 
 
128
  = do { (errs, warns, spare) <- unEwM (process args []) 
 
129
                                       (panic "processArgs: no arg yet")
 
130
                                       emptyBag emptyBag 
 
131
       ; return (spare, bagToList errs, bagToList warns) }
 
132
  where
 
133
    -- process :: [Located String] -> [Located String] -> EwM m [Located String]
 
134
    process [] spare = return (reverse spare)
 
135
 
 
136
    process (locArg@(L _ ('-' : arg)) : args) spare =
 
137
      case findArg spec arg of
 
138
        Just (rest, opt_kind) ->
 
139
           case processOneArg opt_kind rest arg args of
 
140
              Left err            -> do { setArg locArg $ addErr err
 
141
                                        ; process args spare }
 
142
              Right (action,rest) -> do { setArg locArg $ action
 
143
                                        ; process rest spare }
 
144
        Nothing -> process args (locArg : spare) 
 
145
 
 
146
    process (arg : args) spare = process args (arg : spare) 
 
147
 
 
148
 
 
149
processOneArg :: OptKind m -> String -> String -> [Located String]
 
150
              -> Either String (EwM m (), [Located String])
 
151
processOneArg opt_kind rest arg args
 
152
  = let dash_arg = '-' : arg
 
153
        rest_no_eq = dropEq rest
 
154
    in case opt_kind of
 
155
        NoArg  a -> ASSERT(null rest) Right (a, args)
 
156
 
 
157
        HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
 
158
                 | otherwise    -> case args of
 
159
                                    [] -> missingArgErr dash_arg
 
160
                                    (L _ arg1:args1) -> Right (f arg1, args1)
 
161
 
 
162
        SepArg f -> case args of
 
163
                        [] -> unknownFlagErr dash_arg
 
164
                        (L _ arg1:args1) -> Right (f arg1, args1)
 
165
 
 
166
        Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
 
167
                 | otherwise  -> unknownFlagErr dash_arg
 
168
 
 
169
        PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args)
 
170
                       | otherwise          -> unknownFlagErr dash_arg
 
171
 
 
172
        PassFlag f  | notNull rest -> unknownFlagErr dash_arg
 
173
                    | otherwise    -> Right (f dash_arg, args)
 
174
 
 
175
        OptIntSuffix f | null rest                     -> Right (f Nothing,  args)
 
176
                       | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
 
177
                       | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
 
178
 
 
179
        IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
 
180
                    | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
 
181
 
 
182
        OptPrefix f       -> Right (f rest_no_eq, args)
 
183
        AnySuffix f       -> Right (f dash_arg, args)
 
184
        AnySuffixPred _ f -> Right (f dash_arg, args)
 
185
 
 
186
 
 
187
findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
 
188
findArg spec arg
 
189
  = case [ (removeSpaces rest, optKind)
 
190
         | flag <- spec,
 
191
           let optKind = flagOptKind flag,
 
192
           Just rest <- [stripPrefix (flagName flag) arg],
 
193
           arg_ok optKind rest arg ]
 
194
    of
 
195
        []      -> Nothing
 
196
        (one:_) -> Just one
 
197
 
 
198
arg_ok :: OptKind t -> [Char] -> String -> Bool
 
199
arg_ok (NoArg _)            rest _   = null rest
 
200
arg_ok (HasArg _)           _    _   = True
 
201
arg_ok (SepArg _)           rest _   = null rest
 
202
arg_ok (Prefix _)           rest _   = notNull rest
 
203
arg_ok (PrefixPred p _)     rest _   = notNull rest && p (dropEq rest)
 
204
arg_ok (OptIntSuffix _)     _    _   = True
 
205
arg_ok (IntSuffix _)        _    _   = True
 
206
arg_ok (OptPrefix _)        _    _   = True
 
207
arg_ok (PassFlag _)         rest _   = null rest
 
208
arg_ok (AnySuffix _)        _    _   = True
 
209
arg_ok (AnySuffixPred p _)  _    arg = p arg
 
210
 
 
211
parseInt :: String -> Maybe Int
 
212
-- Looks for "433" or "=342", with no trailing gubbins
 
213
--   n or =n      => Just n
 
214
--   gibberish    => Nothing
 
215
parseInt s = case reads s of
 
216
                ((n,""):_) -> Just n
 
217
                _          -> Nothing
 
218
 
 
219
dropEq :: String -> String
 
220
-- Discards a leading equals sign
 
221
dropEq ('=' : s) = s
 
222
dropEq s         = s
 
223
 
 
224
unknownFlagErr :: String -> Either String a
 
225
unknownFlagErr f = Left ("unrecognised flag: " ++ f)
 
226
 
 
227
missingArgErr :: String -> Either String a
 
228
missingArgErr f = Left ("missing argument for flag: " ++ f)
 
229
 
 
230
-- ---------------------------------------------------------------------
 
231
-- Utils
 
232
 
 
233
errorsToGhcException :: [Located String] -> GhcException
 
234
errorsToGhcException errs =
 
235
   let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
 
236
   in UsageError (showSDoc $ withPprStyle cmdlineParserStyle errors)
 
237