LookAtパターン・改 ref: http://qiita.com/myuon_myon/items/0eecb189c39a2269f05d

file0.hs

{-# 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