ZipperT.hs

{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

module ZipperT (
  MonadZipper (..)
, ZipperT
, runZipperT
) where

import Control.Applicative
import Control.Monad.State

class Monad m => MonadZipper a m | m -> a where
    pushL :: a -> m ()
    pushR :: a -> m ()
    popL :: m a
    popR :: m a
    headL :: m (Maybe a)
    headR :: m (Maybe a)
    
    headers :: m (Maybe a, Maybe a)
    headers = do    headerL <- headL
                    headerR <- headR
                    return (headerL, headerR)
    right2left :: m ()
    right2left = popR >>= pushL
    left2right :: m ()
    left2right = popL >>= pushR
    
data ZipperState s = ZipperState { left :: [s], right :: [s] }

newtype ZipperT s m a = ZipperT_ { runZipperT_ :: StateT (ZipperState s) m a }
                        deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadState (ZipperState s))

instance (Monad m) => MonadZipper s (ZipperT s m) where
    pushL x = modify $ \(ZipperState left right) -> ZipperState (x:left) right
    pushR x = modify $ \(ZipperState left right) -> ZipperState left (x:right)
    popL = do   ZipperState (x:left) right <- get
                put $ ZipperState left right
                return x
    popR = do   ZipperState left (x:right) <- get
                put $ ZipperState left right
                return x
    headL = do  ZipperState left _ <- get
                return $ case left of
                           [] -> Nothing
                           (x:_) -> Just x
    headR = do  ZipperState _ right <- get
                return $ case right of
                           [] -> Nothing
                           (x:_) -> Just x

runZipperT :: (Monad m) => ZipperT s m a -> ([s], [s]) -> m (a, ([s], [s]))
runZipperT computation (left, right) = do
    (x, ZipperState left' right') <- runStateT (runZipperT_ computation) (ZipperState left right)
    return (x, (left', right'))