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