Stateful computation with different types of short

问题:

I am trying to find the most elegant way of converting the following stateful imperative piece of code to pure functional representation (preferably in Haskell to use abstraction that its Monad implementation offers). However I am not yet good at combining different monads using transformers and the like. It seems to me, that analyzing other's takes on such tasks helps the best when learning how to do it myself. The imperative code:

while (true) {
  while (x = get()) { // Think of this as returning Maybe something
    put1(x) // may exit and present some failure representation
  }
  put2() // may exit and present some success representation
}

When get returns Nothing we need the execution to continue with put2, when get returns Just x we want the x to get passed to put1 and short-circuit only if put1 fails or loop otherwise. Basically put1 and put2 may terminate the whole thing or move to the following statement changing the underlying state somehow. get can either succeed and invoke put1 and loop or fail and continue to put2.

My idea was something along:

forever $ do
  forever (get >>= put1)
  put2

And why I was looking for something like that is because (get >>= put1) could simply short-circuit whenever get has nothing to return or put1 terminates. Similarly put2 terminates the outer loop. However I am not sure how to mix the State with the necessary Maybe and/or Either to achieve this.

I think using transformers to combine State and the other monads is necessary and thus the code will most probably not be that succint. But I guess it as well might not be much worse.

Any suggestion how to achieve the translation elegantly is welcome. This differs from "Stateful loop with different types of breaks" in avoiding explicit control-flow using if, when, while and rather tries to encourage use of Maybe, Either, or some other handy >>= semantics. Also there is always a straight-forward way how to translate the code into a functional one, however it can hardly be considered elegant.

回答1:

You are looking for EitherT or ExceptT. It adds two ways to return to a transformer stack. The computation can either return a or throwError e. There are two differences between errors and returns. Errors are held on the Left and returns on the Right. When you >>= onto an error it short circuits.

newtype EitherT e m a = EitherT { runEitherT :: m (Either e a) }

return :: a -> EitherT e m a
return a = EitherT $ return (Right a)

throwError :: e -> EitherT e m a
throwError e = EitherT $ return (Left a)

We will also use the names left = throwError and right = return.

Errors on the Left don't continue, we will use them to represent exiting from a loop. We will use the type EitherT r m () to represent a loop that either stops with a breaking result Left r or continues with a Right (). This is almost exactly forever, except we unwrap the EitherT and get rid of the Left around the returned value.

import Control.Monad
import Control.Monad.Trans.Either

untilLeft :: Monad m => EitherT r m () -> m r
untilLeft = liftM (either id id) . runEitherT . forever   

We'll come back to how to use these loops after fleshing out your example.

Since you want to see almost all of the logic disappear, we'll use EitherT for everything else too. The computation that gets data is either Done or returns the data.

import Control.Monad.Trans.Class
import Control.Monad.Trans.State

data Done = Done       deriving Show

-- Gets numbers for a while.
get1 :: EitherT Done (State Int) Int
get1 = do
    x <- lift get
    lift . put $ x + 1
    if x `mod` 3 == 0
    then left Done
    else right x

The first computation that puts data is either a Failure or returns.

data Failure = Failure deriving Show

put1 :: Int -> EitherT Failure (State Int) ()
put1 x = if x `mod` 16 == 0
         then left Failure
         else right ()

The second computation that puts data is either a Success or returns.

data Success = Success deriving Show

put2 :: EitherT Success (State Int) ()
put2 = do 
        x <- lift get
        if x `mod` 25 == 0
        then left Success
        else right ()

For your example, we will need to combine two or more computations that both stop exceptionally in different ways. We will represent this with two nested EitherTs.

EitherT o (EitherT i m) r

The outer EitherT is the one we are currently operating over. We can convert an EitherT o m a to an EitherT o (EitherT i m) a by adding an extra EitherT layer around every m^†.

over :: (MonadTrans t, Monad m) => EitherT e m a -> EitherT e (t m) a
over = mapEitherT lift

The inner EitherT layer will be treated just like any other underlying monad in the transformer stack. We can lift an EitherT i m a to an EitherT o (EitherT i m) a

We can now build an overall computation that either succeeds or fails. Computations that would break the current loop are operated over. Computations that would break an outer loop are lifted.

example :: EitherT Failure (State Int) Success
example =
    untilLeft $ do
        lift . untilLeft $ over get1 >>= lift . put1
        over put2

Overall Failure is lifted twice into the innermost loop. This example is sufficiently interesting to see a few different results.

main = print . map (runState $ runEitherT example) $ [1..30]

---

^†If EitherT had an MFunctor instance, over would just be hoist lift, which is a pattern that is used so often it deserves its own well thought out name. Incidentally, I use EitherT over ExceptT primarily because it has a less loaded name. Whichever one provides an MFunctor instance first will, for me, finally win out as the either monad transformer.

回答2:

However I am not yet good at combining different monads using transformers and the like.

You do not really need to combine different monads with combinators, you only need to explicitly embed the Maybe monad in the State monad. Once this is done, translating the snippet is straightforward, replacing loops by mutually recursive functions – the mutuality implements the branching conditions.

Let us write a solution this with OCaml and the sparkling monad library Lemonade where the State monad is called Lemonade_Success.

So, I assume that the type representing errors returned by put1 and put2 is a string, representing a diagnostic message, and we instantiate the Success monad on the String type:

Success =
  Lemonade_Success.Make(String)

Now, the Success module represents monadic computation which can fail with a diagnostic. See below for the complete signature of Success. I write the translation of the snippet above, as a functor parametrised by your data, but of course, you can shortcut this and directly uses the implementation definition. The data of your problem is described by a module Parameter having the signature P

module type P =
sig
    type t
    val get : unit -> t option
    val put1 : t -> unit Success.t
    val put2 : unit -> unit Success.t
end

A possible implementation of the snippet above would be

module M(Parameter:P) =
struct
    open Success.Infix

    let success_get () =
      match Parameter.get () with
        | Some(x) -> Success.return x
        | None -> Success.throw "Parameter.get"

    let rec innerloop () =
      Success.catch
        (success_get () >>= Parameter.put1 >>= innerloop)
        (Parameter.put2 >=> outerloop)
    and outerloop () =
      innerloop () >>= outerloop
end

The function get_success maps the Maybe monad to the Success monad, providing an ad-hoc error description. This is because you need this ad-hoc error description that you will not be able to do this transformation using only abstract monad combinators – or, to phrase this, more pedantically, there is no canonical mapping from Maybe into State because these mappings are parametrised by an error description.

Once the success_get function is written, it is pretty straightforward to translate the branching conditions you described using mutually recursive functions and the Success.catch function, used to handle error conditions.

I leave you the implementation in Haskell as an exercise. :)

---

The complete signature of the Success module is

  module Success :
  sig
    type error = String.t
    type 'a outcome =
      | Success of 'a
      | Error of error
    type 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
    val return : 'a -> 'a t
    val apply : ('a -> 'b) t -> 'a t -> 'b t
    val join : 'a t t -> 'a t
    val map : ('a -> 'b) -> 'a t -> 'b t
    val bind2 : 'a t -> 'b t -> ('a -> 'b -> 'c t) -> 'c t
    val bind3 : 'a t -> 'b t -> 'c t -> ('a -> 'b -> 'c -> 'd t) -> 'd t
    val bind4 :
      'a t -> 'b t -> 'c t -> 'd t -> ('a -> 'b -> 'c -> 'd -> 'e t) -> 'e t
    val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
    val map3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t
    val map4 :
      ('a -> 'b -> 'c -> 'd -> 'e) -> 'a t -> 'b t -> 'c t -> 'd t -> 'e t
    val dist : 'a t list -> 'a list t
    val ignore : 'a t -> unit t
    val filter : ('a -> bool t) -> 'a t list -> 'a list t
    val only_if : bool -> unit t -> unit t
    val unless : bool -> unit t -> unit t
    module Infix :
      sig
        val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t
        val ( <$> ) : ('a -> 'b) -> 'a t -> 'b t
        val ( <* ) : 'a t -> 'b t -> 'a t
        val ( >* ) : 'a t -> 'b t -> 'b t
        val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
        val ( >> ) : 'a t -> (unit -> 'b t) -> 'b t
        val ( >=> ) : ('a -> 'b t) -> ('b -> 'c t) -> 'a -> 'c t
        val ( <=< ) : ('b -> 'c t) -> ('a -> 'b t) -> 'a -> 'c t
      end
    val throw : error -> 'a t
    val catch : 'a t -> (error -> 'a t) -> 'a t
    val run : 'a t -> 'a outcome
  end

In order to stay succinct, I removed some type annotations and hid the natural transformation T from the signature.

回答3:

Your question is a bit tricky, because you are asking an elegant way of something which is not really elegant. There is the Control.Monad.Loops to write that type of loops. You'll probably need something like whileJust' or equivalent. Usually, we don't need to write while loops like that and plain old recursion is usually easiest.

I tried to find an example of when I would need this type of code and I came with the following example. I want to build a list of list of strings entered by the user. Each line correspond to an entry in the list. An empty line starts a new list, and two empty lines stops the loop.

Example

a
b
c

d
e

f

Will give

[ ["a", "b", "c"
, ["d", "e"]
, ["f"]
]

I would probably do the following in haskell

readMat :: IO [[String]]
readMat = reverse `fmap` go [[]]
    where go sss = do
                s <- getLine
                case s of
                    "" -> case sss of
                        []:sss' -> return sss' # the end
                        _ -> go ([]:sss)       # starts a new line
                    _ -> let (ss:ss') = sss
                          in go ((ss ++ [s]):ss')

Just plain recursion.

回答4:

This might overlap a bit with @Cirdec 's answer, but it also might help you gain a better perspective of what's going on.

The first thing to notice is that you really don't have doublely-nested loops. Without the exit statements, here is how you could write it as a simple loop:

example1 = forever $ do
  x <- getNext                -- get the next String
  if (isPrefixOf "break-" x)  -- do we break out of the "inner" loop?
    then put2 x
    else put1 x
  where
    put1 x = putStrLn $ "put1: " ++ x
    put2 x = putStrLn $ "put2: " ++ x

So now we just use the standard technique of using runEitherT for breaking out of a loop.

First some imports:

import Control.Monad
import Control.Monad.Trans.Either
import Control.Monad.State.Strict
import Data.List

and our result type and a convenience function:

data Result = Success String | Fail String deriving (Show)

exit = left

We then rewrite our loop lifting any IO actions and use exit when we want to break out of the loop:

example2 match =
  let loop = runEitherT $ forever $ do
        x <- getNext
        if isPrefixOf "break-" x
          then put2 x
          else put1 x
        where
          put1 "fail" = exit (Fail "fail encountered")
          put1 x      = liftIO $ putStrLn $ "put1: " ++ x

          put2 x      = if x == match
                          then exit (Success $ "found " ++ match)
                          else liftIO $ putStrLn $ "put2: " ++ x
  in loop

Here are some tests:

-- get next item from the state list:
getNext = do (x:xs) <- get; put xs; return x

test2a = evalStateT (example2 "break-foo") [ "a", "b", "fail" ]
test2b = evalStateT (example2 "break-foo") [ "a", "b", "break-foo", "c", "fail" ]
test2c = evalStateT (example2 "break-foo") [ "a", "b", "break-xxx", "c", "fail" ]

The output of these tests are:

ghci> test2a
put1: a
put1: b
Left (Fail "fail encountered")

ghci> test2b
put1: a
put1: b
Left (Success "found break-foo")

ghci> test2c
put1: a
put1: b
put2: break-xxx
put1: c
Left (Fail "fail encountered")

In this example the returned value of runEitherT will always be Left r where r is the Result value, so the code calling one of these examples might look like:

Left r <- test2a
case r of
  Success ... ->
  Fail    ... -> 

Note that instead of a custom Result type you could just use Either String String:

type Result = Either String String

and use Left for Fail and Right for Success.