{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Util.Computation (
Answer,
done,
( # ),
propagate,
try,
tryUntilOK,
raise,
when,
unless,
incase,
forever,
foreverUntil,
foreach,
while,
Config,
configure,
config,
HasConfig(..),
WithError,
hasError,
hasValue,
fromWithError,
fromWithError1,
toWithError,
isError,
mapWithError,
mapWithError',
mapWithErrorIO,
mapWithErrorIO',
pairWithError,
listWithError,
coerceWithError,
coerceWithErrorIO,
coerceWithErrorStringIO,
coerceWithErrorOrBreakIOPrefix,
coerceWithErrorOrBreakPrefix,
MonadWithError(..),
monadifyWithError,
toMonadWithError,
coerceWithErrorOrBreak,
coerceWithErrorOrBreakIO,
concatWithError,
swapIOWithError,
exceptionToError,
)
where
import Control.Applicative
import Control.Monad
import Control.Monad.Fail
import Control.Exception
import Util.Debug(debug)
infixr 2 #
type Answer a = Either SomeException a
done :: Monad m => m ()
done :: m ()
done = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
( # ) :: a -> (a -> b) -> b
a
o # :: a -> (a -> b) -> b
# a -> b
f = a -> b
f a
o
raise :: IOError -> IO a
raise :: IOError -> IO a
raise IOError
e =
do
[Char] -> IO ()
forall a. Show a => a -> IO ()
debug ([Char]
"RAISED EXCP: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (IOError -> [Char]
forall a. Show a => a -> [Char]
show IOError
e) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
IOError -> IO a
forall a. IOError -> IO a
ioError IOError
e
propagate :: Answer a -> IO a
propagate :: Answer a -> IO a
propagate (Left SomeException
e) = SomeException -> IO a
forall a e. Exception e => e -> a
throw SomeException
e
propagate (Right a
v) = a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
catchall :: IO a -> IO a -> IO a
catchall :: IO a -> IO a -> IO a
catchall IO a
c1 IO a
c2 = IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch IO a
c1 (\ (SomeException
_ :: SomeException) -> IO a
c2)
tryUntilOK :: IO a -> IO a
tryUntilOK :: IO a -> IO a
tryUntilOK IO a
c = IO a -> IO a -> IO a
forall a. IO a -> IO a -> IO a
catchall IO a
c (IO a -> IO a
forall a. IO a -> IO a
tryUntilOK IO a
c)
data WithError a =
Error String
| Value a
hasError :: String -> WithError a
hasError :: [Char] -> WithError a
hasError [Char]
str = [Char] -> WithError a
forall a. [Char] -> WithError a
Error [Char]
str
hasValue :: a -> WithError a
hasValue :: a -> WithError a
hasValue a
a = a -> WithError a
forall a. a -> WithError a
Value a
a
toWithError :: Either String a -> WithError a
toWithError :: Either [Char] a -> WithError a
toWithError (Left [Char]
s) = [Char] -> WithError a
forall a. [Char] -> WithError a
Error [Char]
s
toWithError (Right a
a) = a -> WithError a
forall a. a -> WithError a
Value a
a
isError :: WithError a -> Bool
isError :: WithError a -> Bool
isError (Error [Char]
_) = Bool
True
isError (Value a
_) = Bool
False
fromWithError :: WithError a -> Either String a
fromWithError :: WithError a -> Either [Char] a
fromWithError (Error [Char]
s) = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left [Char]
s
fromWithError (Value a
a) = a -> Either [Char] a
forall a b. b -> Either a b
Right a
a
fromWithError1 :: a -> WithError a -> a
fromWithError1 :: a -> WithError a -> a
fromWithError1 a
_ (Value a
a) = a
a
fromWithError1 a
a (Error [Char]
_) = a
a
mapWithError :: (a -> b) -> WithError a -> WithError b
mapWithError :: (a -> b) -> WithError a -> WithError b
mapWithError a -> b
f (Error [Char]
e) = [Char] -> WithError b
forall a. [Char] -> WithError a
Error [Char]
e
mapWithError a -> b
f (Value a
x) = b -> WithError b
forall a. a -> WithError a
Value (a -> b
f a
x)
mapWithError' :: (a -> WithError b) -> WithError a -> WithError b
mapWithError' :: (a -> WithError b) -> WithError a -> WithError b
mapWithError' a -> WithError b
f (Error [Char]
e) = [Char] -> WithError b
forall a. [Char] -> WithError a
Error [Char]
e
mapWithError' a -> WithError b
f (Value a
a) = a -> WithError b
f a
a
mapWithErrorIO :: (a -> IO b) -> WithError a -> IO (WithError b)
mapWithErrorIO :: (a -> IO b) -> WithError a -> IO (WithError b)
mapWithErrorIO a -> IO b
f (Error [Char]
e) = WithError b -> IO (WithError b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> WithError b
forall a. [Char] -> WithError a
Error [Char]
e)
mapWithErrorIO a -> IO b
f (Value a
a) =
do
b
b <- a -> IO b
f a
a
WithError b -> IO (WithError b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> WithError b
forall a. a -> WithError a
Value b
b)
mapWithErrorIO' :: (a -> IO (WithError b)) -> WithError a -> IO (WithError b)
mapWithErrorIO' :: (a -> IO (WithError b)) -> WithError a -> IO (WithError b)
mapWithErrorIO' a -> IO (WithError b)
f (Error [Char]
e) = WithError b -> IO (WithError b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> WithError b
forall a. [Char] -> WithError a
Error [Char]
e)
mapWithErrorIO' a -> IO (WithError b)
f (Value a
a) = a -> IO (WithError b)
f a
a
pairWithError :: WithError a -> WithError b -> WithError (a,b)
pairWithError :: WithError a -> WithError b -> WithError (a, b)
pairWithError (Value a
a) (Value b
b) = (a, b) -> WithError (a, b)
forall a. a -> WithError a
Value (a
a,b
b)
pairWithError (Error [Char]
e) (Value b
b) = [Char] -> WithError (a, b)
forall a. [Char] -> WithError a
Error [Char]
e
pairWithError (Value a
a) (Error [Char]
f) = [Char] -> WithError (a, b)
forall a. [Char] -> WithError a
Error [Char]
f
pairWithError (Error [Char]
e) (Error [Char]
f) = [Char] -> WithError (a, b)
forall a. [Char] -> WithError a
Error ([Char]
e[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
f)
listWithError :: [WithError a] -> WithError [a]
listWithError :: [WithError a] -> WithError [a]
listWithError [WithError a]
awes =
(WithError a -> WithError [a] -> WithError [a])
-> WithError [a] -> [WithError a] -> WithError [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\ WithError a
awe WithError [a]
awes ->
((a, [a]) -> [a]) -> WithError (a, [a]) -> WithError [a]
forall a b. (a -> b) -> WithError a -> WithError b
mapWithError
(\ (a
a,[a]
as) -> a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as)
(WithError a -> WithError [a] -> WithError (a, [a])
forall a b. WithError a -> WithError b -> WithError (a, b)
pairWithError WithError a
awe WithError [a]
awes)
)
([a] -> WithError [a]
forall a. a -> WithError a
hasValue [])
[WithError a]
awes
coerceWithError :: WithError a -> a
coerceWithError :: WithError a -> a
coerceWithError (Value a
a) = a
a
coerceWithError (Error [Char]
err) = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
err
coerceWithErrorIO :: WithError a -> IO a
coerceWithErrorIO :: WithError a -> IO a
coerceWithErrorIO (Value a
a) = a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
coerceWithErrorIO (Error [Char]
err) = [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
err
coerceWithErrorStringIO :: String -> WithError a -> IO a
coerceWithErrorStringIO :: [Char] -> WithError a -> IO a
coerceWithErrorStringIO [Char]
_ (Value a
a) = a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
coerceWithErrorStringIO [Char]
mess (Error [Char]
err) =
[Char] -> IO a
forall a. HasCallStack => [Char] -> a
error ([Char]
"coerceWithErrorString " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mess [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
coerceWithErrorOrBreakIO :: (String -> a) -> WithError a -> IO a
coerceWithErrorOrBreakIO :: ([Char] -> a) -> WithError a -> IO a
coerceWithErrorOrBreakIO = [Char] -> ([Char] -> a) -> WithError a -> IO a
forall a. [Char] -> ([Char] -> a) -> WithError a -> IO a
coerceWithErrorOrBreakIOPrefix [Char]
""
coerceWithErrorOrBreakIOPrefix
:: String -> (String -> a) -> WithError a -> IO a
coerceWithErrorOrBreakIOPrefix :: [Char] -> ([Char] -> a) -> WithError a -> IO a
coerceWithErrorOrBreakIOPrefix [Char]
errorPrefix [Char] -> a
breakFn WithError a
aWe =
do
let
a :: a
a = [Char] -> ([Char] -> a) -> WithError a -> a
forall a. [Char] -> ([Char] -> a) -> WithError a -> a
coerceWithErrorOrBreakPrefix [Char]
errorPrefix [Char] -> a
breakFn WithError a
aWe
a -> IO a -> IO a
seq a
a (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)
coerceWithErrorOrBreak :: (String -> a) -> WithError a -> a
coerceWithErrorOrBreak :: ([Char] -> a) -> WithError a -> a
coerceWithErrorOrBreak = [Char] -> ([Char] -> a) -> WithError a -> a
forall a. [Char] -> ([Char] -> a) -> WithError a -> a
coerceWithErrorOrBreakPrefix [Char]
""
coerceWithErrorOrBreakPrefix :: String -> (String -> a) -> WithError a -> a
coerceWithErrorOrBreakPrefix :: [Char] -> ([Char] -> a) -> WithError a -> a
coerceWithErrorOrBreakPrefix [Char]
errorPrefix [Char] -> a
breakFn (Value a
a) = a
a
coerceWithErrorOrBreakPrefix [Char]
errorPrefix [Char] -> a
breakFn (Error [Char]
s)
= [Char] -> a
breakFn ([Char]
errorPrefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s)
concatWithError :: [WithError a] -> WithError [a]
concatWithError :: [WithError a] -> WithError [a]
concatWithError [WithError a]
withErrors =
(WithError a -> WithError [a] -> WithError [a])
-> WithError [a] -> [WithError a] -> WithError [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\ WithError a
wE WithError [a]
wEsf -> ((a, [a]) -> [a]) -> WithError (a, [a]) -> WithError [a]
forall a b. (a -> b) -> WithError a -> WithError b
mapWithError ((a -> [a] -> [a]) -> (a, [a]) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:)) (WithError a -> WithError [a] -> WithError (a, [a])
forall a b. WithError a -> WithError b -> WithError (a, b)
pairWithError WithError a
wE WithError [a]
wEsf))
([a] -> WithError [a]
forall a. a -> WithError a
Value [])
[WithError a]
withErrors
swapIOWithError :: WithError (IO a) -> IO (WithError a)
swapIOWithError :: WithError (IO a) -> IO (WithError a)
swapIOWithError (Error [Char]
e) = WithError a -> IO (WithError a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> WithError a
forall a. [Char] -> WithError a
Error [Char]
e)
swapIOWithError (Value IO a
act) =
do
a
v <- IO a
act
WithError a -> IO (WithError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> WithError a
forall a. a -> WithError a
Value a
v)
exceptionToError :: Exception e => (e -> Maybe String) -> IO a -> IO (WithError a)
exceptionToError :: (e -> Maybe [Char]) -> IO a -> IO (WithError a)
exceptionToError e -> Maybe [Char]
testFn IO a
action =
(e -> Maybe [Char])
-> IO (WithError a)
-> ([Char] -> IO (WithError a))
-> IO (WithError a)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust
e -> Maybe [Char]
testFn
(do
a
val <- IO a
action
WithError a -> IO (WithError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> WithError a
forall a. a -> WithError a
hasValue a
val)
)
(\ [Char]
str -> WithError a -> IO (WithError a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> WithError a
forall a. [Char] -> WithError a
hasError [Char]
str))
instance Functor WithError where
fmap :: (a -> b) -> WithError a -> WithError b
fmap a -> b
aToB WithError a
aWE = case WithError a
aWE of
Value a
a -> b -> WithError b
forall a. a -> WithError a
Value (a -> b
aToB a
a)
Error [Char]
e -> [Char] -> WithError b
forall a. [Char] -> WithError a
Error [Char]
e
instance Applicative WithError where
pure :: a -> WithError a
pure = a -> WithError a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: WithError (a -> b) -> WithError a -> WithError b
(<*>) = WithError (a -> b) -> WithError a -> WithError b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad WithError where
return :: a -> WithError a
return a
v = a -> WithError a
forall a. a -> WithError a
hasValue a
v
>>= :: WithError a -> (a -> WithError b) -> WithError b
(>>=) WithError a
aWE a -> WithError b
toBWe =
(a -> WithError b) -> WithError a -> WithError b
forall a b. (a -> WithError b) -> WithError a -> WithError b
mapWithError' a -> WithError b
toBWe WithError a
aWE
instance MonadFail WithError where
fail :: [Char] -> WithError a
fail [Char]
s = [Char] -> WithError a
forall a. [Char] -> WithError a
hasError [Char]
s
newtype MonadWithError m a = MonadWithError (m (WithError a))
instance Monad m => Functor (MonadWithError m) where
fmap :: (a -> b) -> MonadWithError m a -> MonadWithError m b
fmap a -> b
f (MonadWithError m (WithError a)
a) = m (WithError b) -> MonadWithError m b
forall (m :: * -> *) a. m (WithError a) -> MonadWithError m a
MonadWithError (m (WithError b) -> MonadWithError m b)
-> m (WithError b) -> MonadWithError m b
forall a b. (a -> b) -> a -> b
$ (WithError a -> WithError b) -> m (WithError a) -> m (WithError b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a -> b) -> WithError a -> WithError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) m (WithError a)
a
instance Monad m => Applicative (MonadWithError m) where
pure :: a -> MonadWithError m a
pure = a -> MonadWithError m a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: MonadWithError m (a -> b)
-> MonadWithError m a -> MonadWithError m b
(<*>) = MonadWithError m (a -> b)
-> MonadWithError m a -> MonadWithError m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad m => Monad (MonadWithError m) where
return :: a -> MonadWithError m a
return a
v = m (WithError a) -> MonadWithError m a
forall (m :: * -> *) a. m (WithError a) -> MonadWithError m a
MonadWithError (WithError a -> m (WithError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> WithError a
forall a. a -> WithError a
Value a
v))
>>= :: MonadWithError m a
-> (a -> MonadWithError m b) -> MonadWithError m b
(>>=) (MonadWithError m (WithError a)
act1) a -> MonadWithError m b
getAct2 =
m (WithError b) -> MonadWithError m b
forall (m :: * -> *) a. m (WithError a) -> MonadWithError m a
MonadWithError (
do
WithError a
valWithError <- m (WithError a)
act1
case WithError a
valWithError of
Value a
v ->
let
(MonadWithError m (WithError b)
act2) = a -> MonadWithError m b
getAct2 a
v
in
m (WithError b)
act2
Error [Char]
s -> WithError b -> m (WithError b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> WithError b
forall a. [Char] -> WithError a
Error [Char]
s)
)
instance MonadFail m => MonadFail (MonadWithError m) where
fail :: [Char] -> MonadWithError m a
fail [Char]
s = m (WithError a) -> MonadWithError m a
forall (m :: * -> *) a. m (WithError a) -> MonadWithError m a
MonadWithError (WithError a -> m (WithError a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> WithError a
forall a. [Char] -> WithError a
Error [Char]
s))
monadifyWithError :: Monad m => WithError a -> MonadWithError m a
monadifyWithError :: WithError a -> MonadWithError m a
monadifyWithError WithError a
we = m (WithError a) -> MonadWithError m a
forall (m :: * -> *) a. m (WithError a) -> MonadWithError m a
MonadWithError (WithError a -> m (WithError a)
forall (m :: * -> *) a. Monad m => a -> m a
return WithError a
we)
toMonadWithError :: Monad m => m a -> MonadWithError m a
toMonadWithError :: m a -> MonadWithError m a
toMonadWithError m a
act = m (WithError a) -> MonadWithError m a
forall (m :: * -> *) a. m (WithError a) -> MonadWithError m a
MonadWithError (
do
a
a <- m a
act
WithError a -> m (WithError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> WithError a
forall a. a -> WithError a
hasValue a
a)
)
foreverUntil :: Monad m => m Bool -> m ()
foreverUntil :: m Bool -> m ()
foreverUntil m Bool
act =
do
Bool
stop <- m Bool
act
if Bool
stop
then
m ()
forall (m :: * -> *). Monad m => m ()
done
else
m Bool -> m ()
forall (m :: * -> *). Monad m => m Bool -> m ()
foreverUntil m Bool
act
foreach :: Monad m => [a] -> (a -> m b) -> m ()
foreach :: [a] -> (a -> m b) -> m ()
foreach [a]
el a -> m b
c = [m b] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ((a -> m b) -> [a] -> [m b]
forall a b. (a -> b) -> [a] -> [b]
map a -> m b
c [a]
el)
incase :: Maybe a -> (a -> IO b) -> IO ()
incase :: Maybe a -> (a -> IO b) -> IO ()
incase Maybe a
Nothing a -> IO b
f = IO ()
forall (m :: * -> *). Monad m => m ()
done
incase (Just a
a) a -> IO b
f = do {a -> IO b
f a
a; IO ()
forall (m :: * -> *). Monad m => m ()
done}
while :: Monad m => m a -> (a -> Bool) -> m a
while :: m a -> (a -> Bool) -> m a
while m a
c a -> Bool
p = m a
c m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> if (a -> Bool
p a
x) then m a -> (a -> Bool) -> m a
forall (m :: * -> *) a. Monad m => m a -> (a -> Bool) -> m a
while m a
c a -> Bool
p else a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
type Config w = w -> IO w
configure :: w -> [Config w] -> IO w
configure :: w -> [Config w] -> IO w
configure w
w [] = Config w
forall (m :: * -> *) a. Monad m => a -> m a
return w
w
configure w
w (Config w
c:[Config w]
cl) = do {w
w' <- Config w
c w
w; w -> [Config w] -> IO w
forall w. w -> [Config w] -> IO w
configure w
w' [Config w]
cl}
config :: IO () -> Config w
config :: IO () -> Config w
config IO ()
f w
w = IO ()
f IO () -> IO w -> IO w
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Config w
forall (m :: * -> *) a. Monad m => a -> m a
return w
w
class HasConfig option configuration where
($$) :: option -> configuration -> configuration
configUsed :: option -> configuration -> Bool
infixr 0 $$