@@ -0,0 +1,91 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE InstanceSigs #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE PatternGuards #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE Rank2Types #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE StandaloneDeriving #-}
14+{-# LANGUAGE TypeApplications #-}
15+{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+{-# LANGUAGE UndecidableSuperClasses #-}
18+
19+module Data.Patch.DMapWithMove.By where
20+
21+import Data.Semigroupoid as Cat
22+
23+import Data.Patch.Class
24+
25+-- | Structure describing a particular change to a key, be it inserting a new
26+-- key (@By_Insert@), updating an existing key (@By_Insert@ again), deleting
27+-- a key (@By_Delete@), or moving a key (@By_Move@).
28+--
29+-- This type isn't used directly as the from field patch, but is instead wrapped
30+-- in an existential. However, it is nice to be able to reason about this in
31+-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
32+data By (k :: a -> *) (p :: a -> a -> *) :: a -> a -> * where
33+ -- | Insert a new or update an existing key with the given value @PatchTarget1
34+ -- p a@
35+ By_Insert :: PatchTarget1 p to -> By k p from to
36+ -- | Delete the existing key
37+ By_Delete :: By k p from to
38+ -- | Move the value from the given key @k a@ to this key. The source key
39+ -- should also have an entry in the patch giving the current key as
40+ -- @_nodeInfo_to@, usually but not necessarily with @By_Delete@.
41+ By_Move :: !(k from) -> p from to -> By k p from to
42+
43+deriving instance ( Show (k from), Show (k to)
44+ , Show (p from to)
45+ , Show (PatchTarget1 p to)
46+ ) => Show (By k p from to)
47+deriving instance ( Read (k from), Read (k to)
48+ , Read (p from to)
49+ , Read (PatchTarget1 p to)
50+ ) => Read (By k p from to)
51+deriving instance ( Eq (k from), Eq (k to)
52+ , Eq (p from to)
53+ , Eq (PatchTarget1 p to)
54+ ) => Eq (By k p from to)
55+deriving instance ( Ord (k from), Ord (k to)
56+ , Ord (p from to)
57+ , Ord (PatchTarget1 p to)
58+ ) => Ord (By k p from to)
59+
60+mapByPatch
61+ :: PatchTarget1 p0 ~ PatchTarget1 p1
62+ => ((p0 from to) -> (p1 from to))
63+ -> By k p0 from to
64+ -> By k p1 from to
65+mapByPatch f = \case
66+ By_Insert v -> By_Insert v
67+ By_Delete -> By_Delete
68+ By_Move k p -> By_Move k $ f p
69+
70+-- | Compose patches having the same effect as applying the patches in turn:
71+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
72+instance ( PatchSource1 p ~ PatchTarget1 p
73+ , Cat.Semigroupoid p
74+ , PatchHet2 p
75+ ) => Cat.Semigroupoid (By k p) where
76+ o p0 p1 = mapByPatch unProjectLocal $
77+ oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)
78+
79+oLocal
80+ :: ( PatchSource1 p ~ PatchTarget1 p
81+ , PatchHet2Locally p between after
82+ , Cat.Semigroupoid p
83+ )
84+ => By k p between after
85+ -> By k p before between
86+ -> By k p before after
87+By_Insert new `oLocal` _ = By_Insert new
88+By_Delete `oLocal` _ = By_Delete
89+By_Move _ x `oLocal` By_Insert y = By_Insert $ applyAlwaysHet2Locally x y
90+By_Move _ x `oLocal` By_Move src y = By_Move src $ x `o` y
91+By_Move _ _ `oLocal` By_Delete = By_Delete