changeset-containers 0.1.1 → 0.2

raw patch · 4 files changed

+259/−38 lines, 4 filesdep +data-defaultdep +falsifydep +indexed-traversabledep ~basedep ~changesetPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default, falsify, indexed-traversable, transformers

Dependency ranges changed: base, changeset

API changes (from Hackage documentation)

Files

• changeset-containers.cabal +15/−3
• src/Data/Monoid/RightAction/Sequence.hs +107/−7
• test/Main.hs +5/−5
• test/Sequence.hs +132/−23

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

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

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

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