    {-# LANGUAGE CPP, Rank2Types, MagicHash, UnboxedTuples, ExistentialQuantification, ScopedTypeVariables #-}

    {- |
        Internal module, do not import or use.
    -}

    module Data.Generics.Uniplate.Internal.Data where

    import Data.Generics.Str
    import Data.Generics.Uniplate.Internal.Utils
    import Data.Data
    import Data.Generics
    import Data.Maybe
    import Data.List
    import Data.IORef
    import Control.Exception
    import Control.Monad
    import System.Environment(getEnv)
    import qualified Data.IntMap as IntMap; import Data.IntMap(IntMap)

    #if __GLASGOW_HASKELL__ < 606

    ---------------------------------------------------------------------
    -- GHC 6.4 and below

    import qualified Data.Set as Set
    import qualified Data.Map as Map

    type TypeKey = TypeRep
    type TypeSet = Set.Set TypeKey
    type TypeMap = Map.Map TypeKey

    typeKey :: Typeable a => a -> TypeKey
    typeKey = typeOf

    #elif __GLASGOW_HASKELL__ < 702

    ---------------------------------------------------------------------
    -- GHC 6.6 to 7.0 (has typeRepKey)

    import qualified Data.IntSet as Set
    import qualified Data.IntMap as Map

    type TypeKey = Int
    type TypeSet = Set.IntSet
    type TypeMap = Map.IntMap

    typeKey :: Typeable a => a -> TypeKey
    typeKey x = inlinePerformIO $ typeRepKey $ typeOf x

    #else

    ---------------------------------------------------------------------
    -- GHC 7.2 and above (using fingerprint)

    import qualified Data.HashMap.Strict as Map
    import qualified Data.HashSet as Set
    type TypeSet = Set.HashSet TypeKey
    type TypeMap = Map.HashMap TypeKey

    type TypeKey = TypeRep

    typeKey :: Typeable a => a -> TypeKey
    typeKey = typeOf

    #endif

    #if __GLASGOW_HASKELL__ < 702

    ---------------------------------------------------------------------
    -- GHC 7.0 and below (using containers API)

    (!) = (Map.!)
    map_findWithDefault = Map.findWithDefault
    map_fromAscList = Map.fromAscList
    map_keysSet = Map.keysSet
    map_member = Map.member
    set_partition = Set.partition
    set_toAscList = Set.toAscList
    set_unions = Set.unions

    #else

    ---------------------------------------------------------------------
    -- GHC 7.2 and above (using unordered-containers API)

    (!) mp k = map_findWithDefault (error "Could not find element") k mp
    map_findWithDefault d k mp = fromMaybe d $ Map.lookup k mp -- in 0.2.3.0 lookupDefault is strict in the default :(
    map_fromAscList = Map.fromList
    map_keysSet = Set.fromList . Map.keys
    map_member x xs = isJust $ Map.lookup x xs
    set_partition f x = (Set.filter f x, Set.filter (not . f) x)
    set_toAscList = Set.toList
    set_unions = foldr Set.union Set.empty

    #endif

    {-# NOINLINE uniplateVerbose #-}
    uniplateVerbose :: Int -- -1 = error if failed, 0 = quiet, 1 = print errors only, 2 = print everything
    uniplateVerbose = unsafePerformIO $ do
        fmap read (getEnv "UNIPLATE_VERBOSE") `Control.Exception.catch` \(_ :: SomeException) -> return 0

    ---------------------------------------------------------------------
    -- HIT TEST

    data Answer a = Hit {fromHit :: a} -- you just hit the element you were after (here is a cast)
                  | Follow -- go forward, you will find something
                  | Miss -- you failed to sink my battleship!

    data Oracle to = Oracle {fromOracle :: forall on . Typeable on => on -> Answer to}

    {-# INLINE hitTest #-}
    hitTest :: (Data from, Data to) => from -> to -> Oracle to
    hitTest from to =
        let kto = typeKey to
        in case readCacheFollower (dataBox from) kto of
               Nothing -> Oracle $ \on -> if typeKey on == kto then Hit $ unsafeCoerce on else Follow
               Just test -> Oracle $ \on -> let kon = typeKey on in
                       if kon == kto then Hit $ unsafeCoerce on
                       else if test kon then Follow
                       else Miss

    ---------------------------------------------------------------------
    -- CACHE
    -- Store and compute the Follower and HitMap

    data Cache = Cache HitMap (TypeMap2 (Maybe Follower))

    -- Indexed by the @from@ type, then the @to@ type
    -- Nothing means that we can't perform the trick on the set
    {-# NOINLINE cache #-}
    cache :: IORef Cache
    cache = unsafePerformIO $ newIORef $ Cache emptyHitMap Map.empty

    readCacheFollower :: DataBox -> TypeKey -> Maybe Follower
    readCacheFollower from@(DataBox kfrom vfrom) kto = inlinePerformIO $ do
        Cache hit follow <- readIORef cache
        case lookup2 kfrom kto follow of
            Just ans -> return ans
            Nothing -> do
                res <- Control.Exception.try (return $! insertHitMap from hit)
                (hit,fol) <- return $ case res of
                    Left _ -> (hit, Nothing)
                    Right hit -> (hit, Just $ follower kfrom kto hit)

                let msg =
                        "# Uniplate lookup on (" ++ show (typeOf vfrom) ++ "), from (" ++ show kfrom ++ "), to (" ++ show kto ++ "): " ++
                        either (\(msg::SomeException) -> "FAILURE (" ++ show msg ++ ")") (const "Success") res

                when (uniplateVerbose + maybe 1 (const 0) fol >= 2) $ putStrLn msg
                when (uniplateVerbose < 0 && isNothing fol) $ error msg

                atomicModifyIORef cache $ \(Cache _ follow) -> (Cache hit (insert2 kfrom kto fol follow), ())
                return fol

    -- from which values, what can you reach
    readCacheHitMap :: DataBox -> Maybe HitMap
    readCacheHitMap from@(DataBox kfrom vfrom) = inlinePerformIO $ do
        Cache hit _ <- readIORef cache
        case Map.lookup kfrom hit of
            Just _ -> return $ Just hit
            Nothing -> do
                res <- Control.Exception.catch (return $! Just $! insertHitMap from hit) (\(_ :: SomeException) -> return Nothing)
                case res of
                    Nothing -> return Nothing
                    Just hit -> do
                        atomicModifyIORef cache $ \(Cache _ follow) -> (Cache hit follow, ())
                        return $ Just hit

    ---------------------------------------------------------------------
    -- TYPEMAP2/INTMAP2

    type TypeMap2 a = TypeMap (TypeMap a)

    lookup2 :: TypeKey -> TypeKey -> TypeMap2 a -> Maybe a
    lookup2 x y mp = Map.lookup x mp >>= Map.lookup y

    insert2 :: TypeKey -> TypeKey -> a -> TypeMap2 a -> TypeMap2 a
    insert2 x y v mp = Map.insertWith (const $ Map.insert y v) x (Map.singleton y v) mp

    type IntMap2 a = IntMap (IntMap a)

    intLookup2 :: Int -> Int -> IntMap2 a -> Maybe a
    intLookup2 x y mp = IntMap.lookup x mp >>= IntMap.lookup y

    intInsert2 :: Int -> Int -> a -> IntMap2 a -> IntMap2 a
    intInsert2 x y v mp = IntMap.insertWith (const $ IntMap.insert y v) x (IntMap.singleton y v) mp

    ---------------------------------------------------------------------
    -- FOLLOWER
    -- Function to test if you should follow

    type Follower = TypeKey -> Bool

    -- HitMap must have addHitMap on the key
    follower :: TypeKey -> TypeKey -> HitMap -> Follower
    follower from to mp
        | Set.null hit = const False
        | Set.null miss = const True
        | Set.size hit < Set.size miss = \k -> k `Set.member` hit
        | otherwise = \k -> not $ k `Set.member` miss
        where
            (hit,miss) = set_partition (\x -> to `Set.member` grab x) (Set.insert from $ grab from)
            grab x = map_findWithDefault (error "couldn't grab in follower") x mp

    ---------------------------------------------------------------------
    -- DATA/TYPEABLE OPERATIONS

    -- | An existential box representing a type which supports SYB
    -- operations.
    data DataBox = forall a . (Data a) => DataBox {dataBoxKey :: TypeKey, dataBoxVal :: a}

    dataBox :: Data a => a -> DataBox
    dataBox x = DataBox (typeKey x) x

    -- NOTE: This function is partial, but all exceptions are caught later on
    sybChildren :: Data a => a -> [DataBox]
    sybChildren x
        | isAlgType dtyp = concatMap f ctrs
        | isNorepType dtyp = []
            -- Extensive discussions with Lennart and Roman decided that if something returns NorepType, it really wants to be atomic
            -- so we should let it be, and pretend it has no children.
            -- The most common types which say this are Data.Set/Data.Map, and we think that's a bug in their Data instances.
            -- error $ "Data.Generics.Uniplate.Data: sybChildren on data type which returns NorepType, " ++ show (typeOf x) ++ ", " ++ show dtyp
        | otherwise = []
        where
            f ctr = gmapQ dataBox (asTypeOf (fromConstr ctr) x)
            ctrs = dataTypeConstrs dtyp
            dtyp = dataTypeOf x

    ---------------------------------------------------------------------
    -- HITMAP
    -- What is the transitive closure of a type key

    type HitMap = TypeMap TypeSet

    emptyHitMap :: HitMap
    emptyHitMap = Map.fromList
            [(tRational, Set.singleton tInteger)
            ,(tInteger, Set.empty)]
        where tRational = typeKey (undefined :: Rational)
              tInteger = typeKey (0 :: Integer)

    insertHitMap :: DataBox -> HitMap -> HitMap
    insertHitMap box hit = fixEq trans (populate box) `Map.union` hit
        where
            -- create a fresh box with all the necessary children that aren't in hit
            populate :: DataBox -> HitMap
            populate x = f x Map.empty
                where
                    f (DataBox key val) mp
                        | key `map_member` hit || key `map_member` mp = mp
                        | otherwise = fs cs $ Map.insert key (Set.fromList $ map dataBoxKey cs) mp
                            where cs = sybChildren val

                    fs [] mp = mp
                    fs (x:xs) mp = fs xs (f x mp)

            -- update every one to be the transitive closure
            trans :: HitMap -> HitMap
            trans mp = Map.map f mp
                where
                    f x = set_unions $ x : map g (Set.toList x)
                    g x = map_findWithDefault (hit ! x) x mp

    fixEq :: Eq a => (a -> a) -> a -> a
    fixEq f x = if x == x2 then x2 else fixEq f x2
        where x2 = f x

    ---------------------------------------------------------------------
    -- INSTANCE FUNCTIONS

    newtype C x a = C {fromC :: CC x a}

    type CC x a = (Str x, Str x -> a)

    biplateData :: (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> on -> CC with on
    biplateData oracle x = case oracle x of
        Hit y -> (One y, \(One x) -> unsafeCoerce x)
        Follow -> uniplateData oracle x
        Miss -> (Zero, \_ -> x)

    uniplateData :: forall on with . (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> on -> CC with on
    uniplateData oracle item = fromC $ gfoldl combine create item
        where
            combine :: Data a => C with (a -> b) -> a -> C with b
            combine (C (c,g)) x = case biplateData oracle x of
                                      (c2, g2) -> C (Two c c2, \(Two c' c2') -> g c' (g2 c2'))

            create :: g -> C with g
            create x = C (Zero, \_ -> x)

    descendData :: Data on => (forall a . Typeable a => a -> Answer on) -> (on -> on) -> on -> on
    descendData oracle op = gmapT (descendBiData oracle op)

    descendBiData :: (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> (with -> with) -> on -> on
    descendBiData oracle op x = case oracle x of
        Hit y -> unsafeCoerce $ op y
        Follow -> gmapT (descendBiData oracle op) x
        Miss -> x

    descendDataM :: (Data on, Monad m) => (forall a . Typeable a => a -> Answer on) -> (on -> m on) -> on -> m on
    descendDataM oracle op = gmapM (descendBiDataM oracle op)

    descendBiDataM :: (Data on, Data with, Monad m) => (forall a . Typeable a => a -> Answer with) -> (with -> m with) -> on -> m on
    descendBiDataM oracle op x = case oracle x of
        Hit y -> unsafeCoerce $ op y
        Follow -> gmapM (descendBiDataM oracle op) x
        Miss -> return x

    ---------------------------------------------------------------------
    -- FUSION

    data Transformer = forall a . Data a => Transformer TypeKey (a -> a)

    -- | Wrap up a @(a -> a)@ transformation function, to use with 'transformBis'
    transformer :: Data a => (a -> a) -> Transformer
    transformer = transformer_

    -- Don't export directly, as don't want Haddock to see the forall
    transformer_ :: forall a . Data a => (a -> a) -> Transformer
    transformer_ = Transformer (typeKey (undefined :: a))

    -- | Apply a sequence of transformations in order. This function obeys the equivalence:
    --
    -- > transformBis [[transformer f],[transformer g],...] == transformBi f . transformBi g . ...
    --
    --   Each item of type @[Transformer]@ is applied in turn, right to left. Within each
    --   @[Transformer]@, the individual @Transformer@ values may be interleaved.
    --
    --   The implementation will attempt to perform fusion, and avoid walking any part of the
    --   data structure more than necessary. To further improve performance, you may wish to
    --   partially apply the first argument, which will calculate information about the relationship
    --   between the transformations.
    transformBis :: forall a . Data a => [[Transformer]] -> a -> a
    transformBis = transformBis_

    transformBis_ :: forall a . Data a => [[Transformer]] -> a -> a

    -- basic algorithm:
    -- as you go down, given transformBis [fN..f1]
    --   if x is not in the set reachable by fN..f1, return x
    --   if x is in the reachable set, gmap (transformBis [fN..f1]) x
    --   if x is one of fN..f1, pick the lowest fi then
    --      transformBis [fN..f(i+1)] $ fi $ gmap (transformBis [fi..f1]) x

    transformBis_ ts | isJust hitBoxM = op (sliceMe 1 n)
        where
            on = dataBox (undefined :: a)
            hitBoxM = readCacheHitMap on
            hitBox = fromJust hitBoxM
            univ = set_toAscList $ Set.insert (dataBoxKey on) $ hitBox ! dataBoxKey on
            n = length ts

            -- (a,b), where a < b, and both in range 1..n
            sliceMe i j = fromMaybe Map.empty $ intLookup2 i j slices
            slices :: IntMap2 (TypeMap (Maybe Transformer))
            slices = IntMap.fromAscList
                [ (i, IntMap.fromAscList [(j, slice i j ts) | (j,ts) <- zip [i..n] (tail $ inits ts)])
                | (i,ts) <- zip [1..n] (tails $ reverse ts)]

            slice :: Int -> Int -> [[Transformer]] -> TypeMap (Maybe Transformer)
            slice from to tts = self
                where
                    self = f Map.empty (zip [from..] tts) -- FIXME: flattening out here gives different results...
                    f a ((i,[Transformer tk tr]):ts)
                        | tk `map_member` a = f a ts
                        | otherwise = f (Map.insert tk t a) ts
                        where
                            t = Just $ Transformer tk $ op (sliceMe (i+1) to) . tr . gmapT (op $ sliceMe from i)

                    f a [] = a `Map.union` map_fromAscList (mapMaybe (g $ map_keysSet a) univ)

                    g a t = if b then Nothing else Just (t, Nothing)
                        where b = Set.null $ a `Set.intersection` (hitBox ! t)

            op :: forall b . Data b => TypeMap (Maybe Transformer) -> b -> b
            op slice = case Map.lookup (typeKey (undefined :: b)) slice of
                Nothing -> id
                Just Nothing -> gmapT (op slice)
                Just (Just (Transformer _ t)) -> unsafeCoerce . t . unsafeCoerce

    transformBis_ [] = id
    transformBis_ ([]:xs) = transformBis_ xs
    transformBis_ ((Transformer _ t:x):xs) = everywhere (mkT t) . transformBis_ (x:xs)