{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Description : Miscellaneous Monads, in particular 'Computation.WithError'.
module Util.Computation (
        Answer,

        done,

        ( # ), -- reverse of application

        -- * exceptions and handlers
        propagate,
        try, -- re-export from Control.Exception
        tryUntilOK,
        raise,

        -- * selectors
        when, -- re-export from Control.Monad
        unless, -- re-export from Control.Monad
        incase,

        -- * iterators
        forever, -- re-export from Control.Monad
        foreverUntil,
        foreach,
        while,

        -- * configure command
        Config,
        configure,
        config,

        -- * The new-style configuration command
        HasConfig(..),

        -- * Returning results or error messages.
        WithError,

        hasError, -- :: String -> WithError a
        -- pass on an error

        hasValue, -- :: a -> WithError a
        -- pass on a value

        fromWithError, -- :: WithError a -> Either String a
        -- unpack a WithError
        fromWithError1, -- :: a -> WithError a -> a
        -- simpler form.
        toWithError, -- :: Either String a -> WithError a
        -- pack a WithError
        isError, -- :: WithError a -> Bool
        -- returns True if this value indicates an error.

        mapWithError, -- :: (a -> b) -> WithError a -> WithError b
        mapWithError', -- :: (a -> WithError b) -> WithError a -> WithError b
        mapWithErrorIO,
        -- :: (a -> IO b) -> WithError a -> IO (WithError b)
        mapWithErrorIO',
        -- :: (a -> IO (WithError b)) -> WithError a -> IO (WithError b)
        pairWithError, -- :: WithError a -> WithError b -> WithError (a,b)
        -- we concatenate the errors, inserting a newline between them if
        -- there are two.
        listWithError, -- :: [WithError a] -> WithError [a]
        coerceWithError, -- :: WithError a -> a
        coerceWithErrorIO, -- :: WithError a -> IO a
        -- get out result or throw error.
        -- The second throws the error immediately.
        coerceWithErrorStringIO, -- :: String -> WithError a -> IO a
        -- Like coerceWithErrorIO but also takes a String, which will
        -- be included in the eventual error message.

        coerceWithErrorOrBreakIOPrefix,
           -- :: String -> (String -> a) -> WithError a -> IO a
        coerceWithErrorOrBreakPrefix,
           -- :: String -> (String -> a) -> WithError a -> a

        MonadWithError(..),
        -- newtype which wraps a monadic action returning a WithError a.
        -- This is itself an instance of Monad, allowing functions defined
        -- on monads, such as mapM, work on them.
        monadifyWithError, -- :: Monad m => WithError a -> MonadWithError m a
        toMonadWithError, -- :: Monad m => m a -> MonadWithError m a

        coerceWithErrorOrBreak, -- :: (String -> a) -> WithError a -> a
        -- coerce or use the supplied break function (to be used with
        -- ExtendedPrelude.addFallOut)

        coerceWithErrorOrBreakIO, -- :: (String -> a) -> WithError a -> IO a
        -- coerce or use the supplied break function (to be used with
        -- ExtendedPrelude.addFallOut)
        -- The value is evaluated immediately.

        concatWithError, -- :: [WithError a] -> WithError [a]
        -- like pair but using lists.

        swapIOWithError, -- :: WithError (IO a) -> IO (WithError a)
        -- Intended for use on result of mapWithError, for example.

        exceptionToError,
        -- :: (Exception -> Maybe String) -> IO a -> IO (WithError a)
        -- Exception wrapper that turns those exceptions which map to
        -- (Just message) into an error.
        )
where

import Control.Applicative
import Control.Monad
import Control.Monad.Fail

import Control.Exception

import Util.Debug(debug)

infixr 2 #


-- --------------------------------------------------------------------------
-- Type Definitions
-- --------------------------------------------------------------------------

type Answer a = Either SomeException a

-- --------------------------------------------------------------------------
-- Done
-- --------------------------------------------------------------------------

done :: Monad m => m ()
done :: m ()
done = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- --------------------------------------------------------------------------
-- Method Application
-- --------------------------------------------------------------------------

( # ) :: a -> (a -> b) -> b
a
o # :: a -> (a -> b) -> b
# a -> b
f = a -> b
f a
o


-- --------------------------------------------------------------------------
-- IOError and Exception Handling
-- --------------------------------------------------------------------------

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)

-- --------------------------------------------------------------------------
-- Values paired with error messages
-- --------------------------------------------------------------------------

data WithError a =
      Error String
   |  Value a -- error or result

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)
-- we concatenate the errors, inserting a newline between them if there are two.
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

-- coerce or raise error
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)

-- | coerce or use the supplied break function (to be used with
-- 'ExtendedPrelude.addFallOut')
-- The value is evaluated immediately.
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]
""

-- | coerce or use the supplied break function (to be used with
-- 'ExtendedPrelude.addFallOut')
--
-- The first argument is prepended to any error message.
-- The value is evaluated immediately.
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)

-- | coerce or use the supplied break function (to be used with
-- 'ExtendedPrelude.addFallOut')
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]
""


-- | coerce or use the supplied break function (to be used with
-- 'ExtendedPrelude.addFallOut')
--
-- The first argument is prepended to any error message.
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)
   )

-- --------------------------------------------------------------------------
-- Derived Control Abstractions: Iteration
-- --------------------------------------------------------------------------

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)   -- mapM c el

-- --------------------------------------------------------------------------
-- Derived Control Abstractions: Selection
-- --------------------------------------------------------------------------

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}

-- --------------------------------------------------------------------------
-- Loops
-- --------------------------------------------------------------------------

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


-- --------------------------------------------------------------------------
-- Configuration Options
-- --------------------------------------------------------------------------

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


-- --------------------------------------------------------------------------
-- New-style configuration
-- Where HasConfig is defined you can type
--     option1  $$ option2 $$ ... $$ initial_configuration
-- --------------------------------------------------------------------------

class HasConfig option configuration where
   ($$) :: option -> configuration -> configuration

   configUsed :: option -> configuration -> Bool
   -- In some implementations (EG a text-only
   -- implementation of the GraphDisp interface)
   -- we may create default configurations in which $$ simply
   -- ignores the option.  In such cases configUsed should return
   -- False.

infixr 0 $$
-- This makes $$ have fixity like $.