@@ -11,18 +11,30 @@
1111{-# LANGUAGE TemplateHaskell #-}
1212{-# LANGUAGE TypeApplications #-}
1313{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE ViewPatterns #-}
1415
1516-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
1617-- another
1718module Data.Patch.MapWithMove
1819 ( module Data.Patch.MapWithMove
19− , PatchMapWithMove (PatchMapWithMove)
20+ , PatchMapWithMove
21+ ( PatchMapWithMove
22+ , -- | Extract the representation of the 'PatchMapWithMove' as a map of
23+ -- 'NodeInfo'.
24+ unPatchMapWithMove
25+ , ..
26+ )
2027 , NodeInfo
21− , pattern PM.NodeInfo
22− , PM._nodeInfo_to
23− , PM._nodeInfo_from
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)
2435 ) where
2536
37+import Data.Coerce
2638import Data.Patch.Class
2739import Data.Patch.MapWithPatchingMove
2840 ( PatchMapWithPatchingMove (..)
@@ -47,16 +59,25 @@ newtype PatchMapWithMove k v = PatchMapWithMove'
4759 unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
4860 }
4961 deriving ( Show, Read, Eq, Ord
50− , Semigroup, Monoid
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
5167 )
5268
5369{-# COMPLETE PatchMapWithMove #-}
5470pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
55−pattern PatchMapWithMove m = PatchMapWithMove' (PatchMapWithPatchingMove m)
71+pattern PatchMapWithMove { unPatchMapWithMove } <- PatchMapWithMove' (PatchMapWithPatchingMove (coerce -> unPatchMapWithMove))
72+ where PatchMapWithMove m = PatchMapWithMove' $ PatchMapWithPatchingMove $ coerce m
5673
57−-- | Extract the internal representation of the 'PatchMapWithMove'
58−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (PM.NodeInfo k (Proxy v))
59−unPatchMapWithMove = unPatchMapWithPatchingMove . unPatchMapWithMove'
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
6081
6182instance Functor (PatchMapWithMove k) where
6283 fmap f = runIdentity . traverse (Identity . f)
@@ -66,22 +87,51 @@ instance Foldable (PatchMapWithMove k) where
6687
6788instance Traversable (PatchMapWithMove k) where
6889 traverse =
69− _Wrapping PatchMapWithMove' .
70− _Wrapping PatchMapWithPatchingMove .
90+ _PatchMapWithMove .
7191 traverse .
72− traverseNodeInfo
92+ traverse
7393
7494instance FunctorWithIndex k (PatchMapWithMove k)
7595instance FoldableWithIndex k (PatchMapWithMove k)
7696instance TraversableWithIndex k (PatchMapWithMove k) where
7797 itraverse = itraversed . Indexed
7898 itraversed =
79− _Wrapping PatchMapWithMove' .>
80− _Wrapping PatchMapWithPatchingMove .>
99+ _PatchMapWithMove .>
81100 itraversed <.
82− traverseNodeInfo
101+ traverse
83102
84−type NodeInfo k v = PM.NodeInfo k (Proxy v)
103+newtype NodeInfo k v = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
104+ deriving ( Show, Read, Eq, Ord
105+ )
106+
107+{-# COMPLETE NodeInfo #-}
108+pattern NodeInfo :: To k -> From k v -> NodeInfo k v
109+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } =
110+ NodeInfo' (PM.NodeInfo
111+ { PM._nodeInfo_to = _nodeInfo_to
112+ , PM._nodeInfo_from = _nodeInfo_from
113+ })
114+
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'
122+
123+instance Functor (NodeInfo k) where
124+ fmap f = runIdentity . traverse (Identity . f)
125+
126+instance Foldable (NodeInfo k) where
127+ foldMap = foldMapDefault
128+
129+instance 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)
85135
86136type From k v = PM.From k (Proxy v)
87137
@@ -98,13 +148,10 @@ pattern From_Move k = PM.From_Move k Proxy
98148
99149type To k = PM.To k
100150
101−traverseNodeInfo
102− :: Traversal (NodeInfo k a) (NodeInfo k b) a b
103−traverseNodeInfo = PM.bitraverseNodeInfo pure (\ ~Proxy -> pure Proxy)
104151
105152-- | Create a 'PatchMapWithMove', validating it
106153patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
107−patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove
154+patchMapWithMove = fmap coerce . PM.patchMapWithPatchingMove . coerce
108155
109156-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
110157patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
@@ -142,7 +189,7 @@ deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
142189--
143190-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
144191unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
145−unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove
192+unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove . coerce
146193
147194-- | Apply the insertions, deletions, and moves to a given 'Map'
148195instance Ord k => Patch (PatchMapWithMove k v) where
@@ -179,7 +226,7 @@ patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
179226
180227-- | Change the 'From' value of a 'NodeInfo'
181228nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
182−nodeInfoMapFrom = PM.nodeInfoMapFrom
229+nodeInfoMapFrom = coerce . PM.nodeInfoMapFrom
183230
184231-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
185232-- 'Applicative', 'Monad', etc.) action to get the new value
@@ -187,10 +234,11 @@ nodeInfoMapMFrom
187234 :: Functor f
188235 => (From k v -> f (From k v))
189236 -> NodeInfo k v -> f (NodeInfo k v)
190−nodeInfoMapMFrom = PM.nodeInfoMapMFrom
237+nodeInfoMapMFrom f = fmap coerce . PM.nodeInfoMapMFrom f . coerce
191238
192239-- | Set the 'To' field of a 'NodeInfo'
193240nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
194−nodeInfoSetTo = PM.nodeInfoSetTo
241+nodeInfoSetTo = coerce . PM.nodeInfoSetTo
195242
196243makeWrapped ''PatchMapWithMove
244+makeWrapped ''NodeInfo