継続を利用したzipper

Zipper.hs

{-
From walking to zipping: 継続を利用したzipper
  Part 1: Moving right       http://conway.rutgers.edu/~ccshan/wiki/blog/posts/WalkZip1/
  Part 2: Down and up        http://conway.rutgers.edu/~ccshan/wiki/blog/posts/WalkZip2/
  Part 3: Caught in a zipper http://conway.rutgers.edu/~ccshan/wiki/blog/posts/WalkZip3/
-}
{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, Rank2Types #-}
module Zipper where
import Control.Applicative
import Control.Monad (liftM)
import Control.Monad.Cont (runContT, ContT(ContT))
import Control.Monad.Error (Error(..), runErrorT, throwError)
import Control.Monad.Trans (MonadTrans(lift))
import Control.Monad.Writer (WriterT(runWriterT), runWriter, tell)
import Data.Char (isSpace)
import Data.Generics (Typeable, Data, gmapM, mkM)
import Data.Maybe (isJust, fromMaybe)
import Data.Monoid (Any(Any), Sum(..))
import Data.Traversable
import Data.Tree (Tree(..), Forest(..))
import Text.Show.Functions ()
import Debug.Trace (trace)

-- Part 1: Moving right

-- | Monadic traversal
--   Maybeは値をコピーを避けるためのもの。Nothingだと値が書き換わってないことを表す。
type Walk from to part whole
  = forall m. Monad m
  => (from -> part -> m (Maybe part, to)) -- ^ visitor
  -> whole -> m (Maybe whole)             -- ^ walker

-- | 外に出て行く方向はToクラスのインスタンスに
class Eq to => To to where
  after :: to

-- | 出ていく方向が1種類の場合
data After = After deriving (Eq, Ord, Read, Show)

instance To After where
  after = After

-- | 外から入ってくる方向はFromクラスのインスタンスに
class Eq from => From from where
  before :: from

-- | 入ってくる方向が1種類の場合
data Before = Before deriving (Eq, Ord, Read, Show)

instance From Before where
  before = Before

-- | 移動自体はしないwalker。idと同じ。
stop :: from -> Walk from After a a
stop from visit = liftM fst . visit from

-- | 入ってきて出ていくという流れを表すクラス
class (From from, To to, Show from, Read to) => Next from to where
  next :: from -> to

-- | 左から入って右に抜けるだけ
instance Next Before After where
  next Before = After

-- | partをprintしてnextを返す
tourist :: (Next from to, Show part) => from -> part -> IO (Maybe part, to)
tourist from part = do
  putStrLn $ show from ++ ": " ++ show part
  return (Nothing, next from)

tourist' :: Next from to => from -> Term -> IO (Maybe Term, to)
tourist' from part = do
  putStrLn $ show from ++ ": " ++ show part
  return (Just (V "poof"), next from)

-- | immediate subtermをなめてfを適用する。move right = subtermをなめる = gwalk
gwalk :: (Typeable a, Data b) => Walk from to part a -> Walk from to part b
gwalk walk visit a = do
  (a', Any dirty) <- runWriterT $ gmapM (mkM f) a
  return $ scavenge dirty a'
    where
      f part = do
        mpart <- lift $ walk visit part
        tell . Any $ isJust mpart
        return $ fromMaybe part mpart

-- | scavenge = 掃除する。dirtyなら新しい値をJustにくるんで返す。
scavenge :: Bool -> a -> Maybe a
scavenge True a  = Just a
scavenge False _ = Nothing

{- この定義だと、partの型が曖昧なため型検査に失敗する
run1 :: IO (Maybe Term)
run1 = gwalk (stop Before) tourist term
-}

run1 :: IO (Maybe Term)
run1 = gwalk (stop Before) f term
  where f :: Before -> Term -> IO (Maybe Term, After) -- 具体的な型を指定する
        f = tourist
{-
Prelude> run1
Before: L "x" (A (V "x") (V "x"))
Before: L "x" (A (V "x") (V "x"))
Nothing
-}

-- Part 2: Down and up

-- | 2方向から入ってくる。Trueなら子から、Falseなら兄弟から。
data Exit from = Exit Bool from deriving (Eq, Ord, Read, Show)

-- | 2方向に出ていく。Enterは子に向けて、To toは兄弟に向けて。
data Enter to = Enter | To to deriving (Eq, Ord, Read, Show)

instance From from => From (Exit from) where
  before = Exit False before

instance To to => To (Enter to) where
  after = To after

-- | 兄弟から入ってきたら子に向かい、子から帰ってきたら次の兄弟へ
instance Next Before to => Next (Exit Before) (Enter to) where
  next (Exit False Before) = Enter    -- 隣から来たら子へ入る
  next (Exit True  Before) = To after -- 子から戻ってきたら次の兄弟へ

-- | 左から来てEnterして、子をたどってから右に抜ける
around :: Walk from to part whole                -- ^ walkOuter: 兄弟間の移動
       -> Walk (Exit from) (Enter to) part part  -- ^ walkInner: 子への移動
       -> Walk (Exit from) (Enter to) part whole -- ^ 全体を回る移動
around walkOuter walkInner visit = walkOuter (visit' False False)
    where
      visit' dirty around from part = do
        (part1', to) <- visit (Exit around from) part
        let (dirty1, part1) = pollute dirty part part1'
        case to of
          Enter -> do
            part2' <- walkInner visit part1
            let (dirty2, part2) = pollute dirty1 part1 part2'
            visit' dirty2 True from part2
          To to -> return (scavenge dirty1 part1, to)

-- | visitで値が書き換わっていたら(True, a)になる
pollute :: Bool -> a -> Maybe a -> (Bool, a)
pollute dirty a Nothing  = (dirty, a)
pollute _     _ (Just a) = (True, a)

-- | 何もしないwalker
newYork :: Walk from to part whole
newYork  _ _ = return Nothing

-- トップレベルのみ辿る
run2 :: IO (Maybe Term)
run2 = (stop Before `around` newYork) tourist term

{-
Prelude> run2
Exit False Before: A (L "x" (A (V "x") (V "x"))) (L "x" (A (V "x") (V "x")))
Exit True Before: A (L "x" (A (V "x") (V "x"))) (L "x" (A (V "x") (V "x")))
Nothing
-}

-- 1段目の子まで辿る
run2' :: IO (Maybe Term)
run2' = (stop Before `around` gwalk (stop Before `around` newYork)) tourist term

{-
Prelude> run2'
Exit False Before: A (L "x" (A (V "x") (V "x"))) (L "x" (A (V "x") (V "x")))
Exit False Before: L "x" (A (V "x") (V "x"))
Exit True Before: L "x" (A (V "x") (V "x"))
Exit False Before: L "x" (A (V "x") (V "x"))
Exit True Before: L "x" (A (V "x") (V "x"))
Exit True Before: A (L "x" (A (V "x") (V "x"))) (L "x" (A (V "x") (V "x")))
Nothing
-}

-- | すべての子を辿る
throughout :: Data a => Walk from to a a -> Walk (Exit from) (Enter to) a a
throughout level = level `around` gwalk (throughout level)

run3 :: IO (Maybe Term)
run3 = throughout (stop Before) tourist term

{-
Prelude> run3
Exit False Before: A (L "x" (A (V "x") (V "x"))) (L "x" (A (V "x") (V "x")))
Exit False Before: L "x" (A (V "x") (V "x"))
Exit False Before: A (V "x") (V "x")
Exit False Before: V "x"
Exit True Before: V "x"
Exit False Before: V "x"
Exit True Before: V "x"
Exit True Before: A (V "x") (V "x")
Exit True Before: L "x" (A (V "x") (V "x"))
Exit False Before: L "x" (A (V "x") (V "x"))
Exit False Before: A (V "x") (V "x")
Exit False Before: V "x"
Exit True Before: V "x"
Exit False Before: V "x"
Exit True Before: V "x"
Exit True Before: A (V "x") (V "x")
Exit True Before: L "x" (A (V "x") (V "x"))
Exit True Before: A (L "x" (A (V "x") (V "x"))) (L "x" (A (V "x") (V "x")))
Nothing
-}

-- | インタラクティブに進む方向・書き換えを行う。かっこいい。
keyboard :: (Next from to, Show a, Read a)
         => from -> a -> IO (Maybe a, to)
keyboard from x = do
  putStr $ show from ++ ": " ++ show x ++ "\n? "
  line <- getLine
  return $ if all isSpace line
             then (Nothing, next from)
             else read line

run4 :: IO (Maybe Term)
run4 = throughout (stop Before) keyboard term

-- Part 3: Caught in a zipper

data Zipper from to part a
  = Done a    -- ^ walkが終わったあとの値
  | Stop from -- ^ どこからpartに来たか
         part -- ^ 現在のpartの値
         (Maybe part -> to -> Zipper from to part a)
         -- ^ part書き換える場合はその値とどこへ行くか
  deriving Show

-- | Zipperモナドはwalkを具体化したものになっているため、任意のwalkを
--   zipperに変換できる。
instance Monad (Zipper from to part) where
  return = Done
  Done a           >>= k = k a
  Stop from part c >>= k = Stop from part c'
    where c' part' to = c part' to >>= k

-- | walkをzipperへ変換する
zipper :: Walk from to part whole
       -> whole
       -> Zipper from to part (Maybe whole)
zipper walk whole = runContT (walk visit whole) return
  where visit from part = ContT (Stop from part . curry)

-- | termに対するzipper
start :: Zipper (Exit Before) (Enter After) Term (Maybe Term)
start = zipper (throughout (stop Before)) term

-- | 1ステップ進む
continue :: Zipper from to part whole
         -> Maybe part
         -> to
         -> Zipper from to part whole
continue (Done _)     = error "Zipper is done, not at a stop"
continue (Stop _ _ c) = c

run5 = continue start Nothing Enter
                        
-- | keyboardと同じようにインタラクティブに方針を決めるcontinue'
continue' :: (Read part, Show part, Next from to)
          => Zipper from to part whole -> IO (Zipper from to part whole)
continue' z@(Done _)   = return z
continue' (Stop from x c) = do
  putStr $ show from ++ ": " ++ show x ++ "\n? "
  line <- getLine
  continue' $ if all isSpace line
    then c Nothing (next from)
    else uncurry c (read line)

run6 = continue' start

-- * 左にも戻れるようにする

-- | zipperの移動履歴を保持する無限リスト[(Maybe part, to)]みたいなもの
data Diff part to = Diff (Maybe part) to (Diff part to)

instance (Show part, Show to) => Show (Diff part to) where
  showsPrec = loop 3
    where loop 0 _ _ = showString "..."
          loop l d (Diff part to diff) = showParen (d > 0)
            $ showString "Diff " . showsPrec 11 part . showChar ' '
            . showsPrec 11 to . showString " $ " . loop (l - 1) 0 diff

-- | 履歴の初期値は何もしないストリーム
same :: To to => Diff part to
same = Diff Nothing after same

-- | zipperに対して履歴を元に再生する
replay :: Zipper from to part whole -> Diff part to -> whole
replay (Done whole) _                   = whole
replay (Stop _ _ c) (Diff part to diff) = replay (c part to) diff

-- | Diffを歩き回る
-- fromがZipperになる。
walkDiff :: To to
         => Zipper from to part whole
         -> Walk (Exit (Zipper from to part whole))
                 (Enter After)
                 (Diff part to)
                 (Diff part to)
walkDiff zipper = stop zipper `around`
  \visit ~(Diff part to diff) -> case zipper of -- 何故遅延パターンが必要？
    Done _     -> return Nothing
    Stop _ _ c -> liftM (liftM (Diff part to))
                        (walkDiff (c part to) visit diff)

-- いかなるwalkもzipperに具体化できる。いかなるzipperもDiff上のwalkに変換できる。
-- 例: startをsame上のwalkに変換し、そのwalkをzipperに変換する。
run7 :: Zipper (Exit (Zipper (Exit Before) (Enter After) Term (Maybe Term)))
               (Enter After)
               (Diff Term (Enter After))
               (Maybe (Diff Term (Enter After)))
run7 = zipper (walkDiff start) same
{-
Prelude> run7
Stop (Exit False
           (Stop (Exit False Before)  -- ここの部分はstart
                 (A (L "x" (A (V "x") (V "x"))) (L "x" (A (V "x") (V "x"))))
                 <function>))
     (Diff Nothing (To After) $       -- ここの部分はsame
      Diff Nothing (To After) $
      Diff Nothing (To After) $ ...)
     <function>
-}

-- run7の続きを見てみる
-- 一つ進むにはDiffの中をgo downするのでEnterを渡す
run7' = continue run7 Nothing Enter
{-
Prelude> run7'
Stop (Exit False (Done Nothing)) -- replayが終わったことを示す
     (Diff Nothing (To After) $
      Diff Nothing (To After) $
      Diff Nothing (To After) $ ...)
     <function>
-}

-- run7'とは違って、右に抜けるのではなくEnterから始める例を考える
run8 = continue run7
                  (Just (Diff Nothing Enter same))
                  Enter
{-
Prelude> run7''
Stop (Exit False
           (Stop (Exit False Before) -- replayを1ステップ進めた後のzipper
                 (L "x" (A (V "x") (V "x")))
                 <function>))
     (Diff Nothing (To After) $      -- replayを1ステップ進めた後のDiff
      Diff Nothing (To After) $
      Diff Nothing (To After) $ ...)
     <function>
-}
-- この時点では1つめのsubtermにいることに注意

-- Diffをいじらずに、2つめのsubtermに移動する
run8' = continue run8 Nothing Enter
{-
Prelude> run8'
Stop (Exit False
           (Stop (Exit False Before)
                 (L "x" (A (V "x") (V "x")))
                 <function>))
     (Diff Nothing (To After) $
      Diff Nothing (To After) $
      Diff Nothing (To After) $ ...)
     <function>
-}
-- 見た目は同じだけど、2つめのsubtermにいる

-- ここで項を書き換えてみる
run8'' = continue run8'
                  (Just (Diff (Just (V "v")) (To After) same))
                  Enter
{-
Prelude> run8''
Stop (Exit False
           (Stop (Exit True Before) -- Exit True Beforeはzipperがトップレベルに戻ったことを示している
                 (A (L "x" (A (V "x") (V "x"))) (V "v"))
                 <function>))
     (Diff Nothing (To After) $
      Diff Nothing (To After) $
      Diff Nothing (To After) $ ...)
     <function>
-}

-- zipperを終了させる方法は2通りある。まずは一つ目。
-- replayを1ステップ進めるとreplayの最後に到達し、最終的な項が返ってくる。
run8''fin1 = continue run8'' Nothing Enter
{-
Prelude> run8''fin1
Stop (Exit False
           (Done (Just (A (L "x" (A (V "x") (V "x"))) (V "v")))))
     (Diff Nothing (To After) $
      Diff Nothing (To After) $
      Diff Nothing (To After) $ ...)
     <function>
-}

-- もう一つの方法は、replayを巻き戻していく。つまりDiffの中でup/rightしていく。
-- そうすると先ほど加えた変更がundoされ、Diffの中に保持されるようになる。
run8''fin2 = let
  a = continue run8'' Nothing (To After)
{-
Stop (Exit True (Stop (Exit False Before)
                      (L "x" (A (V "x") (V "x")))
                      <function>))
     (Diff (Just (V "v")) (To After) $
      Diff Nothing (To After) $
      Diff Nothing (To After) $ ...)
     <function>
-}
  b = continue a Nothing (To After)
{-
Stop (Exit True (Stop (Exit False Before)
                      (L "x" (A (V "x") (V "x")))
                      <function>))
     (Diff Nothing (To After) $
      Diff (Just (V "v")) (To After) $
      Diff Nothing (To After) $ ...)
     <function>
-}
  c = continue b Nothing (To After)
{-
Stop (Exit True (Stop (Exit False Before)
                      (A (L "x" (A (V "x") (V "x"))) (L "x" (A (V "x") (V "x"))))
                      <function>))
     (Diff Nothing Enter $        -- 変更に必要な手順がDiffストリームに記録されている。
      Diff Nothing (To After) $
      Diff (Just (V "v")) (To After) $ ...)
     <function>
-}
  d = continue c Nothing (To After)
  in d
{-
Prelude> run8''fin2
Done (Just (Diff Nothing Enter $
            Diff Nothing (To After) $
            Diff (Just (V "v")) (To After) $ ...))
-}
-- 任意の時点でステップバックをやめ、再びreplayを続行することもできる。
-- ここまでの洞察をパッケージ化する。

-- | 後退を表す型を用意する。Backで後退、Forth Afterで次へ。
data BackForth to = Back | Forth to
  deriving (Eq, Ord, Read, Show)

instance To to => To (BackForth to) where
  after = Forth after

instance Next from to => Next from (BackForth to) where
  next = Forth . next

-- | 通常のwalkをBackForth対応版に変換する
backForth :: (To to, Error (Maybe whole))
          => Walk from to part whole
          -> Walk from (BackForth to) part whole
backForth walk visit whole =
  liftM (either id (>>= replay za))
        (runErrorT (walkDiff za visit' same))
  where
    za = zipper walk whole
    visit' (Exit _ (Done whole)) _ = throwError whole
    visit' (Exit _ (Stop from part _))
           (Diff partD toD diffD) = do
      (part, to) <- lift $ visit from $ fromMaybe part partD
      let diff' | isJust part = Just $ Diff part toD diffD
                | otherwise   = Nothing
      return $ case to of
        Back -> (diff', after)
        Forth to -> ( if to == toD
                        then diff'
                        else Just (Diff part to same)
                    , Enter)

instance Error (Maybe whole) where
  noMsg = Nothing

-- | Part 1で使ったwalkをTermに特殊化したものを使う
walkTerm :: Walk Before After Term Term
walkTerm = gwalk (stop Before)

run9 = walkTerm keyboard term
{-
Prelude> run9
Before: L "x" (A (V "x") (V "x"))
? (Just (V "y"), After)
Before: L "x" (A (V "x") (V "x"))
? 
Just (A (V "y") (L "x" (A (V "x") (V "x"))))
-}

run10 = backForth walkTerm keyboard term
{-
Prelude> run10
Before: L "x" (A (V "x") (V "x"))
? (Just (V "y"), Forth After)
Before: L "x" (A (V "x") (V "x"))
? (Just (V "z"), Back)
Before: V "y"
? 
Before: V "z"
? 
Just (A (V "y") (V "z"))
-}

run11 = throughout (backForth walkTerm) keyboard term
{-
Prelude> run11
Exit False Before: L "x" (A (V "x") (V "x"))
? 
Exit False Before: V "x"
? 
Exit True Before: V "x"
? 
Exit False Before: V "x"
? (Just (V "y"), To Back)
Exit False Before: V "x"
? (Nothing, To (Forth After))
Exit False Before: V "y"
? (Nothing, To (Forth After))
Exit True Before: L "x" (A (V "x") (V "y"))
? (Nothing, To (Forth After))
Exit False Before: L "x" (A (V "x") (V "x"))
? (Nothing, To (Forth After))
Just (A (L "x" (A (V "x") (V "y"))) (L "x" (A (V "x") (V "x"))))
-}

-- | これまでの例を一般化する関数through
through :: (Data a, Error (Maybe a))
        => Walk (Exit Before) (Enter (BackForth After)) a a
through = stop' `around` throughout (backForth (gwalk stop'))
  where stop' visit = liftM fst . visit before

-- throughを使った例
run12 = through keyboard term
{-
Prelude> run12
Exit False Before: A (L "x" (A (V "x") (V "x"))) (L "x" (A (V "x") (V "x")))
? 
Exit False Before: L "x" (A (V "x") (V "x"))
? 
Exit False Before: V "x"
? 
Exit True Before: V "x"
? 
Exit False Before: V "x"
? (Just (V "y"), To Back)
Exit False Before: V "x"
? (Nothing, To (Forth After))
Exit False Before: V "y"
? (Nothing, To (Forth After))
Exit True Before: L "x" (A (V "x") (V "y"))
? (Nothing, To (Forth After))
Exit False Before: L "x" (A (V "x") (V "x"))
? (Nothing, To (Forth After))
Exit True Before: A (L "x" (A (V "x") (V "y"))) (L "x" (A (V "x") (V "x")))
? (Nothing, To (Forth After))
Just (A (L "x" (A (V "x") (V "y"))) (L "x" (A (V "x") (V "x"))))
-}

{- まとめ

1. fixpoint operationで垂直方向の移動ができるようになる
2. reification operationでwalkをzipperに変換できる
3. 過去の変更履歴を辿ることでzipperを再実行することができる。これにより戻る走査が実現できる。
-}

-- examples
data Term = V String
          | L String Term
          | A Term Term
          deriving (Eq, Read, Show, Typeable, Data)

term :: Term
term = A t t
  where t = L "x" (A (V "x") (V "x"))