Add support for Containers

src/Torsor/Containers.hs

@@ -0,0 +1,217 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Torsor.Containers (DiffableContainer(..), foldDiff, foldDiffM, ContainerDiff, differenceDiffableContainer, addDiffableContainer) where
+
+import Data.Foldable (Foldable (fold), foldl')
+import Data.Functor.Identity (Identity (..))
+import qualified Data.IntMap as IM
+import qualified Data.Map as M
+import qualified Data.Map.Merge.Strict as M
+import qualified Data.Sequence as S
+import Torsor
+
+
+data Diff v d = Add v | Drop v | Shift d
+  deriving (Show, Eq)
+
+instance Additive d => Additive [Diff v d] where
+  zero = []
+  invert = reverse . fmap go where
+    go (Add v) = Drop v
+    go (Drop v) = Add v
+    go (Shift v) = Shift $ invert v
+  plus = (<>)
+  minus x y = x `plus` invert y
+
+-- | A typeclass for diffing containers.  This exists entirely to
+-- simplify creating Torsor instances by eliminating boilerplate
+-- between containers.  The @f@ type function is our container
+-- (e.g. @`Map` `String`@).  The @g@ type function annotates the
+-- values which are added and removed from the container.  For
+-- example, on the `IntMap`, @g@ is @(`Int`,)@, as each value added or
+-- removed needs to be annotated with its key.
+class DiffableContainer f g | f -> g where
+  -- | The elements which have been added to the container
+  gains ::
+    (Applicative t, Foldable t, Monoid (t (g a))) =>
+    -- | The new value
+    f a ->
+    -- | The old value
+    f a ->
+    -- | A collection of the new annotated new elements
+    t (g a)
+
+  losses ::
+    (Applicative t, Foldable t, Monoid (t (g a))) =>
+    -- | The new value
+    f a ->
+    -- | The old value
+    f a ->
+    -- | A collection of the elements removed from the old version by the new one
+    t (g a)
+
+  -- | Find the changed values within the container
+  remained ::
+    -- | The new value
+    f a ->
+    -- | The old value
+    f a ->
+    -- | A container with all of the new and old values together.  Values which were added or removed are ignored
+    f (a, a)
+
+  -- | Add an annotated element to the container
+  patchIn ::
+    -- | The annotated element
+    g a ->
+    -- | The original container
+    f a ->
+    -- | The updated container
+    f a
+
+  -- | Drop an element from the container
+  patchOut ::
+    -- | The annotated element
+    g a ->
+    -- | The original container
+    f a ->
+    -- | The updated container
+    f a
+
+  -- | Zip a function over two containers, acting on values present in
+  -- both containers.  Note that it is a zip and __not__ the applicative
+  -- instance.  For example
+  --
+  -- > zipper (+) [1, 2] [3, 4] == [4, 6]
+  --
+  -- while
+  --
+  -- > (+) <$> [1, 2] <*> [3, 4] == [4, 5, 5, 6]
+  zipper :: (a -> b -> c) -> f a -> f b -> f c
+
+
+-- | Build a monadic response to changes in the container
+foldDiffM ::
+  (DiffableContainer f g, Torsor a b, Monoid w, Monad m) =>
+  -- | Response to new elements
+  (g a -> m w) ->
+  -- | Response to lost elements
+  (g a -> m w) ->
+  -- | Response to changed elements
+  (f b -> m w) ->
+  -- | The difference to operate over
+  ContainerDiff f g a b ->
+  m w
+foldDiffM add drp shft = fmap fold . mapM go
+  where
+    go (Add x) = add x
+    go (Drop x) = drp x
+    go (Shift x) = shft x
+
+-- | Build a response to changes in the container
+foldDiff ::
+  (DiffableContainer f g, Torsor a b, Monoid w) =>
+  -- | Response to new elements
+  (g a -> w) ->
+  -- | Response to lost elements
+  (g a -> w) ->
+  -- | Response to changed elements
+  (f b -> w) ->
+  -- | The difference to operate over
+  ContainerDiff f g a b ->
+  w
+foldDiff add drp shft = runIdentity . foldDiffM (Identity . add) (Identity . drp) (Identity . shft)
+
+-- | For any @`DiffableContainer` f g@, then you can use this function
+-- as the `difference` function when implementing
+-- @`Torsor` (f a) (`ContainerDiff` f g a b)@
+differenceDiffableContainer :: (Functor f, Foldable f, DiffableContainer f g, Torsor a b) => f a -> f a -> ContainerDiff f g a b
+differenceDiffableContainer new old =
+  let gain = Add <$> gains new old
+      lost = Drop <$> losses new old
+      shift =
+        let s = uncurry difference <$> remained new old
+         in pure $ Shift s
+   in lost <> shift <> gain
+
+-- | For any @`DiffableContainer` f g@, then you can use this function
+-- as the `add` function when implementing
+-- @`Torsor` (f a) (`ContainerDiff` f g a b)@
+addDiffableContainer :: (DiffableContainer f g, Torsor a b) => ContainerDiff f g a b -> f a -> f a
+addDiffableContainer = flip (foldl' go)
+  where
+    go x (Add n) = patchIn n x
+    go x (Drop n) = patchOut n x
+    go x (Shift d) = zipper (flip add) x d
+
+-- | The difference for a container.  The only operations that you
+-- should perform on this type are `add`, `foldDiff`, and `foldDiffM`.
+-- I've intentionally made other operations difficult and inconvenient
+-- to discourage other operations.  This enables us to swap out the
+-- underlying implementation in the future for a more performant type.
+type ContainerDiff f g value diff = S.Seq (Diff (g value) (f diff))
+
+instance (Functor f, Additive diff) => Additive (ContainerDiff f g value diff) where
+  zero = S.empty
+  invert = S.reverse . fmap go where
+    go (Add v) = Drop v
+    go (Drop v) = Add v
+    go (Shift v) = Shift $ fmap invert v
+  plus = (<>)
+  minus x y = x `plus` invert y
+
+
+instance (Ord a) => DiffableContainer (M.Map a) ((,) a) where
+  gains new = M.foldMapWithKey (curry pure) . M.difference new
+  losses new = M.foldMapWithKey (curry pure) . flip M.difference new
+  remained = M.intersectionWith (,)
+  patchIn (k, v) = M.insert k v
+  patchOut (k, _) = M.delete k
+  zipper f = M.merge M.dropMissing M.dropMissing (M.zipWithMatched (const f))
+
+instance (Ord a, Torsor value diff) => Torsor (M.Map a value) (ContainerDiff (M.Map a) ((,) a) value diff) where
+  difference = differenceDiffableContainer
+  add = addDiffableContainer
+
+instance DiffableContainer IM.IntMap ((,) Int) where
+  gains new = IM.foldMapWithKey (curry pure) . IM.difference new
+  losses new = IM.foldMapWithKey (curry pure) . flip IM.difference new
+  remained = IM.intersectionWith (,)
+  patchIn (k, v) = IM.insert k v
+  patchOut (k, _) = IM.delete k
+  zipper f = IM.mergeWithKey (\_ a -> Just . f a) (const mempty) (const mempty)
+
+instance (Torsor value diff) => Torsor (IM.IntMap value) (ContainerDiff IM.IntMap ((,) Int) value diff) where
+  difference = differenceDiffableContainer
+  add = addDiffableContainer
+
+instance DiffableContainer S.Seq Identity where
+  gains new old = foldMap (pure . Identity) $ S.drop (S.length old) new
+  losses new old = foldMap (pure . Identity) $ S.drop (S.length new) old
+  remained = S.zip
+  patchIn v vs = vs S.|> runIdentity v
+  patchOut _ vs = case S.viewr vs of
+    S.EmptyR -> vs
+    inner S.:> _ -> inner
+  zipper = S.zipWith
+
+instance (Torsor value diff) => Torsor (S.Seq value) (ContainerDiff S.Seq Identity value diff) where
+  difference = differenceDiffableContainer
+  add = addDiffableContainer
+
+instance DiffableContainer Maybe Identity where
+  gains (Just x) Nothing = pure $ Identity x
+  gains _ _ = mempty
+  losses Nothing (Just x) = pure $ Identity x
+  losses _ _ = mempty
+  remained (Just x) (Just y) = Just (x, y)
+  remained _ _ = Nothing
+  patchIn (Identity x) _ = Just x
+  patchOut _ _ = Nothing
+  zipper f a b = f <$> a <*> b
+
+instance (Torsor value diff) => Torsor (Maybe value) (ContainerDiff Maybe Identity value diff) where
+  difference = differenceDiffableContainer
+  add = addDiffableContainer

test/Tests.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import qualified Data.IntMap as IM
+import qualified Data.Map as M
+import Data.Monoid
+import qualified Data.Sequence as S
+import Torsor
+import Torsor.Containers
+import Test.Tasty
+import Test.Tasty.QuickCheck as QC
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "Tests" [differenceableTests]
+
+differenceableTests :: TestTree
+differenceableTests = testGroup "Torsor" [intTests, mapTests, intMapTests, sequenceTests, maybeTests]
+
+intTests :: TestTree
+intTests =
+  testGroup
+    "Ints"
+    [ QC.testProperty "Difference law" $ \path (old :: Int) -> difference (add old path) old == path,
+      QC.testProperty "Add law" $ \new old -> add old (difference new old) == (new :: Int),
+      QC.testProperty "Path Law" $ \old middle new -> add old (difference middle old + difference new middle) == (new :: Int)
+    ]
+
+mapTests :: TestTree
+mapTests =
+  testGroup
+    "Maps"
+    [ QC.testProperty "Add law" $ \new old -> add (difference new old) old == (new :: M.Map Int Int),
+      QC.testProperty "Path Law" $ \old middle new -> add (difference middle old <> difference new middle) old == (new :: M.Map Int Int)
+    ]
+
+intMapTests :: TestTree
+intMapTests =
+  testGroup
+    "IntMaps"
+    [ QC.testProperty "Add law" $ \new old -> add (difference new old) old == (new :: IM.IntMap Int),
+      QC.testProperty "Path Law" $ \old middle new -> add (difference middle old <> difference new middle) old == (new :: IM.IntMap Int)
+    ]
+
+sequenceTests :: TestTree
+sequenceTests =
+  testGroup
+    "Sequences"
+    [ QC.testProperty "Add law" $ \new old -> add (difference new old) old == (new :: S.Seq Int),
+      QC.testProperty "Path Law" $ \old middle new -> add (difference middle old <> difference new middle) old == (new :: S.Seq Int)
+    ]
+
+maybeTests :: TestTree
+maybeTests =
+  testGroup
+    "Maybe"
+    [ QC.testProperty "Add law" $ \new old -> add (difference new old) old == (new :: Maybe Int),
+      QC.testProperty "Path Law" $ \old middle new -> add (difference middle old <> difference new middle) old == (new :: Maybe Int)
+    ]
+
+eqDouble :: (Ord a, Fractional a) => a -> a -> Bool
+eqDouble 0 b = b == 0
+eqDouble a b = (a - b) / a - 1 < 1e-7

torsor.cabal

@@ -1,5 +1,5 @@
 name: torsor
-version: 0.1
+version: 0.1.1
 synopsis: Torsor Typeclass
 description: Torsor Typeclass
 homepage: https://github.com/andrewthad/torsor#readme
@@ -15,10 +15,31 @@ cabal-version: >=1.10
 
 library
   hs-source-dirs: src
-  exposed-modules: Torsor
+  exposed-modules: Torsor,
+                   Torsor.Containers
   build-depends: base >= 4.7 && < 5
+               , containers
   default-language: Haskell2010
 
 source-repository head
   type: git
   location: https://github.com/andrewthad/torsor
+
+
+test-suite test
+    -- The interface type and version of the test suite.
+    type:             exitcode-stdio-1.0
+
+    -- Directories containing source files.
+    hs-source-dirs:   test
+
+    -- The entrypoint to the test suite.
+    main-is:          Tests.hs
+
+    -- Test dependencies.
+    build-depends: base >= 4.7 && < 5
+                    , torsor
+                    , tasty
+                    , tasty-hspec
+                    , tasty-quickcheck
+                    , containers