1{-# LANGUAGE DeriveDataTypeable #-}
2
3-- | In some cases, 'Data' instances for abstract types are incorrect,
4--   and fail to work correctly with Uniplate. This module defines three helper
5--   types ('Hide', 'Trigger' and 'Invariant') to assist when writing instances
6--   for abstract types. The 'Hide' type is useful when you want to mark some part
7--   of your data type as being ignored by "Data.Generics.Uniplate.Data"
8--   (and any other 'Data' based generics libraries, such as @syb@).
9--
10--   Using the helper types, this module defines wrappers for types in
11--   the @containers@ package, namely 'Map', 'Set', 'IntMap' and 'IntSet'.
12--   The standard @containers@ 'Data' instances all treat the types as abstract,
13--   but the wrapper types allow you to traverse within the data types, ensuring
14--   the necessary invariants are maintained. In particular, if you do not modify
15--   the keys reconstruct will be /O(n)/ instead of /O(n log n)/.
16--
17--   As an example of how to implement your own abstract type wrappers, the 'Map' data
18--   type is defined as:
19--
20-- @
21--   newtype Map k v = Map ('Invariant' ('Trigger' [k], 'Trigger' [v], Hide (Map.Map k v)))
22--      deriving (Data, Typeable)
23-- @
24--
25--   The 'Map' type is defined as an 'Invariant' of three components - the keys, the values, and
26--   the underlying @Map@. We use 'Invariant' to ensure that the keys/values/map always remain in sync.
27--   We use 'Trigger' on the keys and values to ensure that whenever the keys or values change we
28--   rebuild the @Map@, but if they don't, we reuse the previous @Map@. The 'fromMap' function is
29--   implemented by pattern matching on the 'Map' type:
30--
31-- @
32--   'fromMap' ('Map' ('Invariant' _ (_,_,'Hide' x))) = x
33-- @
34--
35--   The 'toMap' function is slightly harder, as we need to come up with an invariant restoring function:
36--
37-- > toMap :: Ord k => Map.Map k v -> Map k v
38-- > toMap x = Map $ Invariant inv $ create x
39-- >     where
40-- >         create x = (Trigger False ks, Trigger False vs, Hide x)
41-- >             where (ks,vs) = unzip $ Map.toAscList x
42-- >
43-- >         inv (ks,vs,x)
44-- >             | trigger ks = create $ Map.fromList $ zip (fromTrigger ks) (fromTrigger vs)
45-- >             | trigger vs = create $ Map.fromDistinctAscList $ zip (fromTrigger ks) (fromTrigger vs)
46-- >             | otherwise = (ks,vs,x)
47--
48--   The 'create' function creates a value from a @Map@, getting the correct keys and values. The 'inv'
49--   function looks at the triggers on the keys/values. If the keys trigger has been tripped, then we
50--   reconstruct the @Map@ using @fromList@. If the values trigger has been tripped, but they keys trigger
51--   has not, we can use @fromDistinctAscList@, reducing the complexity of constructing the @Map@. If nothing
52--   has changed we can reuse the previous value.
53--
54--   The end result is that all Uniplate (or @syb@) traversals over 'Map' result in a valid value, which has
55--   had all appropriate transformations applied.
56module Data.Generics.Uniplate.Data.Instances(
57    Hide(..), Trigger(..), Invariant(..),
58    Map, fromMap, toMap,
59    Set, fromSet, toSet,
60    IntMap, fromIntMap, toIntMap,
61    IntSet, fromIntSet, toIntSet
62    ) where
63
64import Data.Data
65import qualified Data.Map as Map
66import qualified Data.Set as Set
67import qualified Data.IntMap as IntMap
68import qualified Data.IntSet as IntSet
69
70
71---------------------------------------------------------------------
72-- DATA TYPES
73
74-- | The 'Hide' data type has a 'Data' instance which reports having no constructors,
75--   as though the type was defined as using the extension @EmptyDataDecls@:
76--
77-- > data Hide a
78--
79--   This type is suitable for defining regions that are avoided by Uniplate traversals.
80--   As an example:
81--
82-- > transformBi (+1) (1, 2, Hide 3, Just 4) == (2, 3, Hide 3, Just 4)
83--
84--   As a result of having no constructors, any calls to the methods 'toConstr' or 'gunfold'
85--   will raise an error.
86newtype Hide a = Hide {fromHide :: a}
87    deriving (Read,Ord,Eq,Typeable)
88
89instance Show a => Show (Hide a) where
90    show (Hide a) = "Hide " ++ show a
91
92instance Functor Hide where
93    fmap f (Hide x) = Hide $ f x
94
95
96instance Typeable a => Data (Hide a) where
97    gfoldl k z x = z x
98    gunfold k z c = error "Data.Generics.Uniplate.Data.Instances.Hide: gunfold not implemented - data type has no constructors"
99    toConstr _ = error "Data.Generics.Uniplate.Data.Instances.Hide: toConstr not implemented - data type has no constructors"
100    dataTypeOf _ = tyHide
101
102tyHide = mkDataType "Data.Generics.Uniplate.Data.Instances.Hide" []
103
104
105-- | The 'Trigger' data type has a 'Data' instance which reports as being defined:
106--
107-- > data Trigger a = Trigger a
108--
109--   However, whenever a 'gfoldl' or 'gunfold' constructs a new value, it will have the
110--   'trigger' field set to 'True'. The trigger information is useful to indicate whether
111--   any invariants have been broken, and thus need fixing. As an example:
112--
113-- > data SortedList a = SortedList (Trigger [a]) deriving (Data,Typeable)
114-- > toSortedList xs = SortedList $ Trigger False $ sort xs
115-- > fromSortedList (SortedList (Trigger t xs)) = if t then sort xs else xs
116--
117--   This data type represents a sorted list. When constructed the items are initially sorted,
118--   but operations such as 'gmapT' could break that invariant. The 'Trigger' type is used to
119--   detect when the Data operations have been performed, and resort the list.
120--
121--   The 'Trigger' type is often used in conjunction with 'Invariant', which fixes the invariants.
122data Trigger a = Trigger {trigger :: Bool, fromTrigger :: a}
123    deriving (Read,Ord,Eq,Show,Typeable)
124
125instance Functor Trigger where
126    fmap f (Trigger a b) = Trigger a $ f b
127
128
129instance (Data a, Typeable a) => Data (Trigger a) where
130    gfoldl k z (Trigger _ x) = z (Trigger True) `k` x
131    gunfold k z c = k $ z $ Trigger True
132    toConstr Trigger{} = conTrigger
133    dataTypeOf _ = tyTrigger
134
135conTrigger = mkConstr tyTrigger "Trigger" [] Prefix
136tyTrigger = mkDataType "Data.Generics.Uniplate.Data.Instances.Trigger" [conTrigger]
137
138
139-- | The 'Invariant' data type as a 'Data' instance which reports as being defined:
140--
141-- > data Invariant a = Invariant a
142--
143--   However, whenever a 'gfoldl' constructs a new value, it will have the function in
144--   the 'invariant' field applied to it. As an example:
145--
146-- > data SortedList a = SortedList (Invariant [a]) deriving (Data,Typeable)
147-- > toSortedList xs = SortedList $ Invariant sort (sort xs)
148-- > fromSortedList (SortedList (Invariant _ xs)) = xs
149--
150--   Any time an operation such as 'gmapT' is applied to the data type, the 'invariant' function
151--   is applied to the result. The @fromSortedList@ function can then rely on this invariant.
152--
153--   The 'gunfold' method is partially implemented - all constructed values will have an undefined
154--   value for all fields, regardless of which function is passed to 'fromConstrB'. If you only use
155--   'fromConstr' (as Uniplate does) then the 'gunfold' method is sufficient.
156data Invariant a = Invariant {invariant :: a -> a, fromInvariant :: a}
157    deriving Typeable
158
159instance Show a => Show (Invariant a) where
160    show (Invariant _ x) = "Invariant " ++ show x
161
162instance (Data a, Typeable a) => Data (Invariant a) where
163    gfoldl k z (Invariant f x) = z (Invariant f . f) `k` x
164    gunfold k z c = k $ z $ \x -> Invariant (error msg) (error msg `asTypeOf` x)
165        where msg = "Data.Generics.Uniplate.Data.Instances.Invariant: gunfold only partially implemented"
166    toConstr Invariant{} = conInvariant
167    dataTypeOf _ = tyInvariant
168
169conInvariant = mkConstr tyInvariant "Invariant" [] Prefix
170tyInvariant = mkDataType "Data.Generics.Uniplate.Data.Instances.Invariant" [conInvariant]
171
172
173---------------------------------------------------------------------
174-- DATA TYPES
175
176-- | Invariant preserving version of @Map@ from the @containers@ packages, suitable for use with 'Uniplate'.
177--   Use 'toMap' to construct values, and 'fromMap' to deconstruct values.
178newtype Map k v = Map (Invariant (Trigger [k], Trigger [v], Hide (Map.Map k v)))
179    deriving (Data, Typeable)
180
181instance (Show k, Show v) => Show (Map k v) where; show = show . fromMap
182instance (Eq k, Eq v) => Eq (Map k v) where; a == b = fromMap a == fromMap b
183instance (Ord k, Ord v) => Ord (Map k v) where; compare a b = compare (fromMap a) (fromMap b)
184
185-- | Deconstruct a value of type 'Map'.
186fromMap :: Map k v -> Map.Map k v
187fromMap (Map (Invariant _ (_,_,Hide x))) = x
188
189-- | Construct a value of type 'Map'.
190toMap :: Ord k => Map.Map k v -> Map k v
191toMap x = Map $ Invariant inv $ create x
192    where
193        create x = (Trigger False ks, Trigger False vs, Hide x)
194            where (ks,vs) = unzip $ Map.toAscList x
195
196        inv (ks,vs,x)
197            | trigger ks = create $ Map.fromList $ zip (fromTrigger ks) (fromTrigger vs)
198            | trigger vs = create $ Map.fromDistinctAscList $ zip (fromTrigger ks) (fromTrigger vs) -- recreate ks/vs to reduce memory usage
199            | otherwise = (ks,vs,x)
200
201
202-- | Invariant preserving version of @Set@ from the @containers@ packages, suitable for use with 'Uniplate'.
203--   Use 'toSet' to construct values, and 'fromSet' to deconstruct values.
204newtype Set k = Set (Invariant (Trigger [k], Hide (Set.Set k)))
205    deriving (Data, Typeable)
206
207instance Show k => Show (Set k) where; show = show . fromSet
208instance Eq k => Eq (Set k) where; a == b = fromSet a == fromSet b
209instance Ord k => Ord (Set k) where; compare a b = compare (fromSet a) (fromSet b)
210
211-- | Deconstruct a value of type 'Set'.
212fromSet :: Set k -> Set.Set k
213fromSet (Set (Invariant _ (_,Hide x))) = x
214
215-- | Construct a value of type 'Set'.
216toSet :: Ord k => Set.Set k -> Set k
217toSet x = Set $ Invariant inv $ create x
218    where
219        create x = (Trigger False $ Set.toList x, Hide x)
220
221        inv (ks,x)
222            | trigger ks = create $ Set.fromList $ fromTrigger ks
223            | otherwise = (ks,x)
224
225
226-- | Invariant preserving version of @IntMap@ from the @containers@ packages, suitable for use with 'Uniplate'.
227--   Use 'toIntMap' to construct values, and 'fromIntMap' to deconstruct values.
228newtype IntMap v = IntMap (Invariant (Trigger [Int], Trigger [v], Hide (IntMap.IntMap v)))
229    deriving (Data, Typeable)
230
231instance Show v => Show (IntMap v) where; show = show . fromIntMap
232instance Eq v => Eq (IntMap v) where; a == b = fromIntMap a == fromIntMap b
233instance Ord v => Ord (IntMap v) where; compare a b = compare (fromIntMap a) (fromIntMap b)
234
235-- | Deconstruct a value of type 'IntMap'.
236fromIntMap :: IntMap v -> IntMap.IntMap v
237fromIntMap (IntMap (Invariant _ (_,_,Hide x))) = x
238
239-- | Construct a value of type 'IntMap'.
240toIntMap :: IntMap.IntMap v -> IntMap v
241toIntMap x = IntMap $ Invariant inv $ create x
242    where
243        create x = (Trigger False ks, Trigger False vs, Hide x)
244            where (ks,vs) = unzip $ IntMap.toAscList x
245
246        inv (ks,vs,x)
247            | trigger ks = create $ IntMap.fromList $ zip (fromTrigger ks) (fromTrigger vs)
248            | trigger vs = create $ IntMap.fromDistinctAscList $ zip (fromTrigger ks) (fromTrigger vs) -- recreate ks/vs to reduce memory usage
249            | otherwise = (ks,vs,x)
250
251
252-- | Invariant preserving version of @IntSet@ from the @containers@ packages, suitable for use with 'Uniplate'.
253--   Use 'toIntSet' to construct values, and 'fromIntSet' to deconstruct values.
254newtype IntSet = IntSet (Invariant (Trigger [Int], Hide (IntSet.IntSet)))
255    deriving (Data, Typeable)
256
257instance Show IntSet where; show = show . fromIntSet
258instance Eq IntSet where; a == b = fromIntSet a == fromIntSet b
259instance Ord IntSet where; compare a b = compare (fromIntSet a) (fromIntSet b)
260
261-- | Deconstruct a value of type 'IntSet'.
262fromIntSet :: IntSet -> IntSet.IntSet
263fromIntSet (IntSet (Invariant _ (_,Hide x))) = x
264
265-- | Construct a value of type 'IntSet'.
266toIntSet :: IntSet.IntSet -> IntSet
267toIntSet x = IntSet $ Invariant inv $ create x
268    where
269        create x = (Trigger False $ IntSet.toList x, Hide x)
270
271        inv (ks,x)
272            | trigger ks = create $ IntSet.fromList $ fromTrigger ks
273            | otherwise = (ks,x)
274