Container.hs

{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeFamilies #-}
module Data.Module.Container where

import Data.Container
import Data.Default
import Data.Foldable
import Data.Module.Class
import qualified Data.Set as S

type ContainerModule shape dX = [ContainerEdit shape dX]
data ContainerEdit shape dX
	= Fail
	| Modify (P shape) dX
	| Insert (ShapeModule shape) -- a non-decreasing edit to the shape
	| Delete (ShapeModule shape) -- a non-increasing edit to the shape
	| Rearrange (ShapeModule shape) (shape -> P shape -> P shape) -- a shape edit which doesn't change the number of positions, and a function translating positions in the new structure to their corresponding position in the old structure

instance (Show (P shape), Show (ShapeModule shape), Show dX) => Show (ContainerEdit shape dX) where
	showsPrec d Fail = showString "Fail"
	showsPrec d (Modify pos dx)
		= showParen (d > 10)
		$ showString "Modify "
		. showsPrec 11 pos
		. showString " "
		. showsPrec 11 dx
	showsPrec d (Insert ds)
		= showParen (d > 10)
		$ showString "Insert "
		. showsPrec 11 ds
	showsPrec d (Delete ds)
		= showParen (d > 10)
		$ showString "Delete "
		. showsPrec 11 ds
	showsPrec d (Rearrange ds f)
		= showParen (d > 10)
		$ showString "Rearrange "
		. showsPrec 11 ds
		. showString " <fn>"

instance (ContainerType shape, Module dX) => Module (ContainerModule shape dX) where
	type V (ContainerModule shape dX) = Container shape (V dX)
	apply = flip (foldrM applySingle)

applySingle Fail _ = Nothing
applySingle (Modify    p dx) c = fmap (\x -> replace p x c)             (apply dx (containedValues c p))
applySingle (Insert    ds  ) c = fmap (\shape -> expand    shape def c) (apply ds (currentShape    c  ))
applySingle (Delete    ds  ) c = fmap (\shape -> setShape  shape     c) (apply ds (currentShape    c  ))
applySingle (Rearrange ds f) c = fmap (\shape -> reorder f shape     c) (apply ds (currentShape    c  ))

expand shape' x (Container shape values) = Container shape' $ \p ->
	if S.member p (live shape)
	then values p
	else x

setShape shape c = c { currentShape = shape }
reorder f shape' (Container shape values) = Container shape' (values . f shape)