親と子の関係を表現するLookAtパターン ref: http://qiita.com/myuon_myon/items/1c1e1131f485d95f4fc6

file0.hs

{-# LANGUAGE GADTs, TemplateHaskell, FlexibleContexts #-}
import Control.Arrow
import Data.List
import Control.Monad.Operational.Mini
import Control.Monad.Operational.TH (makeSingletons)
import Control.Monad.State

data Pattern p q x where
  GetLocal :: Pattern p q p
  PutLocal :: p -> Pattern p q ()
  GetQ :: Pattern p q q
  PutQ :: q -> Pattern p q ()

makeSingletons ''Pattern

type LookAt p q = Program (Pattern p (q, [State q ()]))

runLookAt :: LookAt p q () -> State (p, (q, [State q ()])) ()
runLookAt = interpret step
  where
    step :: Pattern p (q, [State q ()]) a -> State (p, (q, [State q ()])) a
    step GetLocal = fst `fmap` get
    step (PutLocal p) = modify $ first $ const p
    step GetQ = snd `fmap` get
    step (PutQ q) = modify $ second $ const q

getGlobal :: LookAt p q q
getGlobal = do
  (q, ks) <- getQ
  return $ (foldr (.) id $ fmap execState ks) q

liftGlobal :: State q () -> LookAt p q ()
liftGlobal f = do
  (q, ks) <- getQ
  putQ $ (q, f:ks)

putGlobal :: q -> LookAt p q ()
putGlobal q = liftGlobal (modify $ const q)

liftLocal :: (p -> p) -> LookAt p q ()
liftLocal f = getLocal >>= putLocal . f

data Item a = Item { name :: String, content :: a } deriving (Eq, Show)
data ItemHolder a = ItemHolder { items :: [Item a] } deriving (Eq, Show)

updateAll :: [LookAt (Item a) (ItemHolder a) ()] -> State (ItemHolder a) ()
updateAll fs = do
  h@(ItemHolder s) <- get
  let (s',h') = scan (fmap runLookAt fs) s h ([],return ())
  put $ h { items = reverse $ s' }
  modify $ execState h'
  where
    scan :: [State (p, (q, [State q ()])) ()] -> [p] -> q -> ([p], State q ()) -> ([p], State q ())
    scan [] [] h (xs,g) = (xs,g)
    scan (k:ks) (x:xs) h (xs',g) = scan ks xs h (x':xs', g') where
      (x', (_, fs)) = execState k (x, (h, []))
      g' = foldr (>>) g fs
    scan _ _ _ _ = error "error while scanning"

----------------------------------------
-- examples
----------------------------------------
duplicate :: LookAt (Item a) (ItemHolder a) ()
duplicate = do
  i <- getLocal
  liftGlobal $ do
    ItemHolder s <- get
    put $ ItemHolder $ i:s

nameReverse :: LookAt (Item a) (ItemHolder a) ()
nameReverse = liftLocal $ execState $ do
  i@(Item n _) <- get
  put $ i { name = reverse n }

rename :: LookAt (Item a) (ItemHolder a) ()
rename = do
  Item n _ <- getLocal
  liftGlobal $ do
    ItemHolder s <- get
    put $ ItemHolder $ reverse $ label 0 n s []
  where
    label :: Int -> String -> [Item a] -> [Item a] -> [Item a]
    label _ _ [] bs = bs
    label i n (a@(Item m _):as) bs
      | n == m = label (i+1) n as (a { name = m ++ "(" ++ show i ++ ")" }:bs)
      | otherwise = label i n as (a:bs)

main = do
  f <- return $ ItemHolder [Item "normal bag" ("bag", 100)]
  print $ execState (updateAll [duplicate] >> updateAll [nameReverse, duplicate]) f
  {-
  ItemHolder {items =
    [Item {name = "normal bag", content = ("bag",100)},
     Item {name = "normal bag", content = ("bag",100)},
     Item {name = "gab lamron", content = ("bag",100)}]}
  -}


  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 $ execState (updateAll [rename, return (), return (), return (), return ()]) f2
  {-
  ItemHolder {items = 
    [Item {name = "normal bag(0)", content = ("bag",95)},
     Item {name = "large desk", content = ("desk",400)},
     Item {name = "small cellphone", content = ("phone",10)},
     Item {name = "normal bag(1)", content = ("bag",120)},
     Item {name = "favorite book", content = ("book",30)}]}
  -}

file1.hs

duplicate :: LookAt (Item a) (ItemHolder a) ()
duplicate = do
  i <- getLocal
  liftGlobal $ do
    ItemHolder s <- get
    put $ ItemHolder $ i:s