Создание недетерминированного преобразователя монад в Haskell

Я хотел бы построить недетерминированный преобразователь монады в Haskell, который, как мне кажется, ведет себя иначе, чем ListT и альтернативный ListT, предложенный на http://www.haskell.org/haskellwiki/ListT_done_right. Первый из них связывает монаду со списком элементов; второй связывает монаду с отдельными элементами, но обладает тем свойством, что монадические действия в данном элементе влияют на монадические элементы в последующих слотах списка. Цель состоит в том, чтобы построить монадный преобразователь вида

data Amb m a = Cons (m a) (Amb m a) | Empty

так что каждый элемент списка имеет свою собственную монаду, связанную с ним, и что последующие элементы имеют независимые монады. В конце этого поста у меня есть небольшая демонстрация того, какое поведение должна давать эта монада. Если вы знаете, как заставить какой-либо вариант ListT обеспечивать такое поведение, это тоже будет полезно.

Ниже моя попытка. Он неполный, потому что функция unpack не определена. Как я могу определить это? Вот одна неполная попытка его определения, но она не учитывает случай, когда монада m содержит список Empty Amb:

unpack :: (Monad m) => m (Amb m a) -> Amb m a                                                                                                                 
unpack m = let first = join $ do (Cons x ys) <- m                                                                                                             
                                 return x                                                                                                                     
               rest =  do (Cons x ys) <- m                                                                                                                    
                          return ys                                                                                                                           
           in Cons first (unpack rest)   

Полный (неполный) код:

import Prelude hiding  (map, concat)                                                                                                                          
import Control.Monad                                                                                                                                          
import Control.Monad.Trans       

data Amb m a = Cons (m a) (Amb m a) | Empty                                                                                                                   

infixr 4 <:>                                                                                                                                                  
(<:>) = Cons                                                                                                                                                  

map :: Monad m => (a -> b) -> Amb m a -> Amb m b                                                                                                              
map f (Cons m xs) = Cons y (map f xs)                                                                                                                         
    where y = do a <- m                                                                                                                                       
                 return $ f a                                                                                                                                 
map f Empty = Empty                                                                                                                                           

unpack :: m (Amb m a) -> Amb m a                                                                                                                              
unpack m = undefined                                                                                                                                          


concat :: (Monad m) => Amb m (Amb m a) -> Amb m a                                                                                                             
concat (Cons m xs)  = (unpack m) `mplus` (concat xs)                                                                                                          
concat  Empty = Empty                                                                                                                                         

instance Monad m => Monad (Amb m) where                                                                                                                       
    return x = Cons (return x) Empty                                                                                                                          
    xs >>= f = let yss = map f xs                                                                                                                             
               in concat yss                                                                                                                                  

instance Monad m => MonadPlus (Amb m) where                                                                                                                   
    mzero = Empty                                                                                                                                             
    (Cons m xs) `mplus` ys = Cons m (xs `mplus` ys)                                                                                                           
    Empty `mplus` ys = ys                                                                                                                                     

instance MonadTrans Amb where                                                                                                                                 
    lift m = Cons m Empty        

Примеры желаемого поведения

Здесь базовая монада State Int

instance Show a => Show (Amb (State Int) a) where                                                                                                             
    show m = (show .  toList) m                                                                                                                               


toList :: Amb (State Int) a -> [a]                                                                                                                            
toList Empty = []                                                                                                                                             
toList (n `Cons` xs) = (runState n 0 : toList xs)                                                                                                             


x = (list $ incr) >> (incr <:> incr <:> Empty)                                                                                                                
y = (list $ incr) >> (incr <:> (incr >> incr) <:> Empty)                                                                                                      

main = do                                                                                                                                                     
  putStr $ show x -- | should be [2, 2]                                                                                                                       
  putStr $ show y -- | should be [2, 3]   

Спасибо.

Обновление: пример того, почему LogicT не делает то, что мне нужно.

Вот что делает LogicT на простом примере выше:

import Control.Monad                                                                                                                                          
import Control.Monad.Logic                                                                                                                                    
import Control.Monad.State                                                                                                                                    

type LogicState = LogicT (State Int)                                                                                                                          


incr :: State Int Int                                                                                                                                         
incr = do i <- get                                                                                                                                            
          put (i + 1)                                                                                                                                         
          i' <- get                                                                                                                                           
          return i'                                                                                                                                           

incr' = lift incr                                                                                                                                             
y =  incr' >> (incr' `mplus` incr')                                                                                                                           

main = do                                                                                                                                                     
  putStrLn $ show (fst $ runState (observeAllT y) 0)   -- | returns [2,3], not [2,2]