as Thomas pointed out off-list, the transformation sequence as given is not type-preserving. i even documented that problem in my email, because i thought the type was dodgy, but forgot to track it down before posting. so here are the changes. a good demonstration that "does it still compile?" is not a sufficient test for refactoring!-) claus
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 also need to take into account that the second readTVar already returns a Maybe, so we only need to wrap it in MaybeT, without applying the full lift.
we could now declare the type as
dmin' :: TVar (Trie t) -> MaybeT STM (Maybe t, Bool)
there's that dodgy type. it should just be: dmin' :: TVar (Trie t) -> MaybeT STM (t, Bool)
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) >>=
it was the return-wrapping of lift that introduced the extra Maybe here. this TVar already holds Maybes, so this should just be: `mplus` (((MaybeT $ readTVar m) >>=
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 use this feature to replace the "half-lifted" second readTVar with a fully lifted readTVar' followed by a pattern match on 'Just v'.
--------------------------------------------- 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
by employing pattern-match failure handling, this can become: `mplus` (do Just 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