never executed always true always false

    1 module Conjure.UserError
    2     ( MonadUserError(..), userErr1
    3     , UserErrorT(..), runUserError
    4     , failToUserError, failToBug
    5     , liftUserErrorT
    6     ) where
    7 
    8 import Conjure.Prelude
    9 -- import qualified Conjure.Prelude as Prelude ( MonadFail(..) )
   10 import Conjure.Bug
   11 import Conjure.Language.Pretty
   12 
   13 -- base
   14 import System.Exit ( exitWith, ExitCode(..) )
   15 import System.IO as X ( stderr, hPutStrLn )
   16 
   17 
   18 -- pipes
   19 import qualified Pipes
   20 
   21 
   22 userErr1 :: MonadUserError m => Doc -> m a
   23 userErr1 = userErr . return
   24 
   25 class MonadFailDoc m => MonadUserError m where
   26     userErr :: [Doc] -> m a
   27 
   28 instance MonadUserError (Either Doc) where
   29     userErr msgs = do
   30         let msgsOut = case msgs of
   31                 []    -> bug "userErr []"
   32                 [msg] -> [ "Error:" <++> msg ]
   33                 _     -> [ "Error" <+> pretty (i :: Int) <> ":" <++> msg
   34                          | (i, msg) <- zip [1..] msgs
   35                          ]
   36         Left (vcat msgsOut)
   37 
   38 -- user errors exit with exit code 2 now.
   39 -- in the future we intend to exit with different exit code for different kind of user errors,
   40 -- but they will always use values >1
   41 -- exit code 0 is for success
   42 -- exit code 1 is for bugs
   43 -- exit code >1 for user errors
   44 instance MonadUserError IO where
   45     userErr msgs =
   46         case userErr msgs of
   47             Left doc -> hPutStrLn stderr (renderNormal (doc :: Doc)) >> exitWith (ExitFailure 2)
   48             Right x  -> return x
   49 
   50 instance MonadUserError m => MonadUserError (IdentityT m) where
   51     userErr = lift . userErr
   52 
   53 instance MonadUserError m => MonadUserError (MaybeT m) where
   54     userErr = lift . userErr
   55 
   56 instance MonadUserError m => MonadUserError (ExceptT m) where
   57     userErr = lift . userErr
   58 
   59 instance MonadUserError m => MonadUserError (StateT st m) where
   60     userErr = lift . userErr
   61 
   62 instance (MonadUserError m, Monoid w) => MonadUserError (WriterT w m) where
   63     userErr = lift . userErr
   64 
   65 instance MonadUserError m => MonadUserError (ReaderT r m) where
   66     userErr = lift . userErr
   67 
   68 instance MonadUserError m => MonadUserError (Pipes.Proxy a b c d m) where
   69     userErr = lift . userErr
   70 
   71 
   72 -- | This is to run a MonadUserError. Everything else should lift.
   73 newtype UserErrorT m a = UserErrorT { runUserErrorT :: m (Either [Doc] a) }
   74 
   75 runUserError :: UserErrorT Identity a -> Either [Doc] a
   76 runUserError ma = runIdentity (runUserErrorT ma)
   77 
   78 instance (Functor m) => Functor (UserErrorT m) where
   79     fmap f = UserErrorT . fmap (fmap f) . runUserErrorT
   80 
   81 instance (MonadFailDoc m) => Applicative (UserErrorT m) where
   82     pure = UserErrorT . return .Right
   83     (<*>) = ap
   84 
   85 instance (MonadFailDoc m) => Monad (UserErrorT m) where
   86     return = pure
   87     m >>= k = UserErrorT $ do
   88         a <- runUserErrorT m
   89         case a of
   90             Left e -> return (Left e)
   91             Right x -> runUserErrorT (k x)
   92 
   93 instance (MonadIO m, MonadFailDoc m) => MonadIO (UserErrorT m) where
   94     liftIO comp = UserErrorT $ do
   95         res <- liftIO comp
   96         return (Right res)
   97 
   98 -- instance MonadTrans UserErrorT where
   99 
  100 liftUserErrorT :: Monad m => m a -> UserErrorT m a
  101 liftUserErrorT comp = UserErrorT $ Right <$> comp
  102 
  103 instance MonadFailDoc m => MonadFailDoc (UserErrorT m) where
  104     failDoc = liftUserErrorT . failDoc
  105 
  106 instance MonadFailDoc m => MonadFail (UserErrorT m) where
  107     fail = liftUserErrorT . fail
  108 
  109 instance MonadFailDoc m => MonadUserError (UserErrorT m) where
  110     userErr msgs = UserErrorT $ return $ Left msgs
  111 
  112 
  113 failToUserError :: MonadUserError m => ExceptT m a -> m a
  114 failToUserError comp = do
  115     res <- runExceptT comp
  116     case res of
  117         Left err -> userErr1 err
  118         Right x  -> return x
  119 
  120 failToBug :: Monad m => ExceptT m a -> m a
  121 failToBug comp = do
  122     res <- runExceptT comp
  123     case res of
  124         Left err -> bug err
  125         Right x  -> return x