{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}

module TraceError where

import Control.Monad.Except   (MonadError, throwError, catchError)
import Control.Monad.IO.Class (MonadIO(..))
import Debug.Trace

import Util
import Text.PrettyPrint

data TraceError = Err String | TrErr String TraceError

-- instance Error TraceError where
--     noMsg = Err "no message"
--     strMsg s = Err s

instance Show TraceError where
    show :: TraceError -> String
show (Err String
str) = String
str
    show (TrErr String
str TraceError
err) = String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n/// " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TraceError -> String
forall a. Show a => a -> String
show TraceError
err

throwErrorMsg :: MonadError TraceError m => String -> m a
throwErrorMsg :: forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg = TraceError -> m a
forall a. TraceError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TraceError -> m a) -> (String -> TraceError) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TraceError
Err

newErrorMsg :: (MonadError TraceError m) => m a -> String -> m a
newErrorMsg :: forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> String -> m a
newErrorMsg m a
c String
s = m a
c m a -> (TraceError -> m a) -> m a
forall a. m a -> (TraceError -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\ TraceError
_ -> String -> m a
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg String
s)
-- addErrorMsg c s = c `catchError` (\ s' -> throwErrorMsg (s' ++ "\n" ++ s))

-- extend the current error message by n
throwTrace :: MonadError TraceError m => m a -> String -> m a
throwTrace :: forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> String -> m a
throwTrace m a
x String
n = m a
x m a -> (TraceError -> m a) -> m a
forall a. m a -> (TraceError -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` ( \TraceError
e -> TraceError -> m a
forall a. TraceError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TraceError -> m a) -> TraceError -> m a
forall a b. (a -> b) -> a -> b
$ String -> TraceError -> TraceError
TrErr String
n TraceError
e)

enter, enterTrace :: MonadError TraceError m => String -> m a -> m a
enter :: forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter String
n m a
x = m a -> String -> m a
forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> String -> m a
throwTrace m a
x String
n
enterTrace :: forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enterTrace String
n m a
x = String -> m a -> m a
forall a. String -> a -> a
trace String
n (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m a -> String -> m a
forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> String -> m a
throwTrace m a
x String
n

enterShow :: (MonadError TraceError m, Show a) => a -> m b -> m b
enterShow :: forall (m :: * -> *) a b.
(MonadError TraceError m, Show a) =>
a -> m b -> m b
enterShow a
n = String -> m b -> m b
forall (m :: * -> *) a.
MonadError TraceError m =>
String -> m a -> m a
enter (a -> String
forall a. Show a => a -> String
show a
n)

enterDoc :: (MonadError TraceError m, Pretty d) => m d -> m a -> m a
enterDoc :: forall (m :: * -> *) d a.
(MonadError TraceError m, Pretty d) =>
m d -> m a -> m a
enterDoc m d
md m a
cont = do
  d <- m d
md
  enter (render (pretty d)) cont

failDoc :: (MonadError TraceError m) => m Doc -> m a
failDoc :: forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc m Doc
d = String -> m a
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg (String -> m a) -> (Doc -> String) -> Doc -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> m a) -> m Doc -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Doc
d

newErrorDoc :: (MonadError TraceError m) => m a -> m Doc -> m a
newErrorDoc :: forall (m :: * -> *) a.
MonadError TraceError m =>
m a -> m Doc -> m a
newErrorDoc m a
c m Doc
d = m a
c m a -> (TraceError -> m a) -> m a
forall a. m a -> (TraceError -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\ TraceError
_ -> m Doc -> m a
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc m Doc
d)

errorToMaybe :: (MonadError e m) => m a -> m (Maybe a)
errorToMaybe :: forall e (m :: * -> *) a. MonadError e m => m a -> m (Maybe a)
errorToMaybe m a
m = (m a
m m a -> (a -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just) m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)
forall a. m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (m (Maybe a) -> e -> m (Maybe a)
forall a b. a -> b -> a
const (m (Maybe a) -> e -> m (Maybe a))
-> m (Maybe a) -> e -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)

errorToBool :: (MonadError e m) => m () -> m Bool
errorToBool :: forall e (m :: * -> *). MonadError e m => m () -> m Bool
errorToBool m ()
m = (m ()
m m () -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) m Bool -> (e -> m Bool) -> m Bool
forall a. m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\ e
_ -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

boolToErrorDoc :: (MonadError TraceError m) => m Doc -> Bool -> m ()
boolToErrorDoc :: forall (m :: * -> *).
MonadError TraceError m =>
m Doc -> Bool -> m ()
boolToErrorDoc m Doc
_ Bool
True  = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
boolToErrorDoc m Doc
d Bool
False = m Doc -> m ()
forall (m :: * -> *) a. MonadError TraceError m => m Doc -> m a
failDoc m Doc
d

boolToError :: (MonadError TraceError m) => String -> Bool -> m ()
boolToError :: forall (m :: * -> *).
MonadError TraceError m =>
String -> Bool -> m ()
boolToError String
_   Bool
True  = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
boolToError String
msg Bool
False = String -> m ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg String
msg

-- defined in Control.Monad.Error.Class in mtl-2.2.2
#if !MIN_VERSION_mtl(2,2,2)
instance MonadError () Maybe where
  catchError Nothing k = k ()
  catchError (Just a) k = Just a
  throwError () = Nothing
#endif

orM :: (MonadError e m) => m a -> m a -> m a
orM :: forall e (m :: * -> *) a. MonadError e m => m a -> m a -> m a
orM m a
m1 m a
m2 = m a
m1 m a -> (e -> m a) -> m a
forall a. m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (m a -> e -> m a
forall a b. a -> b -> a
const m a
m2)

-- recoverable errors

data AssertionHandling = Failure | Warning | Ignore
                       deriving (AssertionHandling -> AssertionHandling -> Bool
(AssertionHandling -> AssertionHandling -> Bool)
-> (AssertionHandling -> AssertionHandling -> Bool)
-> Eq AssertionHandling
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AssertionHandling -> AssertionHandling -> Bool
== :: AssertionHandling -> AssertionHandling -> Bool
$c/= :: AssertionHandling -> AssertionHandling -> Bool
/= :: AssertionHandling -> AssertionHandling -> Bool
Eq,Eq AssertionHandling
Eq AssertionHandling =>
(AssertionHandling -> AssertionHandling -> Ordering)
-> (AssertionHandling -> AssertionHandling -> Bool)
-> (AssertionHandling -> AssertionHandling -> Bool)
-> (AssertionHandling -> AssertionHandling -> Bool)
-> (AssertionHandling -> AssertionHandling -> Bool)
-> (AssertionHandling -> AssertionHandling -> AssertionHandling)
-> (AssertionHandling -> AssertionHandling -> AssertionHandling)
-> Ord AssertionHandling
AssertionHandling -> AssertionHandling -> Bool
AssertionHandling -> AssertionHandling -> Ordering
AssertionHandling -> AssertionHandling -> AssertionHandling
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: AssertionHandling -> AssertionHandling -> Ordering
compare :: AssertionHandling -> AssertionHandling -> Ordering
$c< :: AssertionHandling -> AssertionHandling -> Bool
< :: AssertionHandling -> AssertionHandling -> Bool
$c<= :: AssertionHandling -> AssertionHandling -> Bool
<= :: AssertionHandling -> AssertionHandling -> Bool
$c> :: AssertionHandling -> AssertionHandling -> Bool
> :: AssertionHandling -> AssertionHandling -> Bool
$c>= :: AssertionHandling -> AssertionHandling -> Bool
>= :: AssertionHandling -> AssertionHandling -> Bool
$cmax :: AssertionHandling -> AssertionHandling -> AssertionHandling
max :: AssertionHandling -> AssertionHandling -> AssertionHandling
$cmin :: AssertionHandling -> AssertionHandling -> AssertionHandling
min :: AssertionHandling -> AssertionHandling -> AssertionHandling
Ord,Int -> AssertionHandling -> ShowS
[AssertionHandling] -> ShowS
AssertionHandling -> String
(Int -> AssertionHandling -> ShowS)
-> (AssertionHandling -> String)
-> ([AssertionHandling] -> ShowS)
-> Show AssertionHandling
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AssertionHandling -> ShowS
showsPrec :: Int -> AssertionHandling -> ShowS
$cshow :: AssertionHandling -> String
show :: AssertionHandling -> String
$cshowList :: [AssertionHandling] -> ShowS
showList :: [AssertionHandling] -> ShowS
Show)

assert' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> String -> m ()
assert' :: forall (m :: * -> *).
(MonadError TraceError m, MonadIO m) =>
AssertionHandling -> Bool -> String -> m ()
assert' AssertionHandling
Ignore Bool
_      String
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
assert' AssertionHandling
_       Bool
True  String
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
assert' AssertionHandling
Warning Bool
False String
s = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"warning: ignoring error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
assert' AssertionHandling
Failure Bool
False String
s = String -> m ()
forall (m :: * -> *) a. MonadError TraceError m => String -> m a
throwErrorMsg String
s

assertDoc' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> m Doc -> m ()
assertDoc' :: forall (m :: * -> *).
(MonadError TraceError m, MonadIO m) =>
AssertionHandling -> Bool -> m Doc -> m ()
assertDoc' AssertionHandling
h Bool
b m Doc
md = AssertionHandling -> Bool -> String -> m ()
forall (m :: * -> *).
(MonadError TraceError m, MonadIO m) =>
AssertionHandling -> Bool -> String -> m ()
assert' AssertionHandling
h Bool
b (String -> m ()) -> (Doc -> String) -> Doc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> m ()) -> m Doc -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Doc
md

class Monad m => MonadAssert m where
  assert :: Bool -> String -> m ()
  assertDoc :: Bool -> m Doc -> m ()
  assertDoc Bool
b m Doc
md = Bool -> String -> m ()
forall (m :: * -> *). MonadAssert m => Bool -> String -> m ()
assert Bool
b (String -> m ()) -> (Doc -> String) -> Doc -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> m ()) -> m Doc -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Doc
md
  newAssertionHandling :: AssertionHandling -> m a -> m a
  recoverFail :: String -> m ()
  recoverFail = Bool -> String -> m ()
forall (m :: * -> *). MonadAssert m => Bool -> String -> m ()
assert Bool
False
  recoverFailDoc :: m Doc -> m ()
  recoverFailDoc = Bool -> m Doc -> m ()
forall (m :: * -> *). MonadAssert m => Bool -> m Doc -> m ()
assertDoc Bool
False

{-
assert' :: (MonadIO m) => AssertionHandling -> Bool -> String -> m a -> m a
assert' Ignore b s k = k
assert' h True s k = k
assert' Warning False s k = do
  liftIO $ putStrLn s
  k
assert' Failure False s k = fail s

class Monad m => MonadAssert m where
  assert :: Bool -> String -> m a -> m a
  newAssertionHandling :: AssertionHandling -> m a -> m a
-}