Container.hs

{-# LANGUAGE FlexibleContexts, TypeFamilies, TypeOperators #-}
module Data.Lens.Edit.Container where

import Data.Container
import Data.Default
import Data.Iso
import Data.Lens.Bidirectional
import Data.Module.Class
import Data.Module.Container
import qualified Data.Lens.Edit.Stateful  as F -- state_f_ul
import qualified Data.Lens.Edit.Stateless as L -- state_l_ess
import qualified Data.Set                 as S

data Map shape l = Map l deriving (Eq, Ord, Show, Read)

instance Bidirectional l => Bidirectional (Map shape l) where
	type L (Map shape l) = [ContainerEdit shape (L l)]
	type R (Map shape l) = [ContainerEdit shape (R l)]

instance (ContainerType shape, F.Lens l) => F.Lens (Map shape l) where
	type F.C (Map shape l) = Container shape (F.C l)
	missing (Map l) = Container def (const (F.missing l))
	dputr (Map l) = foldState (dputMapF F.dputr l)
	dputl (Map l) = foldState (dputMapF F.dputl l)

instance (ContainerType shape, L.Lens l) => L.Lens (Map shape l) where
	dputr (Map l) = map (dputMapL L.dputr l)
	dputl (Map l) = map (dputMapL L.dputl l)

dputMapF dput l Fail c = ([Fail], c)
dputMapF dput l (Modify p dx) c
	| S.member p (live (currentShape c)) = ([Modify p dy], replace p c' c)
	| otherwise = ([Fail], c)
	where (dy, c') = dput l (dx, containedValues c p)
dputMapF dput l (Insert ds) c = case apply ds (currentShape c) of
	Nothing -> ([Fail], c)
	Just s  -> ([Insert ds], expand s (F.missing l) c)
dputMapF dput l (Delete ds) c = case apply ds (currentShape c) of
	Nothing -> ([Fail], c)
	Just s  -> ([Delete ds], setShape s c)
dputMapF dput l (Rearrange ds f) c = case apply ds (currentShape c) of
	Nothing -> ([Fail], c)
	Just s  -> ([Rearrange ds f], reorder f s c)

dputMapL dput l Fail             = Fail
dputMapL dput l (Modify    p dx) = Modify p (dput l dx)
dputMapL dput l (Insert    ds  ) = Insert ds
dputMapL dput l (Delete    ds  ) = Delete ds
dputMapL dput l (Rearrange ds f) = Rearrange ds f

{-
data Reshape l x = Reshape (L l -> F.C l -> R l -> Iso (P (L l)) (P (R l))) l

instance Bidirectional (Reshape l x) where
	type L (Reshape l x) = [ContainerEdit (L l) x]
	type R (Reshape l x) = [ContainerEdit (R l) x]

instance
	( ContainerType (L l)
	, ContainerType (R l)
	, F.Lens l
	) => F.Lens (Reshape l x) where
	type F.C (Reshape l x) = (L l, F.C l, R l) -- these will be consistent according to the underlying lens l
	missing (Reshape iso l) = (def, F.missing l, def)
	-- TODO: the paper doesn't seem to actually finish defining dputr/dputl... (?)
-}