{-# LANGUAGE PatternGuards #-}

-- Demonstrating that a Zipper can be derived from any Traversable
-- Haskell-Cafe, March 31, 2009

-- We use Data.Map as a sample Traversable data structure to turn
-- into a Zipper. That is a bit silly since Data.Map has a very
-- rich interface; it does not need zippers.
-- However, Data.Map is the only non-trivial instance of Traversable
-- defined in the standard library.

module ZipperTraversable where 

import qualified Data.Traversable as T
import qualified Data.Map as M


-- In the variant Z a k, a is the current, focused value
-- evaluate (k Nothing) to move forward
-- evaluate (k v)       to replace the current value with v and move forward.

data Zipper t a = ZDone (t a) 
                | Z a (Maybe a -> Zipper t a)

make_zipper :: T.Traversable t => t a -> Zipper t a
make_zipper t = reset $ T.mapM f t >>= return . ZDone
 where
 f a = shift (\k -> return $ Z a (k . maybe a id))

-- Zip all the way up, returning the traversed data structure
zip_up :: Zipper t a -> t a
zip_up (ZDone t) = t
zip_up (Z _ k)   = zip_up $ k Nothing



-- Tests

-- sample collections

tmap = M.fromList [ (v,product [1..v]) | v <- [1..10] ]

-- extract a few sample elements from the collection
trav t = 
    let (Z a1 k1) = make_zipper t
        (Z a2 k2) = k1 Nothing
        (Z a3 k3) = k2 Nothing
        (Z a4 k4) = k3 Nothing
     in [a1,a3,a4]

travm = trav tmap

-- Traverse and possibly modify elements of a collection
tmod t = loop (make_zipper t)
 where
 loop (ZDone t) = putStrLn $ "Done\n: " ++ show t
 loop (Z a k) = do
                putStrLn $ "Current element: " ++ show a
                ask k

 ask k =        do
                putStrLn "Enter Return, q or the replacement value: "
                getLine >>= check k

 check k ""   = loop $ k Nothing
 check k "\r" = loop $ k Nothing
 check k ('q':_) = loop . ZDone . zip_up $ k Nothing
 check k s  | [(n,_)] <- reads s = loop $ k (Just n) -- replace
 check k _    = putStrLn "Repeat" >> ask k

testm = tmod tmap


-- The Cont monad for delimited continuations, implemented here to avoid
-- importing conflicting monad transformer libraries

newtype Cont r a = Cont{runCont :: (a -> r) -> r}

instance Monad (Cont r) where
    return x = Cont $ \k -> k x
    m >>= f  = Cont $ \k -> runCont m (\v -> runCont (f v) k)

-- Two delimited control operators,
-- without answer-type polymorphism or modification
-- These features are not needed for the application at hand

reset :: Cont r r -> r
reset m = runCont m id

shift :: ((a -> r) -> Cont r r) -> Cont r a
shift e = Cont (\k -> reset (e k))