diff --git a/Data/.svn/all-wcprops b/Data/.svn/all-wcprops new file mode 100644 --- /dev/null +++ b/Data/.svn/all-wcprops @@ -0,0 +1,5 @@ +K 25 +svn:wc:ra_dav:version-url +V 53 +/svn/symmetric/!svn/ver/859/implementation/demos/Data +END diff --git a/Data/.svn/entries b/Data/.svn/entries new file mode 100644 --- /dev/null +++ b/Data/.svn/entries @@ -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 + diff --git a/Data/Lens/.svn/all-wcprops b/Data/Lens/.svn/all-wcprops new file mode 100644 --- /dev/null +++ b/Data/Lens/.svn/all-wcprops @@ -0,0 +1,5 @@ +K 25 +svn:wc:ra_dav:version-url +V 58 +/svn/symmetric/!svn/ver/859/implementation/demos/Data/Lens +END diff --git a/Data/Lens/.svn/entries b/Data/Lens/.svn/entries new file mode 100644 --- /dev/null +++ b/Data/Lens/.svn/entries @@ -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 + diff --git a/Data/Lens/Edit/.svn/all-wcprops b/Data/Lens/Edit/.svn/all-wcprops new file mode 100644 --- /dev/null +++ b/Data/Lens/Edit/.svn/all-wcprops @@ -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 diff --git a/Data/Lens/Edit/.svn/entries b/Data/Lens/Edit/.svn/entries new file mode 100644 --- /dev/null +++ b/Data/Lens/Edit/.svn/entries @@ -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 + diff --git a/Data/Lens/Edit/.svn/text-base/String.hs.svn-base b/Data/Lens/Edit/.svn/text-base/String.hs.svn-base new file mode 100644 --- /dev/null +++ b/Data/Lens/Edit/.svn/text-base/String.hs.svn-base @@ -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) diff --git a/Data/Lens/Edit/String.hs b/Data/Lens/Edit/String.hs new file mode 100644 --- /dev/null +++ b/Data/Lens/Edit/String.hs @@ -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) diff --git a/Data/Module/.svn/all-wcprops b/Data/Module/.svn/all-wcprops new file mode 100644 --- /dev/null +++ b/Data/Module/.svn/all-wcprops @@ -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 diff --git a/Data/Module/.svn/entries b/Data/Module/.svn/entries new file mode 100644 --- /dev/null +++ b/Data/Module/.svn/entries @@ -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 + diff --git a/Data/Module/.svn/text-base/String.hs.svn-base b/Data/Module/.svn/text-base/String.hs.svn-base new file mode 100644 --- /dev/null +++ b/Data/Module/.svn/text-base/String.hs.svn-base @@ -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) diff --git a/Data/Module/String.hs b/Data/Module/String.hs new file mode 100644 --- /dev/null +++ b/Data/Module/String.hs @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/edit-lenses-demo.cabal b/edit-lenses-demo.cabal new file mode 100644 --- /dev/null +++ b/edit-lenses-demo.cabal @@ -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 diff --git a/lens-editor.hs b/lens-editor.hs new file mode 100644 --- /dev/null +++ b/lens-editor.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 diff --git a/no-gtk.hs b/no-gtk.hs new file mode 100644 --- /dev/null +++ b/no-gtk.hs @@ -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."