- = NoArg (m ()) -- -f all by itself
- | HasArg (String -> m ()) -- -farg or -f arg
- | SepArg (String -> m ()) -- -f arg
- | Prefix (String -> m ()) -- -farg
- | OptPrefix (String -> m ()) -- -f or -farg (i.e. the arg is optional)
- | OptIntSuffix (Maybe Int -> m ()) -- -f or -f=n; pass n to fn
- | IntSuffix (Int -> m ()) -- -f or -f=n; pass n to fn
- | PassFlag (String -> m ()) -- -f; pass "-f" fn
- | AnySuffix (String -> m ()) -- -f or -farg; pass entire "-farg" to fn
- | PrefixPred (String -> Bool) (String -> m ())
- | AnySuffixPred (String -> Bool) (String -> m ())
+ = NoArg (EwM m ()) -- -f all by itself
+ | HasArg (String -> EwM m ()) -- -farg or -f arg
+ | SepArg (String -> EwM m ()) -- -f arg
+ | Prefix (String -> EwM m ()) -- -farg
+ | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional)
+ | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn
+ | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn
+ | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn
+ | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn
+ | PrefixPred (String -> Bool) (String -> EwM m ())
+ | AnySuffixPred (String -> Bool) (String -> EwM m ())
+
+
+--------------------------------------------------------
+-- The EwM monad
+--------------------------------------------------------
+
+type Err = Located String
+type Warn = Located String
+type Errs = Bag Err
+type Warns = Bag Warn
+
+-- EwM (short for "errors and warnings monad") is a
+-- monad transformer for m that adds an (err, warn) state
+newtype EwM m a = EwM { unEwM :: Located String -- Current arg
+ -> Errs -> Warns
+ -> m (Errs, Warns, a) }
+
+instance Monad m => Monad (EwM m) where
+ (EwM f) >>= k = EwM (\l e w -> do { (e', w', r) <- f l e w
+ ; unEwM (k r) l e' w' })
+ return v = EwM (\_ e w -> return (e, w, v))
+
+setArg :: Located String -> EwM m a -> EwM m a
+setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
+
+addErr :: Monad m => String -> EwM m ()
+addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ()))
+
+addWarn :: Monad m => String -> EwM m ()
+addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ()))
+ where
+ w = "Warning: " ++ msg
+
+deprecate :: Monad m => String -> EwM m ()
+deprecate s
+ = do { arg <- getArg
+ ; addWarn (arg ++ " is deprecated: " ++ s) }
+
+getArg :: Monad m => EwM m String
+getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
+
+liftEwM :: Monad m => m a -> EwM m a
+liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
+
+-- -----------------------------------------------------------------------------
+-- A state monad for use in the command-line parser
+-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
+
+newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
+
+instance Monad (CmdLineP s) where
+ return a = CmdLineP $ \s -> (a, s)
+ m >>= k = CmdLineP $ \s -> let
+ (a, s') = runCmdLine m s
+ in runCmdLine (k a) s'
+
+getCmdLineState :: CmdLineP s s
+getCmdLineState = CmdLineP $ \s -> (s,s)
+putCmdLineState :: s -> CmdLineP s ()
+putCmdLineState s = CmdLineP $ \_ -> ((),s)
+
+
+--------------------------------------------------------
+-- Processing arguments
+--------------------------------------------------------