Reversing incremental map changes

MapChangeReverse.purs

-- | A change for a single key is an addition, removal, or update.
data MapChange v dv
  = Add v
  | Remove
  | Update dv

-- | A change for each possible key.
newtype MapChanges k v dv = MapChanges (Map k (MapChange v dv))

prune :: forall k v. Array (Tuple k (Maybe v)) -> Array (Tuple k v)
prune = mapMaybe (\(Tuple k v) -> Tuple k <$> v)

instance changeStructureMap
  :: (Ord k, ChangeStructure v dv)
  => ChangeStructure (WrappedMap k v) (MapChanges k v dv) where
  diff (WrappedMap m1) (WrappedMap m2) = MapChanges $ align m1 m2 <#>
    case _ of
      This x -> Remove
      That y -> Add y
      Both x y -> Update (diff x y)
  patch (WrappedMap m1) (MapChanges m2) =
    WrappedMap <<< Map.fromFoldable <<< prune <<< Map.toUnfoldable $ align m1 m2 <#>
      case _ of
        This x -> Just x
        That (Add v) -> Just v
        Both _ (Add v) -> Just v
        Both v (Update dv) -> Just (patch v dv)
        That Remove -> Nothing
        That (Update dv) -> Nothing
        Both _ Remove -> Nothing

-- | While applying a diff, generate the (minimal) difference required
-- | to get back to the previous state. That is,
-- | - Reversible: `uncurry patch (patchAndReverse a d) = a`
-- | - Patching: `patch a d = extract (patchAndReverse a d)`
class (Eq dv, ChangeStructure v dv) <= ReversibleChange v dv where
  patchAndReverse :: v -> dv -> Tuple dv v

instance reversibleChangeMap
  :: (Ord k, ReversibleChange v dv)
  => ReversibleChange (WrappedMap k v) (MapChanges k v dv) where
  patchAndReverse (WrappedMap m1) (MapChanges m2) =
    let
      -- If no change occurred at the lower level, don't record the
      -- change in the reverse map (so it ends up as mempty if no
      -- significant changes have occurred).
      wrapChange :: dv -> Maybe (MapChange v dv)
      wrapChange dv
        | dv == mempty = Nothing
        | otherwise = Just dv
      patchRev1 :: These v (MapChange v dv) -> Tuple (Maybe (MapChange v dv)) (Maybe v)
      patchRev1 = case _ of
        -- Just a value being maintained, no update requested, no history to maintain
        This v' -> Tuple Nothing (Just v')
        -- Just a value being added (that didn't exist); revert by removing it
        That (Add v') -> Tuple (Just Remove) (Just v')
        -- A value being actually removed, revert by adding back the old value
        Both v Remove -> Tuple (Just (Add v)) Nothing
        -- A value being replaced, revert by replacing with the old value
        Both v (Add v') -> Tuple (Just (Add v)) (Just v')
        -- A value being updated with its own change structure - pass through the reversion
        Both v (Update dv) -> bimap wrapChange Just (patchAndReverse v dv)
        -- A nonexistent value being removed, no history needed
        That Remove -> Tuple Nothing Nothing
        -- A nonexistent value being updated, no history
        That (Update dv) -> Tuple Nothing Nothing
    in bimap
         (MapChanges <<< Map.fromFoldable <<< prune)
         (WrappedMap <<< Map.fromFoldable <<< prune)
         $ (map fst &&& map snd) $ Map.toUnfoldable $ align m1 m2 <#> patchRev1

-- | Irrelevant changes will produce empty reversions when applied:
-- | detect those.
isRelevantChange :: forall v dv. ReversibleChange v dv => v -> dv -> Boolean
isRelevantChange v dv = fst (patchAndReverse v dv) /= mempty

-- | Helper to ensure revisions in history are non-trivial.
addChange :: forall v dv. ReversibleChange v dv => List (Change v) -> dv -> List (Change v)
addChange vs dv
| dv == mempty = vs
| otherwise = toChange dv : vs

-- | A value maintained along with its undo and redo history.
newtype ValueAndHistory v = VH
  { value: v
  , undo: List (Change v)
  , redo: List (Change v)
  }

-- | View the current value.
value :: ValueAndHistory v -> v
value = unwrap >>> _.value

_value :: Lens' (ValueAndHistory v) v
_value = _Newtype <<< prop (SProxy :: SProxy "value")

-- Will be mempty iff there is no history
peekUndo :: ReversibleChange v dv => ValueAndHistory v -> dv
peekUndo = unwrap >>> _.undo >>> head >>> fromChange >>> fromMaybe mempty

peekRedo :: ReversibleChange v dv => ValueAndHistory v -> dv
peekRedo = unwrap >>> _.redo >>> head >>> fromChange >>> fromMaybe mempty

undo :: ReversibleChange v dv => ValueAndHistory v -> ValueAndHistory v
undo vh@(VH { undo: Nil }) = vh
undo (VH { value, undo: dv : undo, redo }) =
  let Tuple dv' v = patchAndReverse value $ fromChange dv
  in VH { value: v, undo, redo: addChange dv' redo }

redo :: ReversibleChange v dv => ValueAndHistory v -> ValueAndHistory v
redo vh@(VH { redo: Nil }) = vh
redo (VH { value, undo, redo: dv : redo }) =
  let Tuple dv' v = patchAndReverse value $ fromChange dv
  in VH { value: v, undo: addChange dv' undo, redo }

-- | Apply a difference to the value while maintaining history.
-- | If no significant change has occurred, then this does nothing,
-- | otherwise it wipes out the redo history.
apply :: ReversibleChange v dv => ValueAndHistory v -> dv -> ValueAndHistory v
apply vh@(VH { value, undo }) dv =
  let Tuple dv' v = patchAndReverse value dv
  -- aka not isRelevantChange
  in if dv' == mempty then vh
  -- wipe out redo history
  else VH { value: v, undo: addChange dv' undo, redo: Nil }