{-# 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)