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