LookAtパターン・改

親と子の関係を表現するLookAtパターンの続きです。
前回のコードはlensを使うことを前提にすればもっとずっとすっきり書くことが出来ます。(その分柔軟性がなくなります)

{-# LANGUAGE TemplateHaskell, RankNTypes, GADTs, FlexibleContexts #-}
import Control.Lens
import Control.Monad.State
import Control.Monad.Operational.Mini
import Control.Monad.Operational.TH (makeSingletons)
import Data.Maybe (fromJust)

data Pattern p q x where
  Hook :: Lens' q a -> State a () -> Pattern p q ()
  Pick :: Lens' q a -> Pattern p q a
  Run :: State p () -> Pattern p q ()
  Self :: Pattern p q p

makeSingletons ''Pattern

type LookAt p q = Program (Pattern p q)

runLookAt :: Traversal' q p -> LookAt p q a -> State q a
runLookAt p = interpret (step p) where
  step :: Traversal' q p -> Pattern p q a -> State q a
  step p (Hook m f) = m `zoom` f
  step p (Pick m) = use m
  step p (Run f) = p `zoom` f
  step p Self = get >>= \f -> return $ fromJust $ f ^? p
  -- step p Self = use p

data Item a = Item {
  _name :: String,
  _content :: a
  } deriving (Eq, Show)
makeLenses ''Item

data ItemHolder a = ItemHolder {
  _items :: [Item a]
  } deriving (Eq, Show)
makeLenses ''ItemHolder

----------------------------------------
-- examples
----------------------------------------
duplicate :: LookAt (Item a) (ItemHolder a) ()
duplicate = do
  b <- self
  hook items $ id %= (b:)

nameReverse :: LookAt (Item a) (ItemHolder a) ()
nameReverse = run $ name %= reverse

rename :: LookAt (Item a) (ItemHolder a) ()
rename = do
  n <- (^.name) `fmap` self
  hook items $ id %= reverse . (\s -> label 0 n s [])

  where
    label :: Int -> String -> [Item a] -> [Item a] -> [Item a]
    label _ _ [] bs = bs
    label i n (a:as) bs
      | n == a^.name = label (i+1) n as ((a & name %~ (++ "(" ++ show i ++ ")")):bs)
      | otherwise = label i n as (a:bs)

main = do
  f <- return $ ItemHolder [Item "normal bag" ("bag", 100)]
  print $ flip execState f $ do
    runLookAt (items . ix 0) (duplicate >> duplicate)
    runLookAt (items . ix 2) nameReverse

  f2 <- return $ ItemHolder
    [Item "normal bag" ("bag", 95),
     Item "large desk" ("desk", 400),
     Item "small cellphone" ("phone", 10),
     Item "normal bag" ("bag", 120),
     Item "favorite book" ("book", 30)]
  print $ flip execState f2 $
    runLookAt (items . ix 0) rename

LookAt p qは相変わらずOperational Monadですが、hook, pick, run, selfが前回のliftGlobal, getGlobal, liftLocal, getLocalに当たります。
これらは全てLensをベースにしているので、引数もLensの形です。hook _1 $ do actionみたいにして使います。

さて、runLookAtの第一引数はTraversal' s aとなっています。これがLens'でないのはix nによって得られるのがTraversal'になるからです。このixのせいで24行目も本来ならstep p Self = use pと書きたいところですがそれができません。よって^?を使って取り出しています。
このようにLensをベースにするとixなどのイレギュラーな函数が非常に使いにくくなります。しかしLensはRank2Types拡張を使って定義されているので型クラスによってrunLookAtの実装を分けたりすることはできません。(本来ならLensのときはこういう振る舞い、Traversalのときはこういう振る舞い、と書きたいところですが…)

Lensがそのままでは型クラスのインスタンスに使えないのはかなり致命的なので、この方法も柔軟性には欠けます。これらの欠点を克服する方法を考えるか、そもそもオブジェクトを親と子の上下関係で捉えるのをやめるしかないと思います。
何かよい方法があればコメント等で教えていただけると嬉しいです。