never executed always true always false

    1 module CommandLine.Program (ProgramResult(..), ProgramIO, run, failed, CommandLine.Program.error, showUsage, liftEither, liftM, liftME, mapError) where
    2 
    3 -- Common handling for command line programs
    4 
    5 import Prelude ()
    6 import Relude hiding (putStrLn, exitSuccess, exitFailure)
    7 
    8 import CommandLine.InfoFormatter (ToConsole(..))
    9 import CommandLine.World
   10 import qualified Data.Text as Text
   11 import System.Exit (ExitCode(..))
   12 
   13 import qualified Options.Applicative as OptParse
   14 
   15 
   16 class MapError f where
   17     mapError :: (x -> y) -> f x a -> f y a
   18 
   19 
   20 data ProgramResult err a
   21     = ShowUsage
   22     | ProgramError err
   23     | ProgramSuccess a
   24     | ProgramFailed
   25     deriving (Functor)
   26 
   27 instance MapError ProgramResult where
   28     mapError f = \case
   29         ShowUsage -> ShowUsage
   30         ProgramError x -> ProgramError $ f x
   31         ProgramSuccess a -> ProgramSuccess a
   32         ProgramFailed -> ProgramFailed
   33 
   34 instance Applicative (ProgramResult err) where
   35     pure a = ProgramSuccess a
   36     liftA2 f (ProgramSuccess a) (ProgramSuccess b) = ProgramSuccess (f a b)
   37     liftA2 _ (ProgramError err) _ = ProgramError err
   38     liftA2 _ ProgramFailed _ = ProgramFailed
   39     liftA2 _ ShowUsage _ = ShowUsage
   40     liftA2 _ _ (ProgramError err) = ProgramError err
   41     liftA2 _ _ ProgramFailed = ProgramFailed
   42     liftA2 _ _ ShowUsage = ShowUsage
   43 
   44 instance Monad (ProgramResult err) where
   45     ShowUsage >>= _ = ShowUsage
   46     ProgramFailed >>= _ = ProgramFailed
   47     (ProgramError err) >>= _ = ProgramError err
   48     (ProgramSuccess a) >>= f = f a
   49 
   50 
   51 newtype ProgramIO m x a =
   52     ProgramIO (m (ProgramResult x a))
   53     deriving (Functor)
   54 
   55 instance Functor m => MapError (ProgramIO m) where
   56     mapError f (ProgramIO m) = ProgramIO (fmap (mapError f) m)
   57 
   58 instance Monad m => Applicative (ProgramIO m x) where
   59     pure a = ProgramIO $ return $ pure a
   60     liftA2 f (ProgramIO a) (ProgramIO b) =
   61         ProgramIO $ do
   62             a' <- a
   63             b' <- b
   64             return $ liftA2 f a' b'
   65 
   66 instance Monad m => Monad (ProgramIO m x) where
   67     (ProgramIO m) >>= f = ProgramIO (m >>= f')
   68         where
   69             f' r =
   70                 case r of
   71                     ShowUsage -> return $ ShowUsage
   72                     ProgramError x -> return $ ProgramError x
   73                     ProgramFailed -> return $ ProgramFailed
   74                     ProgramSuccess a -> (\(ProgramIO z) -> z) $ f a
   75 
   76 failed :: Applicative m => ProgramIO m x a
   77 failed = ProgramIO $ pure $ ProgramFailed
   78 
   79 error :: Applicative m => x -> ProgramIO m x a
   80 error x = ProgramIO $ pure $ ProgramError x
   81 
   82 showUsage :: Applicative m => ProgramIO m x a
   83 showUsage = ProgramIO $ pure $ ShowUsage
   84 
   85 liftEither :: Applicative m => Either x a -> ProgramIO m x a
   86 liftEither (Left x) = ProgramIO $ pure $ ProgramError x
   87 liftEither (Right a) = ProgramIO $ pure $ ProgramSuccess a
   88 
   89 liftM :: Functor m => m a -> ProgramIO m x a
   90 liftM m = ProgramIO (ProgramSuccess <$> m)
   91 
   92 liftME :: Monad m => m (Either x a) -> ProgramIO m x a
   93 liftME m = ProgramIO (m >>= ((\(ProgramIO z) -> z) . liftEither))
   94 
   95 
   96 run ::
   97     World m =>
   98     ToConsole err =>
   99     OptParse.ParserInfo flags
  100     -> (flags -> ProgramIO m err ())
  101     -> [String]
  102     -> m ()
  103 run flagsParser run' args =
  104     let
  105         parsePreferences =
  106             OptParse.prefs (mempty <> OptParse.showHelpOnError)
  107 
  108         parseFlags =
  109             OptParse.execParserPure parsePreferences flagsParser
  110     in
  111     do
  112         flags <- handleParseResult $ parseFlags args
  113         case flags of
  114             Nothing -> return ()
  115             Just flags' ->
  116                 do
  117                     result <- (\(ProgramIO m) -> m) $ run' flags'
  118                     case result of
  119                         ShowUsage ->
  120                             (handleParseResult $ parseFlags ["--help"])
  121                                 -- TODO: handleParseResult is exitSuccess, so we never get to exitFailure
  122                                 >> exitFailure
  123 
  124                         ProgramError err ->
  125                             putStrLnStderr (toConsole err)
  126                                 >> exitFailure
  127 
  128                         ProgramSuccess () ->
  129                             exitSuccess
  130 
  131                         ProgramFailed ->
  132                             exitFailure
  133 
  134 
  135 {-| copied from Options.Applicative -}
  136 handleParseResult :: World m => OptParse.ParserResult a -> m (Maybe a)
  137 handleParseResult (OptParse.Success a) = return (Just a)
  138 handleParseResult (OptParse.Failure failure) = do
  139     progn <- getProgName
  140     let (msg, exit) = OptParse.renderFailure failure (Text.unpack progn)
  141     case exit of
  142         ExitSuccess -> putStrLn (Text.pack msg) *> exitSuccess *> return Nothing
  143         _           -> putStrLnStderr (Text.pack msg) *> exitFailure *> return Nothing
  144 handleParseResult (OptParse.CompletionInvoked _) =
  145     -- do
  146     --     progn <- getProgName
  147     --     msg <- OptParse.execCompletion compl progn
  148     --     putStr msg
  149     --     const undefined <$> exitSuccess
  150     Relude.error "Shell completion not yet implemented"