----------------------------------------------------------------------
--
-- Module      :  Uniform.Error
--
----------------------------------------------------------------------

    {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-- runErrorT is depreceiated but used in monads-tf
{-# OPTIONS_GHC -w #-}

module Uniform.Error
  ( module Uniform.Error,
    -- module Uniform.Strings,
    module Safe,
    module Control.Monad.Error, -- is monads-tf
    module Control.Exception, -- to avoid control.error
  )
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 to avoid the depreceated message for runErrorT, which is identical
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 ()
-- ^ run an operation in ErrIO which is not returning anything
-- simpler to use than runErr
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
-- ^ for type specification, not to be evaluated

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 ::
  -- | computation to run first (\"acquire resource\")
  ErrIO a ->
  -- | computation to run last (\"release resource\")
  (a -> ErrIO b) ->
  -- | computation to run in-between
  (a -> ErrIO c) ->
  ErrIO c -- returns the value from the in-between computation
  --bracketErrIO before after thing = bracket before after thing
  -- no way to catch IO errors reliably in ErrIO -- missing Monad Mask or similar
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 --  (ra :: ErrOrVal a) )
      )
      (\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
-- | this is using catch to grab all errors
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
                    --                         putStrLn "callIO catch caught error\n"
                    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
      --                        putIOwords ["\ncallIO Left branch\n", showT e, "throwError\n"]
      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
-- throw an error with a list of texts as a text
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
-- ^ a list of texts is output with failure
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
-- produce error with msg when Nothing, msg is list of texts
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
-- produce an error when assuming that a value is Right
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
-- produce an error when assuming that a value is Right
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
-- get head with a list of texts
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 ()
                 )