{-# LANGUAGE DeriveDataTypeable #-} -- | In some cases, 'Data' instances for abstract types are incorrect, -- and fail to work correctly with Uniplate. This module defines three helper -- types ('Hide', 'Trigger' and 'Invariant') to assist when writing instances -- for abstract types. The 'Hide' type is useful when you want to mark some part -- of your data type as being ignored by "Data.Generics.Uniplate.Data" -- (and any other 'Data' based generics libraries, such as @syb@). -- -- Using the helper types, this module defines wrappers for types in -- the @containers@ package, namely 'Map', 'Set', 'IntMap' and 'IntSet'. -- The standard @containers@ 'Data' instances all treat the types as abstract, -- but the wrapper types allow you to traverse within the data types, ensuring -- the necessary invariants are maintained. In particular, if you do not modify -- the keys reconstruct will be /O(n)/ instead of /O(n log n)/. -- -- As an example of how to implement your own abstract type wrappers, the 'Map' data -- type is defined as: -- -- @ -- newtype Map k v = Map ('Invariant' ('Trigger' [k], 'Trigger' [v], Hide (Map.Map k v))) -- deriving (Data, Typeable) -- @ -- -- The 'Map' type is defined as an 'Invariant' of three components - the keys, the values, and -- the underlying @Map@. We use 'Invariant' to ensure that the keys/values/map always remain in sync. -- We use 'Trigger' on the keys and values to ensure that whenever the keys or values change we -- rebuild the @Map@, but if they don't, we reuse the previous @Map@. The 'fromMap' function is -- implemented by pattern matching on the 'Map' type: -- -- @ -- 'fromMap' ('Map' ('Invariant' _ (_,_,'Hide' x))) = x -- @ -- -- The 'toMap' function is slightly harder, as we need to come up with an invariant restoring function: -- -- > toMap :: Ord k => Map.Map k v -> Map k v -- > toMap x = Map $ Invariant inv $ create x -- > where -- > create x = (Trigger False ks, Trigger False vs, Hide x) -- > where (ks,vs) = unzip $ Map.toAscList x -- > -- > inv (ks,vs,x) -- > | trigger ks = create $ Map.fromList $ zip (fromTrigger ks) (fromTrigger vs) -- > | trigger vs = create $ Map.fromDistinctAscList $ zip (fromTrigger ks) (fromTrigger vs) -- > | otherwise = (ks,vs,x) -- -- The 'create' function creates a value from a @Map@, getting the correct keys and values. The 'inv' -- function looks at the triggers on the keys/values. If the keys trigger has been tripped, then we -- reconstruct the @Map@ using @fromList@. If the values trigger has been tripped, but they keys trigger -- has not, we can use @fromDistinctAscList@, reducing the complexity of constructing the @Map@. If nothing -- has changed we can reuse the previous value. -- -- The end result is that all Uniplate (or @syb@) traversals over 'Map' result in a valid value, which has -- had all appropriate transformations applied. module Data.Generics.Uniplate.Data.Instances( Hide(..), Trigger(..), Invariant(..), Map, fromMap, toMap, Set, fromSet, toSet, IntMap, fromIntMap, toIntMap, IntSet, fromIntSet, toIntSet ) where import Data.Data import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet --------------------------------------------------------------------- -- DATA TYPES -- | The 'Hide' data type has a 'Data' instance which reports having no constructors, -- as though the type was defined as using the extension @EmptyDataDecls@: -- -- > data Hide a -- -- This type is suitable for defining regions that are avoided by Uniplate traversals. -- As an example: -- -- > transformBi (+1) (1, 2, Hide 3, Just 4) == (2, 3, Hide 3, Just 4) -- -- As a result of having no constructors, any calls to the methods 'toConstr' or 'gunfold' -- will raise an error. newtype Hide a = Hide {fromHide :: a} deriving (Read,Ord,Eq,Typeable) instance Show a => Show (Hide a) where show (Hide a) = "Hide " ++ show a instance Functor Hide where fmap f (Hide x) = Hide $ f x instance Typeable a => Data (Hide a) where gfoldl k z x = z x gunfold k z c = error "Data.Generics.Uniplate.Data.Instances.Hide: gunfold not implemented - data type has no constructors" toConstr _ = error "Data.Generics.Uniplate.Data.Instances.Hide: toConstr not implemented - data type has no constructors" dataTypeOf _ = tyHide tyHide = mkDataType "Data.Generics.Uniplate.Data.Instances.Hide" [] -- | The 'Trigger' data type has a 'Data' instance which reports as being defined: -- -- > data Trigger a = Trigger a -- -- However, whenever a 'gfoldl' or 'gunfold' constructs a new value, it will have the -- 'trigger' field set to 'True'. The trigger information is useful to indicate whether -- any invariants have been broken, and thus need fixing. As an example: -- -- > data SortedList a = SortedList (Trigger [a]) deriving (Data,Typeable) -- > toSortedList xs = SortedList $ Trigger False $ sort xs -- > fromSortedList (SortedList (Trigger t xs)) = if t then sort xs else xs -- -- This data type represents a sorted list. When constructed the items are initially sorted, -- but operations such as 'gmapT' could break that invariant. The 'Trigger' type is used to -- detect when the Data operations have been performed, and resort the list. -- -- The 'Trigger' type is often used in conjunction with 'Invariant', which fixes the invariants. data Trigger a = Trigger {trigger :: Bool, fromTrigger :: a} deriving (Read,Ord,Eq,Show,Typeable) instance Functor Trigger where fmap f (Trigger a b) = Trigger a $ f b instance (Data a, Typeable a) => Data (Trigger a) where gfoldl k z (Trigger _ x) = z (Trigger True) `k` x gunfold k z c = k $ z $ Trigger True toConstr Trigger{} = conTrigger dataTypeOf _ = tyTrigger conTrigger = mkConstr tyTrigger "Trigger" [] Prefix tyTrigger = mkDataType "Data.Generics.Uniplate.Data.Instances.Trigger" [conTrigger] -- | The 'Invariant' data type as a 'Data' instance which reports as being defined: -- -- > data Invariant a = Invariant a -- -- However, whenever a 'gfoldl' constructs a new value, it will have the function in -- the 'invariant' field applied to it. As an example: -- -- > data SortedList a = SortedList (Invariant [a]) deriving (Data,Typeable) -- > toSortedList xs = SortedList $ Invariant sort (sort xs) -- > fromSortedList (SortedList (Invariant _ xs)) = xs -- -- Any time an operation such as 'gmapT' is applied to the data type, the 'invariant' function -- is applied to the result. The @fromSortedList@ function can then rely on this invariant. -- -- The 'gunfold' method is partially implemented - all constructed values will have an undefined -- value for all fields, regardless of which function is passed to 'fromConstrB'. If you only use -- 'fromConstr' (as Uniplate does) then the 'gunfold' method is sufficient. data Invariant a = Invariant {invariant :: a -> a, fromInvariant :: a} deriving Typeable instance Show a => Show (Invariant a) where show (Invariant _ x) = "Invariant " ++ show x instance (Data a, Typeable a) => Data (Invariant a) where gfoldl k z (Invariant f x) = z (Invariant f . f) `k` x gunfold k z c = k $ z $ \x -> Invariant (error msg) (error msg `asTypeOf` x) where msg = "Data.Generics.Uniplate.Data.Instances.Invariant: gunfold only partially implemented" toConstr Invariant{} = conInvariant dataTypeOf _ = tyInvariant conInvariant = mkConstr tyInvariant "Invariant" [] Prefix tyInvariant = mkDataType "Data.Generics.Uniplate.Data.Instances.Invariant" [conInvariant] --------------------------------------------------------------------- -- DATA TYPES -- | Invariant preserving version of @Map@ from the @containers@ packages, suitable for use with 'Uniplate'. -- Use 'toMap' to construct values, and 'fromMap' to deconstruct values. newtype Map k v = Map (Invariant (Trigger [k], Trigger [v], Hide (Map.Map k v))) deriving (Data, Typeable) instance (Show k, Show v) => Show (Map k v) where; show = show . fromMap instance (Eq k, Eq v) => Eq (Map k v) where; a == b = fromMap a == fromMap b instance (Ord k, Ord v) => Ord (Map k v) where; compare a b = compare (fromMap a) (fromMap b) -- | Deconstruct a value of type 'Map'. fromMap :: Map k v -> Map.Map k v fromMap (Map (Invariant _ (_,_,Hide x))) = x -- | Construct a value of type 'Map'. toMap :: Ord k => Map.Map k v -> Map k v toMap x = Map $ Invariant inv $ create x where create x = (Trigger False ks, Trigger False vs, Hide x) where (ks,vs) = unzip $ Map.toAscList x inv (ks,vs,x) | trigger ks = create $ Map.fromList $ zip (fromTrigger ks) (fromTrigger vs) | trigger vs = create $ Map.fromDistinctAscList $ zip (fromTrigger ks) (fromTrigger vs) -- recreate ks/vs to reduce memory usage | otherwise = (ks,vs,x) -- | Invariant preserving version of @Set@ from the @containers@ packages, suitable for use with 'Uniplate'. -- Use 'toSet' to construct values, and 'fromSet' to deconstruct values. newtype Set k = Set (Invariant (Trigger [k], Hide (Set.Set k))) deriving (Data, Typeable) instance Show k => Show (Set k) where; show = show . fromSet instance Eq k => Eq (Set k) where; a == b = fromSet a == fromSet b instance Ord k => Ord (Set k) where; compare a b = compare (fromSet a) (fromSet b) -- | Deconstruct a value of type 'Set'. fromSet :: Set k -> Set.Set k fromSet (Set (Invariant _ (_,Hide x))) = x -- | Construct a value of type 'Set'. toSet :: Ord k => Set.Set k -> Set k toSet x = Set $ Invariant inv $ create x where create x = (Trigger False $ Set.toList x, Hide x) inv (ks,x) | trigger ks = create $ Set.fromList $ fromTrigger ks | otherwise = (ks,x) -- | Invariant preserving version of @IntMap@ from the @containers@ packages, suitable for use with 'Uniplate'. -- Use 'toIntMap' to construct values, and 'fromIntMap' to deconstruct values. newtype IntMap v = IntMap (Invariant (Trigger [Int], Trigger [v], Hide (IntMap.IntMap v))) deriving (Data, Typeable) instance Show v => Show (IntMap v) where; show = show . fromIntMap instance Eq v => Eq (IntMap v) where; a == b = fromIntMap a == fromIntMap b instance Ord v => Ord (IntMap v) where; compare a b = compare (fromIntMap a) (fromIntMap b) -- | Deconstruct a value of type 'IntMap'. fromIntMap :: IntMap v -> IntMap.IntMap v fromIntMap (IntMap (Invariant _ (_,_,Hide x))) = x -- | Construct a value of type 'IntMap'. toIntMap :: IntMap.IntMap v -> IntMap v toIntMap x = IntMap $ Invariant inv $ create x where create x = (Trigger False ks, Trigger False vs, Hide x) where (ks,vs) = unzip $ IntMap.toAscList x inv (ks,vs,x) | trigger ks = create $ IntMap.fromList $ zip (fromTrigger ks) (fromTrigger vs) | trigger vs = create $ IntMap.fromDistinctAscList $ zip (fromTrigger ks) (fromTrigger vs) -- recreate ks/vs to reduce memory usage | otherwise = (ks,vs,x) -- | Invariant preserving version of @IntSet@ from the @containers@ packages, suitable for use with 'Uniplate'. -- Use 'toIntSet' to construct values, and 'fromIntSet' to deconstruct values. newtype IntSet = IntSet (Invariant (Trigger [Int], Hide (IntSet.IntSet))) deriving (Data, Typeable) instance Show IntSet where; show = show . fromIntSet instance Eq IntSet where; a == b = fromIntSet a == fromIntSet b instance Ord IntSet where; compare a b = compare (fromIntSet a) (fromIntSet b) -- | Deconstruct a value of type 'IntSet'. fromIntSet :: IntSet -> IntSet.IntSet fromIntSet (IntSet (Invariant _ (_,Hide x))) = x -- | Construct a value of type 'IntSet'. toIntSet :: IntSet.IntSet -> IntSet toIntSet x = IntSet $ Invariant inv $ create x where create x = (Trigger False $ IntSet.toList x, Hide x) inv (ks,x) | trigger ks = create $ IntSet.fromList $ fromTrigger ks | otherwise = (ks,x)