_Output

~$
Main.hs:1:1: Splicing declarations
    makeManager [''Parent, ''Child]
  ======>
    ComonadicOOP.hs:10:1-31
    data Manager
      = Manager {_parent :: PList Parent,
                 _child:: PList Child}
      deriving (Show)

    class NewM a where
      newM :: a -> Manager -> Manager
    class UpdateM a where
      updateM :: Manager -> a -> Manager

    instance NewM Parent where
      newM p m
        = m {_parent = cons p (_parent m)}
    instance NewM Child where
      newM p m = m {_child = cons p (_child m)}
    instance UpdateM (Pointed (Parent -> Parent)) where
      updateM m (Pointed (n, f))
        = m {_parent = adjust f n (_parent m)}
    instance UpdateM (Pointed (Child -> Child)) where
      updateM m (Pointed (n, f))
        = m_a4hw {_child = adjust f n (_child m)}

Manager {_parent = <PList: fromList [], size: 0>, _child = <PList: fromList [], size: 0>}
Manager {_parent = <PList: fromList [(0,Parent {_x = 100, children = []})], size: 1>, _child = <PList: fromList [], size: 0>}
Manager {_parent = <PList: fromList [(0,Parent {_x = 100, children = [0]})], size: 1>, _child = <PList: fromList [(0,Child {_y = 20, parent = 0})], size: 1>}
Manager {_parent = <PList: fromList [(0,Parent {_x = 100, children = [0]})], size: 1>, _child = <PList: fromList [(0,Child {_y = 30, parent = 0})], size: 1>}
Manager {_parent = <PList: fromList [(0,Parent {_x = 110, children = [0]})], size: 1>, _child = <PList: fromList [(0,Child {_y = 30, parent = 0})], size: 1>}

Main.hs

{-# LANGUAGE DeriveFunctor, FlexibleInstances, TemplateHaskell #-}
import Data.IORef

import TH
import PList

data Parent = Parent { _x :: Int, children :: [Address] } deriving Show
data Child = Child { _y :: Int, parent :: Address } deriving Show

makeManager [''Parent, ''Child]

def :: Manager
def = Manager {
  _parent = empty,
  _child = empty
  }

addParent :: Parent -> Manager -> Manager
addParent = newM

addChildToParent :: Address -> Child -> Manager -> Manager
addChildToParent p c m = m' `updateM` (Pointed (p,add)) where
  m' = newM c m
  addr = lastAddress $ _child m'
  add p = p { children = addr : children p }

moveChildren :: Address -> Manager -> Manager
moveChildren p m = move $ children (_parent m ! p) where
  move cs = foldr (\c m' -> m' `updateM` (Pointed (c,go))) m cs
  go c = c { _y = _y c + 10 }

moveParent :: Address -> Manager -> Manager
moveParent c m = move $ _child m ! c where
  move (Child _ a) = m `updateM` (Pointed (a,go))
  go p = p { _x = _x p + 10 }

main = do
  m <- newIORef def
  print =<< readIORef m

  modifyIORef m $ addParent (Parent 100 [])
  print =<< readIORef m

  modifyIORef m $ addChildToParent 0 (Child 20 0)
  print =<< readIORef m

  modifyIORef m $ moveChildren 0
  print =<< readIORef m

  modifyIORef m $ moveParent 0
  print =<< readIORef m

PList.hs

{-# LANGUAGE DeriveFunctor #-}
module PList where

import Control.Comonad
import qualified Data.IntMap as IM

type Address = Int
newtype Pointed a = Pointed (Address, a) deriving (Eq, Show, Functor)

instance Comonad Pointed where
  extract (Pointed (_,x)) = x
  extend f a = fmap (const $ f a) a

newtype PList a = PList (Int, IM.IntMap a) deriving (Eq, Functor)

instance (Show a) => Show (PList a) where
  show (PList (s,m)) = "<PList: " ++ show m ++ ", size: " ++ show s ++ ">"

empty :: PList a
empty = PList $ (0, IM.empty)

cons :: a -> PList a -> PList a
cons a (PList (s,m)) = PList (s+1, IM.insert s a m)

(!) :: PList a -> Address -> a
(PList (_,m)) ! k = m IM.! k

adjust :: (a -> a) -> Address -> PList a -> PList a
adjust f n (PList (s,m)) = PList (s,IM.adjust f n m)

lastAddress :: PList a -> Address
lastAddress (PList (s,_)) = s-1

TH.hs

{-# LANGUAGE TemplateHaskell #-}
module TH (makeManager) where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Char

import PList

_Manager = "Manager"
_newM = "newM"
_NewM = "NewM"
_updateM = "updateM"
_UpdateM = "UpdateM"

mkMethod name = do
  method <- newName $ methodName name
  varStrictType
    method
    (strictType
      notStrict
      (conT ''PList `appT` conT name)
    )

methodName :: Name -> String
methodName name = let (c:cs) = nameBase name in '_' : toLower c : cs

makeManager :: [Name] -> DecsQ
makeManager ns = sequenceQ $ [managerD, newC, updateC] ++ fmap instanceOfNewC ns ++ fmap instanceOfUpdateC ns where
  managerD = do
    mg <- newName _Manager
    dataD
      (cxt []) mg []
      [recC (mkName _Manager) $ fmap mkMethod ns]
      [''Show]

  newC = head `fmap`
    [d|
      class NewM a where
        newM :: a -> $(conT $ mkName _Manager) -> $(conT $ mkName _Manager)
     |]

  instanceOfNewC name = do
    p <- newName "p"
    m <- newName "m"

    instanceD
      (cxt [])
      (conT (mkName _NewM) `appT` conT name)
      [funD
        (mkName _newM)
        [clause
          [varP p, varP m]
          (normalB (recUpdE
            (varE m)
            [(\q -> return $ (mkName $ methodName name, q)) =<< (varE $ mkName "cons") `appE` (varE p) `appE` ((varE $ mkName $ methodName name) `appE` (varE m))]
          ))
          []
        ]
      ]

  updateC = head `fmap`
    [d|
      class UpdateM a where
        updateM :: $(conT $ mkName _Manager) -> a -> $(conT $ mkName _Manager)
     |]

  instanceOfUpdateC name = do
    m <- newName "m"
    n <- newName "n"
    f <- newName "f"

    instanceD
      (cxt [])
      (conT (mkName _UpdateM) `appT` (conT (mkName "Pointed") `appT` (arrowT `appT` conT name `appT` conT name)))
      [funD
        (mkName _updateM)
        [clause
          [varP $ m, conP (mkName "Pointed") [tupP [varP n, varP f]]]
          (normalB (recUpdE
            (varE m)
            [(\q -> return $ (mkName $ methodName name, q)) =<< (varE $ mkName "adjust") `appE` (varE f) `appE` (varE n) `appE` ((varE $ mkName $ methodName name) `appE` (varE m))]
          ))
          []
        ]
      ]