Claus Reinke | 15 Jul 21:08 2007

Re: Indentation Creep

> Everyone's suggestions show that in order to advance to a level 3
> Haskell Mage[*], I need to spend a chunk of time learning to grok
> monad transformers.

let's see whether we can get from the initial version to the suggested 
final version without any magic, in a somewhat long sequence of 
minor rewrites/refactorings. i won't list all intermediate stages (the 
derivation is long enough as it is), and i hope that readers will find 
this interesting in spite of its length (you might want to load the initial 
version into your editor and follow along as you read the refactoring 
notes below).

enjoy (i hope:-),
claus

    --------------------------------------------- initial version
    dmin p = do
        mv <- dmin' p
        case mv of
            Nothing -> error "dmin: no values"
            Just (v,_) -> return v

    dmin' p = do
        t <- readTVar p
        case t of
            Empty -> return Nothing
            Trie l m r -> do
                mv <- dmin' l
                case mv of
                    Nothing -> do
                        mv <- readTVar m
                        case mv of
                            Nothing -> do
                                mv <- dmin' r
                                case mv of
                                    Nothing -> error "emit nasal daemons"
                                    Just (v,e) -> do
                                        if e
                                            then writeTVar p Empty
                                            else return ()
                                        return mv
                            Just v -> do
                                re <- nullT r
                                case re of
                                    False -> writeTVar m Nothing
                                    True  -> writeTVar p Empty
                                return (Just (v,re))
                    Just (v,e) -> do
                        case e of
                            True -> do
                                me <- empty m
                                re <- nullT r
                                case me && re of
                                    False -> writeTVar m Nothing
                                    True  -> writeTVar p Empty
                                return (Just (v,me && re))
                            False -> return mv
        where
        nullT :: Monad m => TriePtr t -> m Bool
        nullT t = undefined
        empty m = do
            v <- readTVar m
            case v of
                Nothing -> return True
                Just _  -> return False
    --------------------------------------------- initial version

simple things first:

in dmin:
  replace case with maybe 
  use =<< to avoid intermediate mv
  replace lambda with (return . fst)

in empty:
  replace case with maybe 
  lift return out of the branches
  use =<< to avoid intermediate v
  'maybe True (const False)' is (Data.Maybe) isNothing
  use liftM to apply isNothing

in dmin':
  use (Control.Monad) 'when e .' to replace 'if e then . else return ()'
  create and use (2x) function 'write'

    write m p (v,False) = writeTVar m Nothing >> return (Just (v,False))
    write m p (v,True ) = writeTVar p Empty   >> return (Just (v,True))

  now, on to slightly bigger rewrites:
  inside-out, replace 'case . of Nothing -> .; Just . -> .' with maybe

    case mv of
        Nothing -> error "emit nasal daemons"
        Just (v,e) -> do
            when e $ writeTVar p Empty
            return mv

  becomes

    maybe (error "emit nasal daemons")
          (\(v,e) -> do
            when e $ writeTVar p Empty
            return mv)
          mv

  and so on, for all three levels of case (in the outermost case, one
  'return mv' needs to be replaced with 'return (Just (v,e))', we'll do
  the same for the other 'return mv', for clarity)

  at this stage, the code looks somewhat like this:

    dmin p = maybe (error "dmin: no values") (return . fst) =<< dmin' p

    dmin' p = do
        t <- readTVar p
        case t of
            Empty -> return Nothing
            Trie l m r -> do
                mv <- dmin' l
                maybe (do
                        mv <- readTVar m
                        maybe (do
                                mv <- dmin' r
                                maybe (error "emit nasal daemons")
                                      (\(v,e) -> do
                                        when e $ writeTVar p Empty
                                        return (Just (v,e)))
                                      mv)
                              (\v -> do
                                re <- nullT r
                                write m p (v,re))
                              mv)
                      (\(v,e) -> do
                        case e of
                            True -> do
                                me <- empty m
                                re <- nullT r
                                write m p (v,me && re)
                            False -> return (Just (v,e)))
                      mv
        where
        write m p (v,False) = writeTVar m Nothing >> return (Just (v,False))
        write m p (v,True ) = writeTVar p Empty   >> return (Just (v,True))

        nullT :: Monad m => TriePtr t -> m Bool
        nullT t = undefined

        empty m = liftM isNothing $ readTVar m

  we'd still like to get rid of the nesting, and we see the pattern 

    action >>= maybe (nontrivialB) (nontrivialA)

  repeatedly, which strongly suggests the use of (MonadPlus) 'mplus'

    (action >>= nontrivialA) `mplus` nontrivialB

  the problem is that those Maybes are interleaved with STM operations.

  as a first step, we can define our own 'mplus' for the special case of
  'STM (Maybe a)', where we want the alternatives to be controlled by
  the Maybe result of the outer monad (STM in this case):

    a `mplus` b = (a >>= maybe b (return . Just))

  however, our pattern is slightly more complex: there's always another
  STM operation to be executed first (readTVar or dmin'), and the result
  of that operation selects the branch, so we also need to define our
  own version of sequential composition:

    a >>> b = a >>= maybe (return Nothing) b

  now, we can rewrite the pattern 

    do { v<-op; maybe that this v }

  to, using our own combinator versions,

    (op >>> this) `mplus` that

  so that

    do
      mv <- dmin' r
      maybe (error "emit nasal daemons")
            (\(v,e) -> do
              when e $ writeTVar p Empty
              return (Just (v,e)))
            mv

  turns into

    (dmin' r >>>
          (\ (v,e) -> do
            when e $ writeTVar p Empty
            return (Just (v,e))))
     `mplus` (error "emit nasal daemons")

  again, we apply this rewriting inside out to all three levels of
  maybe, which gives us something like this code:

    dmin' p = do
        t <- readTVar p
        case t of
            Empty -> return Nothing
            Trie l m r -> 
               (dmin' l >>>
                      (\(v,e) -> do
                        case e of
                            True -> do
                                me <- empty m
                                re <- nullT r
                                write m p (v,me && re)
                            False -> return (Just (v,e))))
                `mplus` ((readTVar m >>>
                              (\v -> do
                                re <- nullT r
                                write m p (v,re)))
                `mplus` ((dmin' r >>>
                              (\ (v,e) -> do
                                when e $ writeTVar p Empty
                                return (Just (v,e))))
                `mplus` (error "emit nasal daemons")))
        where
        a `mplus` b = (a >>= maybe b (return . Just))
        a  >>> b    = a >>= maybe (return Nothing) b

        write m p (v,False) = writeTVar m Nothing >> return (Just (v,False))
        write m p (v,True ) = writeTVar p Empty   >> return (Just (v,True))

        nullT :: Monad m => TriePtr t -> m Bool
        nullT t = undefined

        empty m = liftM isNothing $ readTVar m

  which already gets rid of most of the indentation creep. next, we want
  to turn our local combinators into proper Monad/MonadPlus instances,
  to avoid confusion and to get back the do-notation. since both these
  classes are defined over type constructors, rather than plain types,
  we need a type constructor that captures the composition of STM and
  Maybe in 'STM (Maybe a)'. actually, our combinators only depend on 
  the composition of some Monad m with Maybe:

    data MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }

  the Monad instance is almost exactly what we expect, using the
  definition of >>> we already have, with some added wrapping and
  unwrapping for our "type constructor composition constructor" 
  (aka monad transformer;-):

    instance Monad m => Monad (MaybeT m) where
      return  = MaybeT . return . Just
      a >>= b = MaybeT $ runMaybeT a >>= maybe (return Nothing) (runMaybeT . b)

  the MonadPlus instance is just what we expect, using our mplus
  definition with some extra wrapping and unwrapping.

    instance Monad m => MonadPlus (MaybeT m) where
      mzero       = MaybeT $ return Nothing
      a `mplus` b = MaybeT $ runMaybeT a >>= maybe (runMaybeT b) (return . Just)

  now, before we can apply our shiny new instances to our code, there is
  the issue of plain STM operations like writeTVar and readTVar. when
  running code in our composed monad, we still want to be able to run
  operations in the wrapped inner monad. the standard way to do that is
  to define a 'lift' operation for lifting inner monad operations to the
  composed monad. so standard, in fact, that there is a class for this,
  (Control.Monad.Trans) MonadTrans, and we only need to define an
  instance for our wrapper:

    instance MonadTrans MaybeT where
      lift m = MaybeT $ m >>= return . Just

  to prepare for our next step, we apply lift to all barebones STM
  operations, readTVar, write, empty, nullT. at this stage, our types
  (asking ghci, with :t dmin') are slightly redundant:

    dmin' :: (MonadTrans t1, Monad (t1 STM)) 
          => TVar (Trie t) -> t1 STM (Maybe (t, Bool))

  since our particular MonadTrans, MaybeT, already wraps results in
  Maybe, this is one level of Maybe too much. so, when we remove our
  local definitions of mplus and >>> (replacing >>> with >>=), we remove
  that extra layer of Maybe, by removing the redundant (Just _) in
  returns, and by replacing 'return Nothing' with 'mzero'. we could now
  declare the type as

    dmin' :: TVar (Trie t) -> MaybeT STM (Maybe t, Bool)

  to retain compatibility, we also need to apply runMaybeT in dmin, 
  unwrapping (dmin' p).

  after all that refactoring, the code should look something like this:

    dmin p = maybe (error "dmin: no values") (return . fst) 
                =<< runMaybeT (dmin' p)

    dmin' p = do
        t <- lift $ readTVar p
        case t of
            Empty -> mzero
            Trie l m r -> 
                (dmin' l >>=
                        (\ (v,e) -> do
                          case e of
                              True -> do
                                  me <- lift $ empty m
                                  re <- lift $ nullT r
                                  lift $ write m p (v,me && re)
                              False -> return (v,e)))
                `mplus` (((lift $ readTVar m) >>=
                               (\ v -> do
                                re <- lift $ nullT r
                                lift $ write m p (v,re)))
                `mplus` ((dmin' r >>= 
                               (\ (v,e) -> do
                                when e $ lift $ writeTVar p Empty
                                return (v,e)))
                `mplus` (error "emit nasal daemons")))
        where
        write m p (v,False) = writeTVar m Nothing >> return (v,False)
        write m p (v,True ) = writeTVar p Empty   >> return (v,True)

        nullT :: Monad m => TriePtr t -> m Bool
        nullT t = undefined

        empty m = liftM isNothing $ readTVar m

  to clean up, we reapply do-notation instead of >>=, drop some
  redundant parentheses for mplus, and move the lift calls to the
  definitions of empty, nullT, etc., creating lifted variants 
  readTVar' and writeTVar'.

  next, we can make use of the fact that pattern match failure in
  do-notation invokes fail in the monad, by defining 'fail msg = mzero'
  in our wrapped monad, and by pattern matching directly on the result
  of the first readTVar' (we only need the Trie-case, the other case
  will fail to match, leading to mzero, which is what we wanted anyway).

  we can also replace the remaining 'case e of True ..' by appealing to
  'guard e' and mzero. 

  at which stage our code looks sufficiently similar to Miguel's. we
  still don't need to have any idea what the code is supposed to do, 
  as long as we haven't made any mistakes in refactoring, the final
  version should do the same thing as the initial version. usually, 
  one would use a testsuite or a proven tool to monitor the steps,
  whereas my only test was "does it still compile?", which gives no
  assurance that the code transformations were indeed refactorings. 

  no magic involved, just repeated simplifications, generalizations, 
  and use of sufficiently advanced technology!-) by noticing that
  there was something about your code you didn't like, and looking
  for improvements, you've already done the most important step.

  as long as you remain determined to keep reviewing and simplifying
  your code, the route to "higher levels" isn't all that steep. part of
  the reason why i take part in such rewrite exercises on this list is
  to hone my own skills - there is always something more to learn;-)

    --------------------------------------------- final version
    dmin p = maybe (error "dmin: no values") (return . fst) 
               =<< runMaybeT (dmin' p)

    dmin' p = do
        Trie l m r <- readTVar' p
        (do (v,e) <- dmin' l
            (do guard e
                me <- empty m
                re <- nullT r
                write m p (v,me && re))
             `mplus` return ((v,e)))
         `mplus` (do v <- readTVar' m
                     re <- nullT r
                     write m p (v,re))
         `mplus` (do (v,e) <- dmin' r
                     when e $ writeTVar' p Empty
                     return ((v,e)))
         `mplus` error "emit nasal daemons"
        where
        readTVar'  var     = lift $ readTVar var
        writeTVar' var val = lift $ writeTVar var val

        write m p (v,False) = lift $ writeTVar m Nothing >> return ((v,False))
        write m p (v,True ) = lift $ writeTVar p Empty   >> return ((v,True))

        nullT :: Monad m => TriePtr t -> m Bool
        nullT t = undefined

        empty m = lift $ liftM isNothing $ readTVar m

    data MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }

    instance Monad m => Monad (MaybeT m) where
      return  = MaybeT . return . Just
      a >>= b = MaybeT $ runMaybeT a >>= maybe (return Nothing) (runMaybeT . b)
      fail msg= mzero

    instance Monad m => MonadPlus (MaybeT m) where
      mzero       = MaybeT $ return Nothing
      a `mplus` b = MaybeT $ runMaybeT a >>= maybe (runMaybeT b) (return . Just)

    instance MonadTrans MaybeT where
      lift m = MaybeT $ m >>= return . Just

    --------------------------------------------- final version

Gmane