ghc/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   ) where
  16
  17 #include "HsVersions.h"
  18
  19 import Util             ( maybePrefixMatch, notNull, removeSpaces )
  20
  21 data OptKind m
  22         = NoArg (m ())  -- flag with no argument
  23         | HasArg    (String -> m ())    -- flag has an argument (maybe prefix)
  24         | SepArg    (String -> m ())    -- flag has a separate argument
  25         | Prefix    (String -> m ())    -- flag is a prefix only
  26         | OptPrefix (String -> m ())    -- flag may be a prefix
  27         | AnySuffix (String -> m ())    -- flag is a prefix, pass whole arg to fn
  28         | PassFlag  (String -> m ())    -- flag with no arg, pass flag to fn
  29         | PrefixPred    (String -> Bool) (String -> m ())
  30         | AnySuffixPred (String -> Bool) (String -> m ())
  31
  32 processArgs :: Monad m
  33             => [(String, OptKind m)]    -- cmdline parser spec
  34             -> [String]                 -- args
  35             -> m (
  36                 [String],  -- spare args
  37                 [String]   -- errors
  38                 )
  39 processArgs spec args = process spec args [] []
  40   where
  41     process _spec [] spare errs =
  42       return (reverse spare, reverse errs)
  43
  44     process spec args@(('-':arg):args') spare errs =
  45       case findArg spec arg of
  46         Just (rest,action) ->
  47            case processOneArg action rest args of
  48            Left err       -> process spec args' spare (err:errs)
  49            Right (action,rest) -> do
  50                 action >> process spec rest spare errs
  51         Nothing ->
  52            process spec args' (('-':arg):spare) errs
  53
  54     process spec (arg:args) spare errs =
  55       process spec args (arg:spare) errs
  56
  57
  58 processOneArg :: OptKind m -> String -> [String]
  59   -> Either String (m (), [String])
  60 processOneArg action rest (dash_arg@('-':arg):args) =
  61   case action of
  62         NoArg  a -> ASSERT(null rest) Right (a, args)
  63
  64         HasArg f ->
  65                 if rest /= ""
  66                         then Right (f rest, args)
  67                         else case args of
  68                                 [] -> missingArgErr dash_arg
  69                                 (arg1:args1) -> Right (f arg1, args1)
  70
  71         SepArg f ->
  72                 case args of
  73                         [] -> unknownFlagErr dash_arg
  74                         (arg1:args1) -> Right (f arg1, args1)
  75
  76         Prefix f ->
  77                 if rest /= ""
  78                         then Right (f rest, args)
  79                         else unknownFlagErr dash_arg
  80
  81         PrefixPred p f ->
  82                 if rest /= ""
  83                         then Right (f rest, args)
  84                         else unknownFlagErr dash_arg
  85
  86         OptPrefix f       -> Right (f rest, args)
  87
  88         AnySuffix f       -> Right (f dash_arg, args)
  89
  90         AnySuffixPred p f -> Right (f dash_arg, args)
  91
  92         PassFlag f  ->
  93                 if rest /= ""
  94                         then unknownFlagErr dash_arg
  95                         else Right (f dash_arg, args)
  96
  97
  98 findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a)
  99 findArg spec arg
 100   = case [ (removeSpaces rest, k)
 101          | (pat,k)   <- spec,
 102            Just rest <- [maybePrefixMatch pat arg],
 103            arg_ok k rest arg ]
 104     of
 105         []      -> Nothing
 106         (one:_) -> Just one
 107
 108 arg_ok (NoArg _)            rest arg = null rest
 109 arg_ok (HasArg _)           rest arg = True
 110 arg_ok (SepArg _)           rest arg = null rest
 111 arg_ok (Prefix _)           rest arg = notNull rest
 112 arg_ok (PrefixPred p _)     rest arg = notNull rest && p rest
 113 arg_ok (OptPrefix _)        rest arg = True
 114 arg_ok (PassFlag _)         rest arg = null rest
 115 arg_ok (AnySuffix _)        rest arg = True
 116 arg_ok (AnySuffixPred p _)  rest arg = p arg
 117
 118 unknownFlagErr :: String -> Either String a
 119 unknownFlagErr f = Left ("unrecognised flag: " ++ f)
 120
 121 missingArgErr :: String -> Either String a
 122 missingArgErr f = Left ("missing argument for flag: " ++ f)
 123
 124 -- -----------------------------------------------------------------------------
 125 -- A state monad for use in the command-line parser
 126
 127 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
 128
 129 instance Monad (CmdLineP s) where
 130         return a = CmdLineP $ \s -> (a, s)
 131         m >>= k  = CmdLineP $ \s -> let
 132                 (a, s') = runCmdLine m s
 133                 in runCmdLine (k a) s'
 134
 135 getCmdLineState   = CmdLineP $ \s -> (s,s)
 136 putCmdLineState s = CmdLineP $ \_ -> ((),s)