{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# OPTIONS_GHC -w #-}
module Uniform.Error
( module Uniform.Error,
module Safe,
module Control.Monad.Error,
module Control.Exception,
)
where
import Control.Exception (Exception, SomeException, bracket, catch)
import "monads-tf" Control.Monad.Error (Error, ErrorT, ErrorType, MonadError, MonadIO, catchError, liftIO, runErrorT, throwError, unless, when)
import Safe (headNote, readNote)
import Uniform.Strings hiding (S, (<.>), (</>))
instance CharChains2 IOError Text where
show' :: IOError -> Text
show' = String -> Text
s2t (String -> Text) -> (IOError -> String) -> IOError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> String
forall a. Show a => a -> String
show
type ErrOrVal = Either Text
type ErrIO = ErrorT Text IO
instance Exception [Text]
toErrOrVal :: Either String a -> ErrOrVal a
toErrOrVal :: Either String a -> ErrOrVal a
toErrOrVal (Left String
s) = Text -> ErrOrVal a
forall a b. a -> Either a b
Left (String -> Text
s2t String
s)
toErrOrVal (Right a
r) = a -> ErrOrVal a
forall a b. b -> Either a b
Right a
r
runErr :: ErrIO a -> IO (ErrOrVal a)
runErr :: ErrIO a -> IO (ErrOrVal a)
runErr = ErrIO a -> IO (ErrOrVal a)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT
runErrorVoid :: ErrIO () -> IO ()
runErrorVoid :: ErrIO () -> IO ()
runErrorVoid ErrIO ()
a = do
ErrOrVal ()
res <- ErrIO () -> IO (ErrOrVal ())
forall a. ErrIO a -> IO (ErrOrVal a)
runErr ErrIO ()
a
case ErrOrVal ()
res of
Left Text
msg -> String -> IO ()
forall a. HasCallStack => String -> a
error (Text -> String
t2s Text
msg)
Right ()
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
undef :: Text -> a
undef :: Text -> a
undef = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (Text -> String) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
t2s
fromRightEOV :: ErrOrVal a -> a
fromRightEOV :: ErrOrVal a -> a
fromRightEOV (Right a
a) = a
a
fromRightEOV (Left Text
msg) = [Text] -> a
forall a. [Text] -> a
errorT [Text
"fromrightEOV", Text
msg]
bracketErrIO ::
ErrIO a ->
(a -> ErrIO b) ->
(a -> ErrIO c) ->
ErrIO c
bracketErrIO :: ErrIO a -> (a -> ErrIO b) -> (a -> ErrIO c) -> ErrIO c
bracketErrIO ErrIO a
before a -> ErrIO b
after a -> ErrIO c
thing =
(ErrOrVal c -> c) -> ErrorT Text IO (ErrOrVal c) -> ErrIO c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ErrOrVal c -> c
forall a. ErrOrVal a -> a
fromRightEOV (ErrorT Text IO (ErrOrVal c) -> ErrIO c)
-> (IO (ErrOrVal c) -> ErrorT Text IO (ErrOrVal c))
-> IO (ErrOrVal c)
-> ErrIO c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (ErrOrVal c) -> ErrorT Text IO (ErrOrVal c)
forall (m :: * -> *) a.
(MonadError m, MonadIO m, ErrorType m ~ Text) =>
IO a -> m a
callIO (IO (ErrOrVal c) -> ErrIO c) -> IO (ErrOrVal c) -> ErrIO c
forall a b. (a -> b) -> a -> b
$
IO (ErrOrVal a)
-> (ErrOrVal a -> IO (ErrOrVal b))
-> (ErrOrVal a -> IO (ErrOrVal c))
-> IO (ErrOrVal c)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
( do
ErrOrVal a
ra <- ErrIO a -> IO (ErrOrVal a)
forall a. ErrIO a -> IO (ErrOrVal a)
runErr (ErrIO a -> IO (ErrOrVal a)) -> ErrIO a -> IO (ErrOrVal a)
forall a b. (a -> b) -> a -> b
$ ErrIO a
before
ErrOrVal a -> IO (ErrOrVal a)
forall (m :: * -> *) a. Monad m => a -> m a
return ErrOrVal a
ra
)
(\ErrOrVal a
a -> ErrIO b -> IO (ErrOrVal b)
forall a. ErrIO a -> IO (ErrOrVal a)
runErr (ErrIO b -> IO (ErrOrVal b)) -> ErrIO b -> IO (ErrOrVal b)
forall a b. (a -> b) -> a -> b
$ a -> ErrIO b
after (a -> ErrIO b) -> (ErrOrVal a -> a) -> ErrOrVal a -> ErrIO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrOrVal a -> a
forall a. ErrOrVal a -> a
fromRightEOV (ErrOrVal a -> ErrIO b) -> ErrOrVal a -> ErrIO b
forall a b. (a -> b) -> a -> b
$ ErrOrVal a
a)
(\ErrOrVal a
a -> ErrIO c -> IO (ErrOrVal c)
forall a. ErrIO a -> IO (ErrOrVal a)
runErr (ErrIO c -> IO (ErrOrVal c)) -> ErrIO c -> IO (ErrOrVal c)
forall a b. (a -> b) -> a -> b
$ a -> ErrIO c
thing (a -> ErrIO c) -> (ErrOrVal a -> a) -> ErrOrVal a -> ErrIO c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrOrVal a -> a
forall a. ErrOrVal a -> a
fromRightEOV (ErrOrVal a -> ErrIO c) -> ErrOrVal a -> ErrIO c
forall a b. (a -> b) -> a -> b
$ ErrOrVal a
a)
instance Error Text
callIO :: (MonadError m, MonadIO m, ErrorType m ~ Text) => IO a -> m a
callIO :: IO a -> m a
callIO IO a
op = do
Either SomeException a
r2 <-
IO (Either SomeException a) -> m (Either SomeException a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException a) -> m (Either SomeException a))
-> IO (Either SomeException a) -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$
do
a
r <- IO a
op
Either SomeException a -> IO (Either SomeException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> IO (Either SomeException a))
-> Either SomeException a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ a -> Either SomeException a
forall a b. b -> Either a b
Right a
r
IO (Either SomeException a)
-> (SomeException -> IO (Either SomeException a))
-> IO (Either SomeException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` ( \SomeException
e -> do
Either SomeException a -> IO (Either SomeException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> IO (Either SomeException a))
-> (SomeException -> Either SomeException a)
-> SomeException
-> IO (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left (SomeException -> IO (Either SomeException a))
-> SomeException -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ (SomeException
e :: SomeException)
)
case Either SomeException a
r2 of
Left SomeException
e -> do
ErrorType m -> m a
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError (SomeException -> Text
forall a. Show a => a -> Text
showT SomeException
e)
Right a
v -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
throwErrorT :: [Text] -> ErrIO a
throwErrorT :: [Text] -> ErrIO a
throwErrorT = Text -> ErrIO a
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError (Text -> ErrIO a) -> ([Text] -> Text) -> [Text] -> ErrIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unwordsT
maybe2error :: Maybe a -> ErrIO a
maybe2error :: Maybe a -> ErrIO a
maybe2error Maybe a
Nothing = String -> ErrIO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"was Nothing"
maybe2error (Just a
a) = a -> ErrIO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
errorT :: [Text] -> a
errorT :: [Text] -> a
errorT = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> ([Text] -> String) -> [Text] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
t2s (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unwordsT
errorWords :: [Text] -> a
errorWords :: [Text] -> a
errorWords = [Text] -> a
forall a. [Text] -> a
errorT
fromJustNoteT :: [Text] -> Maybe a -> a
fromJustNoteT :: [Text] -> Maybe a -> a
fromJustNoteT [Text]
msgs Maybe a
a = String -> Maybe a -> a
forall a. HasCallStack => String -> Maybe a -> a
fromJustNote (Text -> String
t2s (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unlinesT ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ [Text]
msgs) Maybe a
a
fromRightNoteString :: Text -> Either String b -> b
fromRightNoteString :: Text -> Either String b -> b
fromRightNoteString Text
msg (Left String
a) = [Text] -> b
forall a. [Text] -> a
errorT [Text
"fromRight", String -> Text
forall a. Show a => a -> Text
showT String
a, Text
msg]
fromRightNoteString Text
_ (Right b
a) = b
a
fromRightNote :: Text -> Either Text b -> b
fromRightNote :: Text -> Either Text b -> b
fromRightNote Text
msg (Left Text
a) = [Text] -> b
forall a. [Text] -> a
errorT [Text
"fromRight", Text -> Text
forall a. Show a => a -> Text
showT Text
a, Text
msg]
fromRightNote Text
_ (Right b
a) = b
a
headNoteT :: [Text] -> [a] -> a
headNoteT :: [Text] -> [a] -> a
headNoteT [Text]
msg [a]
s = String -> [a] -> a
forall a. HasCallStack => String -> [a] -> a
headNote (Text -> String
t2s (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. CharChains a => [a] -> a
unwords' [Text]
msg) [a]
s
startProg :: Show a => Text -> ErrIO a -> IO ()
startProg :: Text -> ErrIO a -> IO ()
startProg Text
programName ErrIO a
mainProg =
do
[Text] -> IO ()
forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords
[ Text
"------------------ ",
Text
programName,
Text
" ----------------------------\n"
]
ErrOrVal a
r <- ErrIO a -> IO (ErrOrVal a)
forall a. ErrIO a -> IO (ErrOrVal a)
runErr (ErrIO a -> IO (ErrOrVal a)) -> ErrIO a -> IO (ErrOrVal a)
forall a b. (a -> b) -> a -> b
$ ErrIO a
mainProg
[Text] -> IO ()
forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords
[ Text
"\n------------------",
Text
"main",
Text
programName,
Text
"\nreturning",
(Text -> Text) -> (a -> Text) -> ErrOrVal a -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id a -> Text
forall a. Show a => a -> Text
showT ErrOrVal a
r,
Text
"\n"
]
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IO () -> (ErrorType IO -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadError m =>
m a -> (ErrorType m -> m a) -> m a
`catchError` ( \ErrorType IO
e -> do
[Text] -> IO ()
forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords
[ Text
"startProg error caught\n",
Text
programName,
Text
"\n",
IOError -> Text
forall a. Show a => a -> Text
showT IOError
ErrorType IO
e
]
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
)