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