never executed always true always false

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