diff --git a/changeset-containers.cabal b/changeset-containers.cabal --- a/changeset-containers.cabal +++ b/changeset-containers.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: changeset-containers -version: 0.1.1 +version: 0.2 synopsis: Stateful monad transformer based on monoidal actions description: A general state monad transformer with separate types for the state and the possible changes. @@ -38,17 +38,25 @@ BangPatterns DeriveFunctor DeriveGeneric + DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances FunctionalDependencies GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost KindSignatures + LambdaCase MultiParamTypeClasses NamedFieldPuns + QuantifiedConstraints RankNTypes ScopedTypeVariables + StandaloneDeriving StrictData TupleSections + TypeApplications TypeOperators library @@ -61,10 +69,12 @@ Data.Monoid.RightAction.Set build-depends: - base >=4.12 && <4.22, - changeset ==0.1.1, + base >=4.16 && <4.23, + changeset ==0.2, containers >=0.6 && <0.8, + indexed-traversable ^>=0.1, monoid-extras ^>=0.7, + transformers >=0.5.6.2 && <0.7, hs-source-dirs: src default-language: Haskell2010 @@ -80,6 +90,8 @@ changeset, changeset-containers, containers, + data-default, + falsify ^>=0.2.0, monoid-extras, tasty >=1.4.2 && <1.6, tasty-hunit ^>=0.10.2, diff --git a/src/Data/Monoid/RightAction/Sequence.hs b/src/Data/Monoid/RightAction/Sequence.hs --- a/src/Data/Monoid/RightAction/Sequence.hs +++ b/src/Data/Monoid/RightAction/Sequence.hs @@ -1,21 +1,35 @@ module Data.Monoid.RightAction.Sequence where -- base +import Data.Foldable (toList) import GHC.Generics (Generic) +-- transformers +import Control.Monad.Trans.State.Strict + -- containers -import Data.Sequence +import Data.Map (Map) +import Data.Map qualified as M +import Data.Sequence hiding (deleteAt, empty, insertAt, zipWith) +import Data.Sequence qualified as Seq +-- indexed-traversable +import Data.Foldable.WithIndex (FoldableWithIndex (..)) +import Data.Functor.WithIndex (FunctorWithIndex (..)) +import Data.Traversable.WithIndex (TraversableWithIndex (..)) + -- changeset -import Data.Monoid.RightAction (RightAction (..)) +import Control.Monad.Trans.Changeset (Changes (..)) +import Data.Monoid.RightAction (RightAction (..), RightTorsor (..)) + {- | Insert or delete an element at either end of a 'Seq'. To change an element in a 'Seq', see the indexed changes in [@changeset-lens@](hackage.haskell.org/package/changeset-lens). -The general purpose changes t'Control.Monad.Trans.Changeset.FilterableChange', -t'Control.Monad.Trans.Changeset.FilterableChanges', t'Control.Monad.Trans.Changeset.FilterableWithIndexChanges', -and t'Control.Monad.Trans.Changeset.AlignChanges' also apply to 'Seq'uences. +The general purpose changes 'Control.Monad.Trans.Changeset.FilterableChange', +'Control.Monad.Trans.Changeset.FilterableChanges', 'Control.Monad.Trans.Changeset.FilterableWithIndexChanges', +and 'Control.Monad.Trans.Changeset.AlignChanges' also apply to 'Seq'uences. -} data SeqChange a = -- | Prepend an element @@ -32,8 +46,94 @@ actRight s (Cons a) = a <| s actRight s (Snoc a) = s |> a actRight s Uncons = case viewl s of - EmptyL -> empty + EmptyL -> Seq.empty _ :< as' -> as' actRight s Unsnoc = case viewr s of - EmptyR -> empty + EmptyR -> Seq.empty as' :> _ -> as' + +{- | Change a sequence by deleting and inserting elements at a specified position. + +The edit is not minimal or normalized. +For example, @'Control.Monad.Trans.Changeset.changes' ['InsertAt' 0 '()', 'DeleteAt' 0]@ performs a trivial action on a sequence, +but is not equal to the empty 'Changes'. +-} +data SeqEdit a + = DeleteAt Int + | InsertAt Int a + deriving stock (Eq, Ord, Show, Read, Generic, Functor, Foldable, Traversable) + +{- | Shift the position of the edit by 1 + +The resulting edit applies the same change to a sequence prepended by one element: + +@ +a '<|' 'actRight' s edit = 'actRight' (a '<|' s) (shift edit) +@ +-} +shift :: SeqEdit a -> SeqEdit a +shift (DeleteAt i) = DeleteAt $ i + 1 +shift (InsertAt i a) = InsertAt (i + 1) a + +instance RightAction (SeqEdit a) (Seq a) where + actRight as = \case + DeleteAt i -> Seq.deleteAt i as + InsertAt i a -> Seq.insertAt i a as + +{- | An edit script is a sequence of edits to a 'Seq'. + +It is implemented as a 'Seq'uence of 'SeqEdit's. +The 'RightTorsor' instance implements the shortest edit between to sequences. + +__Note__: This is not always a lawful 'RightTorsor', but in practice this doesn't matter. +The first law is: + +@s `differenceRight` (s `actRight` es) = es@ + +That is, when an edit script acts on a sequence, it is recovered by 'differenceRight'. +This laws doesn't hold though if @es@ contains positions outside the range of @s@. +In practice, this doesn't matter though, because the action on @s@ of either side of the equation is still the same: + +@s `actRight` (s `differenceRight` (s `actRight` es)) = s `actRight` es@ +-} +newtype EditScript a = EditScript {getEditScript :: Changes (SeqEdit a)} + deriving stock (Show, Read, Traversable, Generic, Foldable, Functor) + deriving newtype (Eq, Ord, Semigroup, Monoid) + +instance FunctorWithIndex Int EditScript where + imap f (EditScript es) = EditScript $ imap (\i e -> f i <$> e) es + +instance FoldableWithIndex Int EditScript + +instance TraversableWithIndex Int EditScript where + itraverse handler = fmap EditScript . itraverse (traverse . handler) . getEditScript + +instance RightAction (EditScript a) (Seq a) where + actRight s EditScript {getEditScript} = actRight s getEditScript + +{- | Compute the minimum edit script. + +Implements a memoized longest common subsequence search. +-} +instance (Ord a) => RightTorsor (EditScript a) (Seq a) where + differenceRight asOrig0 asActed0 = EditScript $ Changes $ evalState (memoized (toList asOrig0) (toList asActed0)) M.empty + where + memoized :: [a] -> [a] -> State (Map ([a], [a]) (Seq (SeqEdit a))) (Seq (SeqEdit a)) + memoized [] asActed = pure $ Seq.fromList $ zipWith InsertAt [0 ..] asActed + memoized asOrig [] = pure $ Seq.fromList $ DeleteAt 0 <$ asOrig + memoized asOrig@(aOrig : asOrigTail) asActed@(aActed : asActedTail) = + if aOrig == aActed + then fmap shift <$> memoized asOrigTail asActedTail + else do + cache <- gets $ M.lookup (asOrig, asActed) + case cache of + Just edit -> pure edit + Nothing -> do + l <- memoized asOrig asActedTail + r <- memoized asOrigTail asActed + let result = + if Seq.length l < Seq.length r + then InsertAt 0 aActed <| (shift <$> l) + else DeleteAt 0 <| r + modify' $ M.insert (asOrig, asActed) result + pure result diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -7,11 +7,11 @@ import Test.Tasty -- changeset-containers-test -import qualified IntMap -import qualified IntSet -import qualified Map -import qualified Sequence -import qualified Set +import IntMap qualified +import IntSet qualified +import Map qualified +import Sequence qualified +import Set qualified main :: IO () main = diff --git a/test/Sequence.hs b/test/Sequence.hs --- a/test/Sequence.hs +++ b/test/Sequence.hs @@ -1,20 +1,37 @@ module Sequence where -- base -import Prelude hiding (Foldable (..)) +import Control.Monad (when) +import Data.Foldable (length) +import Data.Functor ((<&>)) +import Prelude hiding (Foldable (..), sequence) + -- containers -import Data.Sequence (fromList, singleton) +import Data.Sequence (Seq, fromList, singleton, (<|)) +import Data.Sequence qualified as Seq + -- tasty import Test.Tasty -- tasty-hunit import Test.Tasty.HUnit (testCase, (@?=)) +-- falsify + +import Test.Falsify.Generator hiding (enum) +import Test.Falsify.Predicate hiding (between) +import Test.Falsify.Range +import Test.Tasty.Falsify + +-- data-default +import Data.Default + -- changeset import Control.Monad.Changeset.Class -import Control.Monad.Trans.Changeset (changeSingle, execChangeset, runChangeset) +import Control.Monad.Trans.Changeset (changeSingle, changes, execChangeset, runChangeset) +import Data.Monoid.RightAction -- changeset-containers import Data.Monoid.RightAction.Sequence @@ -22,24 +39,116 @@ tests :: TestTree tests = testGroup - "Map" - [ testCase "Can insert" $ - runChangeset (changeSingle (Cons 0 :: SeqChange Int)) mempty @?= ((), singleton (0 :: Int)) - , testCase "Can read after insert" $ - let action = do - changeSingle (Cons 1 :: SeqChange Int) - m <- current - changeSingle $ Cons 0 - return m - in runChangeset action mempty @?= (singleton (1 :: Int), fromList [0, 1]) - , testCase "Can delete after insert" $ - let action = do - changeSingle (Cons 1 :: SeqChange Int) - m <- current - changeSingle $ Cons 0 - changeSingle $ Snoc 3 - changeSingle $ Snoc 99 - changeSingle Unsnoc - return m - in execChangeset action (singleton (2 :: Int)) @?= fromList [0, 1, 2, 3] + "Sequence" + [ testGroup + "SeqChange" + [ testCase "Can insert" $ + runChangeset (changeSingle (Cons 0 :: SeqChange Int)) mempty @?= ((), singleton (0 :: Int)) + , testCase "Can read after insert" $ + let action = do + changeSingle (Cons 1 :: SeqChange Int) + m <- current + changeSingle $ Cons 0 + return m + in runChangeset action mempty @?= (singleton (1 :: Int), fromList [0, 1]) + , testCase "Can delete after insert" $ + let action = do + changeSingle (Cons 1 :: SeqChange Int) + m <- current + changeSingle $ Cons 0 + changeSingle $ Snoc 3 + changeSingle $ Snoc 99 + changeSingle Unsnoc + return m + in execChangeset action (singleton (2 :: Int)) @?= fromList [0, 1, 2, 3] + ] + , testGroup + "SeqEdit" + [ testProperty "shift" $ do + s <- gen sequence + edit <- gen seqEdit + a <- gen string + assert $ + eq + .$ ("a <| actRight s edit", a <| actRight s edit) + .$ ("actRight (a <| s) (shift edit)", actRight (a <| s) (shift edit)) + , testProperty "Torsor law 1 semantic" $ do + s <- gen sequence + edit <- gen editScript + info $ show ("s `differenceRight` (s `actRight` edit)", s `differenceRight` (s `actRight` edit) :: EditScript String) + assert $ + eq + .$ ("s `actRight` (s `differenceRight` (s `actRight` edit)", s `actRight` (s `differenceRight` (s `actRight` edit) :: EditScript String)) + .$ ("s `actRight` edit", s `actRight` (edit :: EditScript String)) + , testProperty "Torsor law 2" $ do + sOrig <- gen sequence + sActed <- gen sequence + info $ show ("sOrig `differenceRight` sActed", sOrig `differenceRight` sActed :: EditScript String) + assert $ + eq + .$ ("sOrig `actRight` (sOrig `differenceRight` sActed)", sOrig `actRight` (sOrig `differenceRight` sActed :: EditScript String)) + .$ ("sActed", sActed) + , testProperty "Torsor law 3" $ do + s <- gen sequence + assert $ + eq + .$ ("s `differenceRight` s", s `differenceRight` s :: EditScript String) + .$ ("mempty", mempty :: EditScript String) + , testProperty "Subsequence is recognized" $ do + s <- gen sequence + insertions <- gen $ changes <$> list (between (0, 100)) insertAt + let sBigger = s `actRight` insertions + info $ show ("sBigger", sBigger) + assert $ + satisfies + ( "all DeleteAt" + , all + ( \case + DeleteAt _ -> True + _ -> False + ) + . getEditScript + ) + .$ ("sBigger `differenceRight` s", sBigger `differenceRight` s :: EditScript String) + assert $ + satisfies + ( "s `differenceRight` sBigger" + , all + ( \case + InsertAt _ _ -> True + _ -> False + ) + . getEditScript + ) + .$ ("s `differenceRight` sBigger", s `differenceRight` sBigger :: EditScript String) + , testPropertyWith def {overrideMaxRatio = Just 10000} "Edit script is minimal" $ do + sOrig <- gen sequence + sActed <- gen sequence + edit <- gen editScript + let minimalEdit = sOrig `differenceRight` sActed + info $ show ("sOrig `actRight` edit", sOrig `actRight` edit) + when (sOrig `actRight` edit /= sActed) discard + assert $ + (le `on` transparent length) + .$ ("minimalEdit", minimalEdit) + .$ ("edit", edit) + ] ] + +sequence :: Gen (Seq String) +sequence = list (between (0, 10)) string <&> Seq.fromList + +string :: Gen String +string = list (between (0, 3)) (inRange (enum ('a', 'z'))) + +deleteAt :: Gen (SeqEdit String) +deleteAt = DeleteAt <$> int (between (0, 10)) + +insertAt :: Gen (SeqEdit String) +insertAt = InsertAt <$> int (between (0, 10)) <*> string + +seqEdit :: Gen (SeqEdit String) +seqEdit = choose deleteAt insertAt + +editScript :: Gen (EditScript String) +editScript = EditScript . changes <$> list (between (0, 10)) seqEdit