packages feed

edit-lenses (empty) → 0.1

raw patch · 23 files changed

+958/−0 lines, 23 filesdep +Diffdep +basedep +containerssetup-changed

Dependencies added: Diff, base, containers, data-default, edit-lenses, gtk, lattices, mtl, regex-pcre

Files

+ Data/Container.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}+module Data.Container where++import Algebra.PartialOrd+import Data.Default+import Data.Module.Class+import Data.Set++type family ShapeModule shape++class (V (ShapeModule shape) ~ shape, Module (ShapeModule shape), PartialOrd shape, Ord (P shape)) => ContainerType shape where+	type P shape -- _p_ositions+	live :: shape -> Set (P shape) -- monotone++data Container shape element = Container+	{ currentShape    :: shape+	, containedValues :: P shape -> element -- only need be defined for "live" shapes+	}++instance (Default shape, Default element) => Default (Container shape element) where+	def = Container def (const def)++replace p e c = c { containedValues = \p' -> if p == p' then e else containedValues c p' }
+ Data/Iso.hs view
@@ -0,0 +1,4 @@+module Data.Iso where++data Iso a b = Iso (a -> b) (b -> a)+instance Show (Iso a b) where show (Iso f g) = "Iso <fn> <fn>"
+ Data/Lens/Bidirectional.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeFamilies #-}++module Data.Lens.Bidirectional where++class Bidirectional l where+	type L l+	type R l
+ Data/Lens/Edit.hs view
@@ -0,0 +1,13 @@+module Data.Lens.Edit+	( module Data.Lens.Bidirectional+	, module Data.Lens.Edit.Container+	, module Data.Lens.Edit.Primitive+	, module Data.Lens.Edit.Product+	, module Data.Lens.Edit.Sum+	) where++import Data.Lens.Bidirectional+import Data.Lens.Edit.Container+import Data.Lens.Edit.Primitive+import Data.Lens.Edit.Product+import Data.Lens.Edit.Sum
+ Data/Lens/Edit/Container.hs view
@@ -0,0 +1,66 @@+{-# 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... (?)+-}
+ Data/Lens/Edit/Primitive.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Lens.Edit.Primitive where++import Control.Arrow (first)+import Data.Lens.Bidirectional+import Data.Module.Primitive+import Data.Iso+import Data.Monoid+import qualified Data.Lens.Edit.Stateful  as F -- state_f_ul+import qualified Data.Lens.Edit.Stateless as L -- state_l_ess++data Id dX = Id deriving (Eq, Ord, Show, Read)+instance Bidirectional (Id dX) where+	type L (Id dX) = dX+	type R (Id dX) = dX++instance F.Lens (Id dX) where+	type F.C (Id dX) = ()+	missing = const ()+	dputr   = const id+	dputl   = const id++instance L.Lens (Id dX) where+	dputr = const id+	dputl = const id++data Compose k l = Compose k l deriving (Eq, Ord, Show, Read)+instance (Bidirectional k, Bidirectional l, R k ~ L l) => Bidirectional (Compose k l) where+	type L (Compose k l) = L k+	type R (Compose k l) = R l++instance (F.Lens k, F.Lens l, R k ~ L l) => F.Lens (Compose k l) where+	type F.C (Compose k l) = (F.C k, F.C l)+	missing  (Compose k l) = (F.missing k, F.missing l)+	dputr (Compose k l) (dx, (ck, cl)) =+		let (dy, ck') = F.dputr k (dx, ck)+		    (dz, cl') = F.dputr l (dy, cl)+		in (dz, (ck', cl'))+	dputl (Compose k l) (dz, (ck, cl)) =+		let (dy, cl') = F.dputl l (dz, cl)+		    (dx, ck') = F.dputl k (dy, ck)+		in (dx, (ck', cl'))++instance (L.Lens k, L.Lens l, R k ~ L l) => L.Lens (Compose k l) where+	dputr (Compose k l) = L.dputr l . L.dputr k+	dputl (Compose k l) = L.dputl k . L.dputl l++data ComposeFL k l = ComposeFL k l deriving (Eq, Ord, Show, Read)+instance (Bidirectional k, Bidirectional l, R k ~ L l) => Bidirectional (ComposeFL k l) where+	type L (ComposeFL k l) = L k+	type R (ComposeFL k l) = R l++instance (F.Lens k, L.Lens l, R k ~ L l) => F.Lens (ComposeFL k l) where+	type F.C (ComposeFL k l) = F.C k+	missing  (ComposeFL k l) = F.missing k+	dputr (ComposeFL k l) = first (L.dputr l) . F.dputr k+	dputl (ComposeFL k l) = F.dputl k . first (L.dputl l)++data ComposeLF k l = ComposeLF k l deriving (Eq, Ord, Show, Read)+instance (Bidirectional k, Bidirectional l, R k ~ L l) => Bidirectional (ComposeLF k l) where+	type L (ComposeLF k l) = L k+	type R (ComposeLF k l) = R l++instance (L.Lens k, F.Lens l, R k ~ L l) => F.Lens (ComposeLF k l) where+	type F.C (ComposeLF k l) = F.C l+	missing  (ComposeLF k l) = F.missing l+	dputr (ComposeLF k l) = F.dputr l . first (L.dputr k)+	dputl (ComposeLF k l) = first (L.dputl k) . F.dputl l++data Op l = Op l deriving (Eq, Ord, Show, Read)+unOp (Op l) = l+instance Bidirectional l => Bidirectional (Op l) where+	type L (Op l) = R l+	type R (Op l) = L l++instance F.Lens l => F.Lens (Op l) where+	type F.C (Op l) = F.C l+	missing = F.missing . unOp+	dputr   = F.dputl   . unOp+	dputl   = F.dputr   . unOp++instance L.Lens l => L.Lens (Op l) where+	dputr = L.dputl . unOp+	dputl = L.dputr . unOp++data Disconnect dX dY = Disconnect deriving (Eq, Ord, Show, Read)+instance Bidirectional (Disconnect dX dY) where+	type L (Disconnect dX dY) = dX+	type R (Disconnect dX dY) = dY++instance (Monoid dX, Monoid dY) => F.Lens (Disconnect dX dY) where+	type F.C (Disconnect dX dY) = ()+	missing = const ()+	dputr _ (_, c) = (mempty, c)+	dputl _ (_, c) = (mempty, c)++instance (Monoid dX, Monoid dY) => L.Lens (Disconnect dX dY) where+	dputr = const (const mempty)+	dputl = const (const mempty)++instance Bidirectional (Iso dX dY) where+	type L (Iso dX dY) = dX+	type R (Iso dX dY) = dY++instance F.Lens (Iso dX dY) where+	type F.C (Iso dX dY) = ()+	missing = const ()+	dputr (Iso f g) (dx, c) = (f dx, c)+	dputl (Iso f g) (dy, c) = (g dy, c)++instance L.Lens (Iso dX dY) where+	dputr (Iso f g) = f+	dputl (Iso f g) = g
+ Data/Lens/Edit/Product.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Lens.Edit.Product where++import Control.Arrow+import Data.Lens.Bidirectional+import qualified Data.Lens.Edit.Stateful  as F -- state_f_ul+import qualified Data.Lens.Edit.Stateless as L -- state_l_ess++swizzleFF ((a, b), (c, d)) = ((a, c), (b, d))+data Product k l = Product k l deriving (Eq, Ord, Show, Read)+instance (Bidirectional k, Bidirectional l) => Bidirectional (Product k l) where+	type L (Product k l) = (L k, L l)+	type R (Product k l) = (R k, R l)++instance (F.Lens k, F.Lens l) => F.Lens (Product k l) where+	type F.C (Product k l) = (F.C k, F.C l)+	missing  (Product k l) = (F.missing k, F.missing l)+	dputr (Product k l) = swizzleFF . (F.dputr k *** F.dputr l) . swizzleFF+	dputl (Product k l) = swizzleFF . (F.dputl k *** F.dputl l) . swizzleFF++instance (L.Lens k, L.Lens l) => L.Lens (Product k l) where+	dputr (Product k l) = L.dputr k *** L.dputr l+	dputl (Product k l) = L.dputl k *** L.dputl l++swizzleFL ((a, b), c) = ((a, c), b)+data ProductFL k l = ProductFL k l deriving (Eq, Ord, Show, Read)+instance (Bidirectional k, Bidirectional l) => Bidirectional (ProductFL k l) where+	type L (ProductFL k l) = (L k, L l)+	type R (ProductFL k l) = (R k, R l)++instance (F.Lens k, L.Lens l) => F.Lens (ProductFL k l) where+	type F.C (ProductFL k l) = F.C k+	missing  (ProductFL k l) = F.missing k+	dputr (ProductFL k l) = swizzleFL . (F.dputr k *** L.dputr l) . swizzleFL+	dputl (ProductFL k l) = swizzleFL . (F.dputl k *** L.dputl l) . swizzleFL++swizzleLF   ((a, b), c) = (a, (b, c))+unswizzleLF (a, (b, c)) = ((a, b), c)+data ProductLF k l = ProductLF k l deriving (Eq, Ord, Show, Read)+instance (Bidirectional k, Bidirectional l) => Bidirectional (ProductLF k l) where+	type L (ProductLF k l) = (L k, L l)+	type R (ProductLF k l) = (R k, R l)++instance (L.Lens k, F.Lens l) => F.Lens (ProductLF k l) where+	type F.C (ProductLF k l) = F.C l+	missing  (ProductLF k l) = F.missing l+	dputr (ProductLF k l) = unswizzleLF . (L.dputr k *** F.dputr l) . swizzleLF+	dputl (ProductLF k l) = unswizzleLF . (L.dputl k *** F.dputl l) . swizzleLF
+ Data/Lens/Edit/Stateful.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Lens.Edit.Stateful where++import Data.Lens.Bidirectional++class Bidirectional l => Lens l where+	type C l+	missing :: l -> C l+	dputr   :: l -> (L l, C l) -> (R l, C l)+	dputl   :: l -> (R l, C l) -> (L l, C l)
+ Data/Lens/Edit/Stateless.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Lens.Edit.Stateless where++import Data.Lens.Bidirectional++class Bidirectional l => Lens l where+	dputr :: l -> L l -> R l+	dputl :: l -> R l -> L l
+ Data/Lens/Edit/String.hs view
@@ -0,0 +1,27 @@+module Data.Lens.Edit.String where++import Data.Lens.Edit.Container+import Data.Lens.Edit.Primitive+import Data.Lens.Edit.Product+import Data.Module.String++copyEmpty :: String -> (Match, Id [Edit], Match)+copyEmpty s = (Match s, Id, Match s)++copyNonEmpty :: v -> String -> (NewDefaultMatch v, Id (NewDefaultModule v), NewDefaultMatch v)+copyNonEmpty v s = (NewDefaultMatch s, Id, NewDefaultMatch s)++skipEmpty :: String -> (Match, Disconnect [Edit] [Edit], Match)+skipEmpty s = (Match s, Disconnect, Match "")++skipNonEmpty :: v -> String -> (NewDefaultMatch v, Disconnect (NewDefaultModule v) [Edit], Match)+skipNonEmpty v s = (NewDefaultMatch s, Disconnect, Match "")++(#) :: (a, k, b) -> (c, l, d) -> ((a, c), Product k l, (b, d))+(#) (a, k, b) (c, l, d) = ((a, c), Product k l, (b, d))++op :: (a, l, b) -> (b, Op l, a)+op (a, l, b) = (b, Op l, a)++star :: (a, l, b) -> (Asterisk a, Map Int l, Asterisk b)+star (a, l, b) = (Asterisk a, Map l, Asterisk b)
+ Data/Lens/Edit/Sum.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Lens.Edit.Sum where++import Data.Lens.Bidirectional+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.Module.Sum          as M -- _m_odule++data Sum k l = Sum k l deriving (Eq, Ord, Show, Read)+instance (Bidirectional k, Bidirectional l) => Bidirectional (Sum k l) where+	type L (Sum k l) = M.Sum (L k) (L l)+	type R (Sum k l) = M.Sum (R k) (R l)++instance (F.Lens k, F.Lens l) => F.Lens (Sum k l) where+	type F.C (Sum k l) = (F.C k, F.C l)+	missing  (Sum k l) = (F.missing k, F.missing l)+	dputr (Sum k l) (M.Sum f dx dz, (ck, cl)) = (M.Sum (M.retype f) dy dw, (ck', cl')) where+		(dy, ck') = F.dputr k (dx, M.bool f ck (F.missing k))+		(dw, cl') = F.dputr l (dz, M.bool f cl (F.missing l))+	dputl (Sum k l) (M.Sum f dy dw, (ck, cl)) = (M.Sum (M.retype f) dx dz, (ck', cl')) where+		(dx, ck') = F.dputl k (dy, M.bool f ck (F.missing k))+		(dz, cl') = F.dputl l (dw, M.bool f cl (F.missing l))++instance (L.Lens k, L.Lens l) => L.Lens (Sum k l) where+	dputr (Sum k l) (M.Sum f dx dz) = M.Sum (M.retype f) (L.dputr k dx) (L.dputr l dz)+	dputl (Sum k l) (M.Sum f dy dw) = M.Sum (M.retype f) (L.dputl k dy) (L.dputl l dw)++data SumFL k l = SumFL k l deriving (Eq, Ord, Show, Read)+instance (Bidirectional k, Bidirectional l) => Bidirectional (SumFL k l) where+	type L (SumFL k l) = M.Sum (L k) (L l)+	type R (SumFL k l) = M.Sum (R k) (R l)++instance (F.Lens k, L.Lens l) => F.Lens (SumFL k l) where+	type F.C (SumFL k l) = F.C k+	missing  (SumFL k l) = F.missing k+	dputr (SumFL k l) (M.Sum f dx dz, ck) =+		let (dy, ck') = F.dputr k (dx, M.bool f ck (F.missing k))+		in (M.Sum (M.retype f) dy (L.dputr l dz), ck')+	dputl (SumFL k l) (M.Sum f dy dw, ck) =+		let (dx, ck') = F.dputl k (dy, M.bool f ck (F.missing k))+		in (M.Sum (M.retype f) dx (L.dputl l dw), ck')++data SumLF k l = SumLF k l deriving (Eq, Ord, Show, Read)+instance (Bidirectional k, Bidirectional l) => Bidirectional (SumLF k l) where+	type L (SumLF k l) = M.Sum (L k) (L l)+	type R (SumLF k l) = M.Sum (R k) (R l)++instance (L.Lens k, F.Lens l) => F.Lens (SumLF k l) where+	type F.C (SumLF k l) = F.C l+	missing  (SumLF k l) = F.missing l+	dputr (SumLF k l) (M.Sum f dx dz, cl) =+		let (dw, cl') = F.dputr l (dz, M.bool f cl (F.missing l))+		in (M.Sum (M.retype f) (L.dputr k dx) dw, cl')+	dputl (SumLF k l) (M.Sum f dy dw, cl) =+		let (dz, cl') = F.dputl l (dw, M.bool f cl (F.missing l))+		in (M.Sum (M.retype f) (L.dputl k dy) dz, cl')
+ Data/Module.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, FlexibleContexts #-}+module Data.Module+	( module Data.Default+	, module Data.Module.Class+	, module Data.Module.Primitive+	, module Data.Module.Product+	, module Data.Module.Shape+	, module Data.Module.Sum+	, module Data.Monoid+	) where++import Data.Default+import Data.Module.Class+import Data.Module.Primitive+import Data.Module.Product+import Data.Module.Shape+import Data.Module.Sum+import Data.Monoid hiding (Sum(..))
+ Data/Module/Class.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+module Data.Module.Class where++import Data.Default+import Data.Maybe+import Data.Monoid++class (Default (V dX), Monoid dX) => Module dX where+	type V dX+	apply :: dX -> V dX -> Maybe (V dX)++applyDef :: Module dX => dX -> Maybe (V dX)+applyDef dx = apply dx def++applyTotal :: Module dX => dX -> V dX -> V dX+applyTotal dx x = fromJust (apply dx x)++applyDefTotal :: Module dX => dX -> V dX+applyDefTotal dx = applyTotal dx def++-- Morally, we have+-- foldMap :: Monoid b => (a -> State c b) -> ([a] -> State c b)+-- which does just what we want.  Unfortunately, this requires an+-- instance (Monad m, Monoid a) => Monoid (m a)+-- and an unhealthy amount of type munging to get in and out of State, curry+-- arguments, etc.  Since the instance above is most conveniently available+-- from the "reducers" package, which has a dependency redwood, and the+-- above-mentioned type-munging obfuscates the beautiful definition anyway, we+-- instead re-implement foldMap manually. It's not quite as beatiful+-- conceptually, but it makes for much easier reading.++foldState f ([]  , c) = (mempty, c)+foldState f (e:es, c) = (mappend e1 e2, c'') where+	(e2, c' ) = foldState f (es, c)+	(e1, c'') = f e c'
+ Data/Module/Container.hs view
@@ -0,0 +1,56 @@+{-# 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)
+ Data/Module/Primitive.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}+module Data.Module.Primitive where++import Data.Default+import Data.Module.Class+import Data.Monoid++newtype Unit x = Unit () deriving Monoid++instance Default x => Module (Unit x) where+	type V (Unit x) = x+	apply _ = Just++instance Default x => Module (First x) where+	type V (First x) = x+	apply (First Nothing  ) x = Just x+	apply (First (Just x')) x = Just x'
+ Data/Module/Product.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Module.Product where++import Control.Monad+import Data.Default+import Data.Module.Class++instance (Module dX, Module dY) => Module (dX, dY) where+	type V (dX, dY) = (V dX, V dY)+	apply (dx, dy) (x, y) = liftM2 (,) (apply dx x) (apply dy y)
+ Data/Module/Shape.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE FlexibleInstances, TypeFamilies #-}+module Data.Module.Shape where++import Algebra.PartialOrd+import Data.Monoid+import Data.Module.Class+import Data.Container+import qualified Data.Set as S++instance Module (Sum Int) where+	type V (Sum Int) = Int+	apply (Sum di) i = Just (max 0 (di + i)) -- Okay, doesn't quite obey the laws, what with overflow and all.+type instance ShapeModule Int = Sum Int+instance PartialOrd Int where leq = (<=)+instance ContainerType Int where+	type P Int = Int+	live i = S.fromAscList [0..i-1]++listToContainer :: [a] -> Container Int a+containerToList :: Container Int a -> [a]+listToContainer as = Container (length as) (as!!)+containerToList c  = [containedValues c i | i <- [0..currentShape c-1]]
+ Data/Module/String.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies #-}+module Data.Module.String where++import Control.Arrow+import Control.Monad+import Data.Algorithm.Diff+import Data.Default+import Data.List+import Data.Maybe+import Data.Module.Class+import Data.Module.Container (ContainerEdit, ContainerModule)+import Data.Module.Product+import Data.Module.Shape+import Data.Monoid+import Text.Regex.PCRE+import qualified Data.Map as M+import qualified Data.Module.Container as C++class Module (M m) => StringModule m where+	type M m+	valid  :: m -> String -- returns a regex telling what strings are valid+	parse  :: m -> String -> Maybe (V (M m))+	pprint :: m -> V (M m) -> String+	edit   :: m -> V (M m) -> [Edit] -> M m++data Edit = Insert Int String | Delete Int Int deriving (Show, Read)++instance Module [Edit] where+	type V [Edit] = String+	apply es s = Just (foldr applyEdit s es) where+		applyEdit (Insert n s') s = take n s ++ s' ++ drop n s+		applyEdit (Delete n n') s = take n s ++ drop n' s++newtype Match = Match String deriving (Eq, Ord, Show, Read)+maybeMatch re s = guard (s =~ re == (0 :: Int, length s)) >> return s+instance StringModule Match where+	type M Match = [Edit]+	valid (Match re) = re+	parse  = maybeMatch . valid+	pprint = const id+	edit   = const (const id)++instance (StringModule dX, StringModule dY) => StringModule (dX, dY) where+	type M (dX, dY) = (M dX, M dY)+	valid (mx, my) = valid mx ++ valid my+	parse (mx, my) s = do+		let (m , n ) =        s =~ valid mx+		    (m', n') = drop n s =~ valid my+		guard ([m, m', n + n'] == [0, 0, length s])+		vx <- parse mx (take n s)+		vy <- parse my (drop n s)+		return (vx, vy)+	pprint (mx, my) (vx, vy) = pprint mx vx ++ pprint my vy+	edit = editProd++editProd (mx, my) (vx, vy) es = edit mx vx *** edit my vy $ case splitMap of+	Nothing -> (replace sx sx', replace sy sy')+	Just ms -> (exs, eys)+	where+	die = error "The impossible happened! A [Edit] didn't successfully apply to a String in editProd."+	sx  = pprint mx vx+	sy  = pprint my vy+	sn  = fromMaybe die (apply es (sx ++ sy))+	oldSplit     = length sx+	newSplit     = snd (sn =~ valid mx :: (Int, Int))+	(sx', sy')   = splitAt newSplit sn+	easySplits   = trackEdits [oldSplit] es+	splitMap     = M.lookup newSplit easySplits+	-- this is dangerous, only use the variables it binds when splitMap is definitely a Just!+	(exs, eys)   = splitEdits (fromJust splitMap) oldSplit es+	replace s s' = [Insert 0 s', Delete 0 (length s)]++trackEdit :: Edit -> (Int, M.Map Int (M.Map Int Int)) -> (Int, M.Map Int (M.Map Int Int))+trackEdit (Insert n s) (i, m) = (i + 1, m') where+	(smaller, larger') = M.split n m+	len    = length s+	larger = M.mapKeysMonotonic (+ len) larger'+	exact  = case M.lookup n m of+		Nothing -> M.empty+		Just im -> M.fromList [(n + i', M.insert i i' im) | i' <- [0 .. len]]+	m'     = smaller `M.union` larger `M.union` exact+trackEdit (Delete n n') (i, m)+	| n >  n' = trackEdit (Delete n' n) (i, m)+	| n == n' = (i + 1, m)+	| n <  n' = (i + 1, m') where+	(smaller, notSmaller) = M.split (n +1) m+	(deleted, larger')    = M.split (n'-1) notSmaller+	len    = n' - n+	larger = M.mapKeysMonotonic (subtract len) larger'+	m'     = smaller `M.union` larger+	-- NOTE: this arbitrarily prefers the edits on the left-hand side of the+	-- deletion boundary over the edits on the right-hand side of the deletion+	-- boundary when a chunk boundary happens to fall on a position that+	-- matches the deletion boundary++-- input: the locations of chunk boundaries, plus some edits+-- returns:+--   The inner Map Int Int tells, for each index into the edits, whether to split the resulting edit and where.+--   The outer Map tells, for each position, if a chunk boundary ends up landing there, how to split the edits.+trackEdits :: [Int] -> [Edit] -> M.Map Int (M.Map Int Int)+trackEdits boundaries = snd . foldr trackEdit (0, M.fromList (zip boundaries (repeat M.empty)))++splitEdits :: M.Map Int Int -> Int -> [Edit] -> ([Edit], [Edit])+splitEdits m split = snd . foldr splitEdit ((0, split), ([], [])) where+	splitEdit :: Edit -> ((Int, Int), ([Edit], [Edit])) -> ((Int, Int), ([Edit], [Edit]))+	splitEdit e@(Delete n n') ((i, split), (els, ers))+		| n > n' = splitEdit (Delete n' n) ((i, split), (els, ers))+		| n' <= split = ((i+1, split-n'+n), (e:els, ers))+		| n  >= split = ((i+1, split), (els, Delete (n-split) (n'-split) : ers))+		| otherwise   = error "The impossible happened! A deletion crossed a chunk boundary."+		-- | otherwise   = ((i+1, n), (Delete n split : els, Delete 0 (n'-split) : ers))+	splitEdit e@(Insert n s) ((i, split), (els, ers)) = case M.lookup i m of+		Nothing+			| n < split -> ((i+1, split+length s), (e:els, ers))+			| n > split -> ((i+1, split), (els, Insert (n-split) s : ers))+			| otherwise -> error "The impossible happened! An insertion crossed a chunk boundary without being in the splitting map."+		Just n' -> ((i+1, split+n'), (consInsert n (take n' s) els, consInsert 0 (drop n' s) ers))+	consInsert n "" es = es+	consInsert n s  es = Insert n s : es++data Asterisk m = Asterisk m+instance StringModule m => StringModule (Asterisk m) where+	type M (Asterisk m) = ContainerModule Int (M m)+	valid  (Asterisk m) = "(" ++ valid m ++ ")*"+	pprint (Asterisk m) = containerToList >=> pprint m+	edit   (Asterisk m) = editList m . containerToList+	parse  (Asterisk m) = liftM listToContainer . parseList m++parseList m = splitList (valid m) >=> mapM (parse m)+splitList re "" = return []+splitList re s  = do+	-- pattern match failure means the regex didn't match at the beginning,+	-- and results in a failed parse overall+	("", sMatch, rest) <- return (s =~ re)+	liftM (sMatch:) (splitList re rest)++-- Heuristic: if we can track where *all* the old splits went, then go ahead+-- and do that. Nice! Otherwise, use diff to compare the entire old list with+-- the entire new list.+--+-- There's a lot of room for improvement: we could take the regions between+-- successfully tracked splits and the regions with unsuccessfully tracked+-- splits and run the diff only on the unsuccessful regions, for example.+-- Additionally, note that when we are tracking splits, we assume that no+-- splits are inserted or deleted. A more sophisticated heuristic might try to+-- relax this assumption somehow (though the only way I could think of to relax+-- it would result in an exponential-time algorithm).+editList m vs es = fromMaybe diffy exact where+	exact = editListExact m vs oldss newss es 0+	diffy = editListDiff  m    oldss newss+	oldss = map (pprint m) vs+	newss = fromJust (splitList (valid m) =<< apply es (concat oldss)) :: [String]++editListExact m (v:vs) (olds:oldss) (news:newss) es i = case splitMap of+	Nothing -> Nothing+	Just ms -> liftM (C.Modify i (edit m v e) :) (editListExact m vs oldss newss erest (i+1))+	where+	oldSplit     = length olds+	newSplit     = length news+	easySplits   = trackEdits [oldSplit] es+	splitMap     = M.lookup newSplit easySplits+	-- this is dangerous, only use the variables it binds when splitMap is definitely a Just!+	(e, erest)   = splitEdits (fromJust splitMap) oldSplit es+editListExact m [] [] [] [] i = Just []+editListExact _ _  _  _  _  _ = Nothing++editListDiff m oldss newss = result where+	diff = getDiff oldss newss+	tags = map fst diff+	count place        = length . filter (==place) $ tags+	match place B      = [True]+	match place place' = [False | place == place']+	reordered place    = map fst . uncurry (++) . partition snd . zip [0..] $ (tags >>= match place)+	create s = edit m def [Insert 0 s, Delete 0 . length . pprint m $ def]+	result+		= C.Rearrange (Sum 0) (\_ i -> fromJust (findIndex (==i) (reordered S)))+		: zipWith C.Modify [count B .. count B + count S - 1] [create news | (S, news) <- diff] +++		[ C.Insert . Sum          . count $ S+		, C.Delete . Sum . negate . count $ F+		, C.Rearrange (Sum 0) (\_ i -> reordered F !! i)+		]++-- a few utilities for defining string modules whose default value is not ""+newtype NewDefault v = NewDefault String deriving (Eq, Ord)+instance Show (NewDefault v) where show (NewDefault s) = show s+instance Read (NewDefault v) where readsPrec n s = map (first NewDefault) (readsPrec n s)+instance (Default v, Show v) => Default (NewDefault v) where def = NewDefault (show (def :: v))+newtype NewDefaultModule v = NewDefaultModule [Edit] deriving (Show, Read, Monoid)+instance (Default v, Show v) => Module (NewDefaultModule v) where+	type V (NewDefaultModule v) = NewDefault v+	apply (NewDefaultModule es) (NewDefault v) = liftM NewDefault (apply es v)+newtype NewDefaultMatch v = NewDefaultMatch String deriving (Eq, Ord, Show, Read)++instance (Default v, Show v) => StringModule (NewDefaultMatch v) where+	type M (NewDefaultMatch v) = NewDefaultModule v+	valid (NewDefaultMatch re) = re+	parse  m                   = liftM NewDefault . maybeMatch (valid m)+	pprint m (NewDefault s)    = s+	edit                       = const (const NewDefaultModule)
+ Data/Module/Sum.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}+module Data.Module.Sum where++import Data.Default+import Data.Module.Class+import Data.Monoid hiding (Sum(..))++instance Default x => Default (Either x y) where+	def = Left def++data Tag = L | R deriving (Eq, Ord, Bounded, Enum, Show, Read)+newtype Retag x y = Retag (Maybe (Endo Tag)) deriving Monoid++retype (Retag f) = Retag f+bool (Retag Nothing) nothing just = nothing+bool _               nothing just = just++instance Eq (Retag x y) where+	Retag Nothing  == Retag Nothing   = True+	Retag (Just f) == Retag (Just f') = map (appEndo f) [L, R] == map (appEndo f') [L, R]+	_ == _ = False++instance (Default x, Default y) => Module (Retag x y) where+	type V (Retag x y) = Either x y+	apply (Retag Nothing) v = Just v+	apply (Retag (Just (Endo f))) v = Just $ case v of+		Left  x -> redef (f L)+		Right y -> redef (f R)+		where+		redef L = Left  def+		redef R = Right def++data Sum dX dY = Sum (Retag (V dX) (V dY)) dX dY+instance (Monoid dX, Monoid dY) => Monoid (Sum dX dY) where+	mempty = Sum mempty mempty mempty+	mappend (Sum f dx dy) (Sum f' dx' dy') =+		Sum (mappend f f') (annihilate dx dx') (annihilate dy dy') where+		annihilate :: Monoid d => d -> d -> d+		annihilate d d' = bool f d (mappend d d')++instance (Module dX, Module dY) => Module (Sum dX dY) where+	type V (Sum dX dY) = Either (V dX) (V dY)+	apply (Sum f dx dy) v = apply f v >>= either+		(fmap Left  . apply dx)+		(fmap Right . apply dy)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Daniel Wagner++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Daniel Wagner nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demos/lens-editor.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++import Control.Concurrent+import Control.Monad+import Data.IORef+import Data.Lens.Edit+import Data.Lens.Edit.Stateful+import Data.Lens.Edit.String+import Data.Maybe+import Data.Module+import Data.Module.String+import Graphics.UI.Gtk++newtype DATE      = DATE      () deriving Default+newtype COUNTRY   = COUNTRY   () deriving Default+newtype COMMA     = COMMA     () deriving Default+newtype SEMICOLON = SEMICOLON () deriving Default+newtype NEWLINE   = NEWLINE   () deriving Default++instance Show DATE      where show DATE      {} = "0000"+instance Show COUNTRY   where show COUNTRY   {} = "Unknown"+instance Show COMMA     where show COMMA     {} = ","+instance Show SEMICOLON where show SEMICOLON {} = ";"+instance Show NEWLINE   where show NEWLINE   {} = "\n"++commaToSemicolon = skipNonEmpty COMMA {} "," # op (skipNonEmpty SEMICOLON {} ";")+composerName     = copyEmpty "[^,;\n]*"+composerYear     = skipNonEmpty DATE {} "\\d\\d\\d\\d"+composerCountry  = op (skipNonEmpty COUNTRY {} "[A-Z][a-z]*")+newline          = copyNonEmpty NEWLINE {} "\n"+(leftM, lens, rightM) = star (composerName # commaToSemicolon # composerYear # composerCountry # newline)++initView string = do+	buffer <- textBufferNew Nothing+	view   <- textViewNewWithBuffer buffer+	good   <- newIORef (def, [])+	del    <- newIORef (Delete 0 0)+	sigm   <- newEmptyMVar+	readIORef good >>= textBufferInsertAtCursor buffer . pprint string . fst+	return (buffer, view, good, del, sigm)++changeEvent cref sigm this that goodThis goodThat dput stringThis stringThat e = do+	c             <- readIORef cref+	(oldThis, es) <- readIORef goodThis+	(oldThat, _ ) <- readIORef goodThat+	newThisS      <- get this textBufferText+	sigs          <- readMVar sigm+	mapM_ signalBlock sigs+	case parse stringThis newThisS of+		Nothing      -> writeIORef goodThis (oldThis, e:es)+		Just newThis -> do+			let (eThat, c')  = dput lens (edit stringThis oldThis (e:es), c)+			    Just newThat = apply eThat oldThat+			writeIORef cref c'+			writeIORef goodThis (newThis, [])+			writeIORef goodThat (newThat, [])+			set that [ textBufferText := pprint stringThat newThat ]+	mapM_ signalUnblock sigs++changeEventL cref (buf1, _, good1, _, _) (buf2, _, good2, _, sigm2)+	= changeEvent cref sigm2 buf1 buf2 good1 good2 dputr leftM rightM+changeEventR cref (buf1, _, good1, _, sigm1) (buf2, _, good2, _, _)+	= changeEvent cref sigm1 buf2 buf1 good2 good1 dputl rightM leftM++insertEdit p s  = get p textIterOffset >>= \n -> return (Insert (n - length s) s)+deleteEdit p p' = liftM2 Delete (get p textIterOffset) (get p' textIterOffset)++main = do+	initGUI+	window <- windowNew+	hbox   <- hBoxNew True 2+	cref   <- newIORef (missing lens)+	v1@(buf1, view1, good1, del1, sigm1) <- initView leftM+	v2@(buf2, view2, good2, del2, sigm2) <- initView rightM++	window `on` objectDestroy $ mainQuit+	sig1i <- buf1 `after` bufferInsertText $ \p s  -> insertEdit p s  >>= changeEventL cref v1 v2+	sig1w <- buf1 `on`    deleteRange      $ \p p' -> deleteEdit p p' >>= writeIORef del1+	sig1r <- buf1 `after` deleteRange      $ \p p' -> readIORef  del1 >>= changeEventL cref v1 v2+	sig2i <- buf2 `after` bufferInsertText $ \p s  -> insertEdit p s  >>= changeEventR cref v1 v2+	sig2w <- buf2 `on`    deleteRange      $ \p p' -> deleteEdit p p' >>= writeIORef del2+	sig2r <- buf2 `after` deleteRange      $ \p p' -> readIORef  del2 >>= changeEventR cref v1 v2+	putMVar sigm1 [sig1i, sig1w, sig1r]+	putMVar sigm2 [sig2i, sig2w, sig2r]++	set window [ containerChild      := hbox+	           , windowDefaultWidth  := 600+	           , windowDefaultHeight := 200+	           ]+	set hbox   [ containerChild      := view1+	           , containerChild      := view2+	           ]++	widgetShowAll window+	mainGUI
+ edit-lenses.cabal view
@@ -0,0 +1,54 @@+name:                edit-lenses+version:             0.1+synopsis:            Symmetric, stateful edit lenses+Description:         An implementation of the ideas of the paper "Edit Lenses",+                     available at http://dmwit.com/papers/201107EL.pdf,+                     together with a very simple demo program for a simple+                     string edit lens.+-- Homepage:            http://dmwit.com/edit-lenses+license:             BSD3+license-file:        LICENSE+author:              Daniel Wagner+maintainer:          daniel@wagner-home.com+category:            Data+build-type:          Simple+cabal-version:       >=1.8+++library+  exposed-modules:+    Data.Container,+    Data.Iso,+    Data.Module,+    Data.Module.Class,+    Data.Module.Primitive,+    Data.Module.Sum,+    Data.Module.Product,+    Data.Module.Container,+    Data.Module.Shape,+    Data.Module.String,+    Data.Lens.Bidirectional,+    Data.Lens.Edit,+    Data.Lens.Edit.Container,+    Data.Lens.Edit.Stateless,+    Data.Lens.Edit.Stateful,+    Data.Lens.Edit.Sum,+    Data.Lens.Edit.Primitive,+    Data.Lens.Edit.Product,+    Data.Lens.Edit.String+  build-depends:+    base >= 3.0 && < 5,+    containers >= 0.3,+    data-default >= 0.3,+    Diff >= 0.1,+    lattices >= 1.2,+    mtl >= 2.0,+    regex-pcre >= 0.94++executable lens-editor+  build-depends:+    base >= 3.0,+    edit-lenses >= 0.1,+    gtk >= 0.12+  main-is: lens-editor.hs+  hs-source-dirs: demos