edit-lenses-demo (empty) → 0.1

raw patch · 17 files changed

+840/−0 lines, 17 filesdep +Diffdep +basedep +containerssetup-changed

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

Files

• Data/.svn/all-wcprops +5/−0
• Data/.svn/entries +34/−0
• Data/Lens/.svn/all-wcprops +5/−0
• Data/Lens/.svn/entries +31/−0
• Data/Lens/Edit/.svn/all-wcprops +11/−0
• Data/Lens/Edit/.svn/entries +62/−0
• Data/Lens/Edit/.svn/text-base/String.hs.svn-base +27/−0
• Data/Lens/Edit/String.hs +27/−0
• Data/Module/.svn/all-wcprops +11/−0
• Data/Module/.svn/entries +62/−0
• Data/Module/.svn/text-base/String.hs.svn-base +199/−0
• Data/Module/String.hs +199/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• edit-lenses-demo.cabal +33/−0
• lens-editor.hs +101/−0
• no-gtk.hs +1/−0

@@ -0,0 +1,5 @@+K 25+svn:wc:ra_dav:version-url+V 53+/svn/symmetric/!svn/ver/859/implementation/demos/Data+END

@@ -0,0 +1,34 @@+10++dir+876+https://webdav.seas.upenn.edu/svn/symmetric/implementation/demos/Data+https://webdav.seas.upenn.edu/svn/symmetric++++2012-01-05T11:04:26.259154Z+859+wagnerdm+++++++++++++++aa241a2e-9b9f-11de-8e07-5b05083ecc8c++Lens+dir++Module+dir+

@@ -0,0 +1,5 @@+K 25+svn:wc:ra_dav:version-url+V 58+/svn/symmetric/!svn/ver/859/implementation/demos/Data/Lens+END

@@ -0,0 +1,31 @@+10++dir+876+https://webdav.seas.upenn.edu/svn/symmetric/implementation/demos/Data/Lens+https://webdav.seas.upenn.edu/svn/symmetric++++2012-01-05T11:04:26.259154Z+859+wagnerdm+++++++++++++++aa241a2e-9b9f-11de-8e07-5b05083ecc8c++Edit+dir+

@@ -0,0 +1,11 @@+K 25+svn:wc:ra_dav:version-url+V 63+/svn/symmetric/!svn/ver/859/implementation/demos/Data/Lens/Edit+END+String.hs+K 25+svn:wc:ra_dav:version-url+V 73+/svn/symmetric/!svn/ver/859/implementation/demos/Data/Lens/Edit/String.hs+END

@@ -0,0 +1,62 @@+10++dir+876+https://webdav.seas.upenn.edu/svn/symmetric/implementation/demos/Data/Lens/Edit+https://webdav.seas.upenn.edu/svn/symmetric++++2012-01-05T11:04:26.259154Z+859+wagnerdm+++++++++++++++aa241a2e-9b9f-11de-8e07-5b05083ecc8c++String.hs+file+++++2012-01-06T16:47:07.208237Z+03005d26259ff686dc4483b67cba7035+2012-01-05T11:04:26.259154Z+859+wagnerdm++++++++++++++++++++++974+

@@ -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), CompactProduct k l, (b, d))+(#) (a, k, b) (c, l, d) = ((a, c), CompactProduct 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)

@@ -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), CompactProduct k l, (b, d))+(#) (a, k, b) (c, l, d) = ((a, c), CompactProduct 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)

@@ -0,0 +1,11 @@+K 25+svn:wc:ra_dav:version-url+V 60+/svn/symmetric/!svn/ver/859/implementation/demos/Data/Module+END+String.hs+K 25+svn:wc:ra_dav:version-url+V 70+/svn/symmetric/!svn/ver/859/implementation/demos/Data/Module/String.hs+END

@@ -0,0 +1,62 @@+10++dir+876+https://webdav.seas.upenn.edu/svn/symmetric/implementation/demos/Data/Module+https://webdav.seas.upenn.edu/svn/symmetric++++2012-01-05T11:04:26.259154Z+859+wagnerdm+++++++++++++++aa241a2e-9b9f-11de-8e07-5b05083ecc8c++String.hs+file+++++2012-01-06T16:47:07.604237Z+5cde9f4d5ab75f3482364ef388c8b121+2012-01-05T11:04:26.259154Z+859+wagnerdm++++++++++++++++++++++8937+

@@ -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 (ContainerAtom)+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 PartialEdit Edit where+	type V_0 Edit = String+	apply_0 (Insert n s') s = Just (take n s ++ s' ++ drop n s)+	apply_0 (Delete n n') s = Just (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) = [ContainerAtom 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)

@@ -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 (ContainerAtom)+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 PartialEdit Edit where+	type V_0 Edit = String+	apply_0 (Insert n s') s = Just (take n s ++ s' ++ drop n s)+	apply_0 (Delete n n') s = Just (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) = [ContainerAtom 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)

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,33 @@+name:                edit-lenses-demo+version:             0.1+synopsis:            Programs demoing the use of symmetric, stateful edit lenses+Description:         Some simple demo programs showing ways to use the edit-lenses package.+-- 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++flag gtk+    description: Build demos that require a GUI.+    default: False++executable lens-editor+  if flag(gtk)+    build-depends:+      base >= 3.0 && < 5,+      containers >= 0.4,+      data-default >= 0.3,+      Diff >= 0.1,+      edit-lenses >= 0.2,+      gtk >= 0.12,+      regex-pcre >= 0.94+    extensions: GeneralizedNewtypeDeriving+    other-modules: Data.Lens.Edit.String Data.Module.String+    main-is: lens-editor.hs+  else+    build-depends: base >= 3.0 && < 5+    main-is: no-gtk.hs

@@ -0,0 +1,101 @@+{-# 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 hiding (Delete, Insert)+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][^\n]*")+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+	font   <- fontDescriptionNew+	fontDescriptionSetSize font 48+	widgetModifyFont view (Just font)+	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 eThis        = edit stringThis oldThis (e:es)+			    (eThat, c')  = dput lens (edit stringThis oldThis (e:es), c)+			    Just newThat = apply eThat oldThat+			putStrLn $ "Edit received: " ++ show eThis+			putStrLn $ "Lens computes: " ++ show eThat+			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 False 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

@@ -0,0 +1,1 @@+main = putStrLn "This executable was disabled at compile time to avoid a dependency on Gtk+. To\nenable, add \"--flags=gtk\" to cabal's configure or install command."