git.iko.soy/patch
on 444969d help sign in
patch/src/Data/Patch/MapWithMove.hs
244 lines 9.2 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveTraversable #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PatternGuards #-}
9{-# LANGUAGE PatternSynonyms #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE ViewPatterns #-}
16-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
17-- another
18module Data.Patch.MapWithMove
19 ( module Data.Patch.MapWithMove
20 , PatchMapWithMove
21 ( PatchMapWithMove
22 , -- | Extract the representation of the 'PatchMapWithMove' as a map of
23 -- 'NodeInfo'.
24 unPatchMapWithMove
25 , ..
26 )
27 , NodeInfo
28 ( NodeInfo
29 , _nodeInfo_to
30 , _nodeInfo_from
31 , ..
32 )
33 -- TODO export these under the type consructor once GHC is fixed
34 -- , From (From_Insert, From_Delete, From_Move)
35 ) where
37import Data.Coerce
38import Data.Patch.Class
39import Data.Patch.MapWithPatchingMove
40 ( PatchMapWithPatchingMove (..)
41 )
42import qualified Data.Patch.MapWithPatchingMove as PM
44import Control.Lens hiding (from, to)
45import Data.List
46import Data.Map (Map)
47import qualified Data.Map as Map
48import Data.Proxy
49#if !MIN_VERSION_base(4,11,0)
50import Data.Semigroup (Semigroup (..))
51#endif
52import Data.Traversable (foldMapDefault)
54-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
55-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
56-- and vice versa. There should never be any unpaired From/To keys.
57newtype PatchMapWithMove k v = PatchMapWithMove'
58 { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
59 unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
60 }
61 deriving ( Show, Read, Eq, Ord
62 , -- | Compose patches having the same effect as applying the
63 -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
64 -- 'applyAlways' q@
65 Semigroup
66 , Monoid
67 )
69{-# COMPLETE PatchMapWithMove #-}
70pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
71pattern PatchMapWithMove { unPatchMapWithMove } <- PatchMapWithMove' (PatchMapWithPatchingMove (coerce -> unPatchMapWithMove))
72 where PatchMapWithMove m = PatchMapWithMove' $ PatchMapWithPatchingMove $ coerce m
74_PatchMapWithMove
75 :: Iso
76 (PatchMapWithMove k0 v0)
77 (PatchMapWithMove k1 v1)
78 (Map k0 (NodeInfo k0 v0))
79 (Map k1 (NodeInfo k1 v1))
80_PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove
82instance Functor (PatchMapWithMove k) where
83 fmap f = runIdentity . traverse (Identity . f)
85instance Foldable (PatchMapWithMove k) where
86 foldMap = foldMapDefault
88instance Traversable (PatchMapWithMove k) where
89 traverse =
90 _PatchMapWithMove .
91 traverse .
92 traverse
94instance FunctorWithIndex k (PatchMapWithMove k)
95instance FoldableWithIndex k (PatchMapWithMove k)
96instance TraversableWithIndex k (PatchMapWithMove k) where
97 itraverse = itraversed . Indexed
98 itraversed =
99 _PatchMapWithMove .>
100 itraversed <.
101 traverse
103newtype NodeInfo k v = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
104 deriving ( Show, Read, Eq, Ord
105 )
107{-# COMPLETE NodeInfo #-}
108pattern NodeInfo :: To k -> From k v -> NodeInfo k v
109pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } =
110 NodeInfo' (PM.NodeInfo
111 { PM._nodeInfo_to = _nodeInfo_to
112 , PM._nodeInfo_from = _nodeInfo_from
113 })
115_NodeInfo
116 :: Iso
117 (NodeInfo k0 v0)
118 (NodeInfo k1 v1)
119 (PM.NodeInfo k0 (Proxy v0))
120 (PM.NodeInfo k1 (Proxy v1))
121_NodeInfo = iso unNodeInfo' NodeInfo'
123instance Functor (NodeInfo k) where
124 fmap f = runIdentity . traverse (Identity . f)
126instance Foldable (NodeInfo k) where
127 foldMap = foldMapDefault
129instance Traversable (NodeInfo k) where
130 traverse = _NodeInfo . traverseNodeInfo
131 where
132 traverseNodeInfo
133 :: Traversal (PM.NodeInfo k (Proxy a)) (PM.NodeInfo k (Proxy b)) a b
134 traverseNodeInfo = PM.bitraverseNodeInfo pure (\ ~Proxy -> pure Proxy)
136type From k v = PM.From k (Proxy v)
138{-# COMPLETE From_Insert, From_Delete, From_Move #-}
140pattern From_Insert :: v -> From k v
141pattern From_Insert v = PM.From_Insert v
143pattern From_Delete :: From k v
144pattern From_Delete = PM.From_Delete
146pattern From_Move :: k -> From k v
147pattern From_Move k = PM.From_Move k Proxy
149type To k = PM.To k
152-- | Create a 'PatchMapWithMove', validating it
153patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
154patchMapWithMove = fmap coerce . PM.patchMapWithPatchingMove . coerce
156-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
157patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
158patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
160-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
161insertMapKey :: k -> v -> PatchMapWithMove k v
162insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
164-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
165--
166-- @
167-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
168-- @
169moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
170moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
172-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
173--
174-- @
175-- let aMay = Map.lookup a map
176-- bMay = Map.lookup b map
177-- in maybe id (Map.insert a) (bMay `mplus` aMay)
178-- . maybe id (Map.insert b) (aMay `mplus` bMay)
179-- . Map.delete a . Map.delete b $ map
180-- @
181swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
182swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
184-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
185deleteMapKey :: k -> PatchMapWithMove k v
186deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
188-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
189--
190-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
191unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
192unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove . coerce
194-- | Apply the insertions, deletions, and moves to a given 'Map'
195instance Ord k => Patch (PatchMapWithMove k v) where
196 type PatchTarget (PatchMapWithMove k v) = Map k v
197 apply (PatchMapWithMove' p) = apply p
199-- | Returns all the new elements that will be added to the 'Map'.
200patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
201patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
203-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
204patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
205patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
207-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
208-- its values using the given ordering function. The set keys of the 'Map' is
209-- not changed.
210patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
211patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
213-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
214-- will produce a 'Map' with the same values as the second 'Map' but with the
215-- values sorted with the given ordering function.
216patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
217patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
218 where newList = Map.toList newByIndexUnsorted
219 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
221-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
222-- will produce the second 'Map'.
223patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
224patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
225 PM.patchThatChangesMap oldByIndex newByIndex
227-- | Change the 'From' value of a 'NodeInfo'
228nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
229nodeInfoMapFrom = coerce . PM.nodeInfoMapFrom
231-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
232-- 'Applicative', 'Monad', etc.) action to get the new value
233nodeInfoMapMFrom
234 :: Functor f
235 => (From k v -> f (From k v))
236 -> NodeInfo k v -> f (NodeInfo k v)
237nodeInfoMapMFrom f = fmap coerce . PM.nodeInfoMapMFrom f . coerce
239-- | Set the 'To' field of a 'NodeInfo'
240nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
241nodeInfoSetTo = coerce . PM.nodeInfoSetTo
243makeWrapped ''PatchMapWithMove
244makeWrapped ''NodeInfo