-------------------------------------------------------------------------------

{-# LANGUAGE CPP #-}

-------------------------------------------------------------------------------

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-  LANGUAGE ImpredicativeTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  SAI.Data.Generics.Shape.SYB.Filter
-- Copyright   :  (c) Andrew Seniuk, 2014
-- License     :  BSD-style (see the LICENSE file)
-- 
-- Maintainer  :  rasfar@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (uses Data.Generics.Basics)
--
-- This package provides SYB shape support: generic mapping to
-- homogeneous types, and related features.  Complements existing
-- Uniplate and TH shape libraries.  See <http://www.fremissant.net/shape-syb>
-- for more information.
--
-- The present module provides limited support for structure-changing
-- transformations, some generic, others on the homogeneous types.
--
-----------------------------------------------------------------------------

  module SAI.Data.Generics.Shape.SYB.Filter (

    -- * Lifted result, but good structure preservation (via glue nodes)
    -- | These functions simplify the structure by removing all possible
    -- 'Nothing' nodes, without disrupting the lineal relations obtaining
    -- between 'Just' nodes.
    --
    -- Recall that
    --
    -- @type 'HomoM' r = 'Homo' ('Maybe' r)@
    --
    -- and
    --
    -- @type 'BiM' r = 'Bi' ('Maybe' r) = 'Homo' ('Dynamic', 'Maybe' r)@
    --
    -- See "Shape.SYB" for other functions involving 'HomoM' and 'BiM'.

    filterHomoM ,
    filterBiM ,

    -- * Lifted argument, as well as result; same transformation
    -- | Note that these functions don't take a predicate;
    -- the filtering predicate is encoded in the @'Maybe' r@ input.

    filterHomoMM ,
    filterBiMM ,

    -- * Unlifted result, but less structure preserved (no glue nodes)
    -- | These filter functions produce trees containing only nodes
    -- which satisfy the predicate, and yet which inherit the structure
    -- of the argument to some extent.
    --
    -- For each node N, the algorithm acts on all children C of N which
    -- fail the predicate. The transformation is to move the
    -- grandchildren of N via C into child position, in place of C,
    -- which is elided.  Recurse to fixed point.  (You'd think one of
    -- bottom-up or top-down would do it in one pass, but ... maybe I
    -- did something wrong...)
    --
    -- Other transformations are possible; see also 'filterHomoM_.

    filterHomo ,
    filterHetero ,
    filterBi ,

    -- * Lifted argument, less structure preservation (no glue nodes)
    -- | These don't require a predicate or default values, depending
    -- instead on 'Nothing' for default, and on the predicate being
    -- encoded as 'Nothing' / 'Just'.

    filterHomoM_ ,
    filterHomoM_' ,

    -- * Experimental, but sufficient for the task

    gfilter ,
    gfilter_ ,
    mkQP ,

  ) where

-------------------------------------------------------------------------------

  import Data.Data ( cast )
  import Data.Data ( gfoldl )
  import Data.Data ( gmapQ )
  import Data.Data ( Data )
  import Data.Data ( Typeable )
  import Data.Generics.Aliases ( GenericQ )
  import Data.Generics.Aliases ( mkQ )
  import Data.Generics.Aliases ( extQ )
  import Data.Generics.Aliases ( GenericT )
  import Data.Data ( gmapT )
--import Data.Function ( fix )
  import Data.Dynamic
--import Data.HList
  import Data.Maybe

  import SAI.Data.Generics.Shape.SYB

  import Debug.Trace ( trace )

-------------------------------------------------------------------------------

  filterHomo :: (r -> Bool) -> Homo r -> Homo r
  filterHomo p = condenseHomo (filterHomo' p)

  filterHetero :: Typeable r => (r -> Bool) -> Hetero -> Hetero
  filterHetero p = condenseHetero (filterHetero' p)

  filterBi :: (r -> Bool) -> Bi r -> Bi r
  filterBi p = condenseBi (filterBi' p)

-------------------------------------------------------------------------------

  filterHomo' :: forall r. (r -> Bool) -> Homo r -> Homo r
  filterHomo' p (Node rp chsp) = Node rp chsp'  -- XXX root stays...
   where
    chsp' = map (filterHomo' p) $ concatMap f chsp  -- top-down
--  chsp' = concatMap f chsp                        -- bottom-up
    f :: Rose r -> [ Rose r ]
    f c@(Node rc chsc)
     | p rc       = [c]
     | otherwise  = chsc'
     where
      chsc' = chsc                                  -- top-down
--    chsc' = map (filterHomo' p) chsc              -- bottom-up

  filterHetero' :: Typeable r => (r -> Bool) -> Hetero -> Hetero
  filterHetero' p (Node d chsp) = Node d chsp'  -- XXX root stays...
   where
    chsp' = map (filterHetero' p) $ concatMap f chsp
    -- It seems this one does not give an error (no type vars?):
    f :: Rose Dynamic -> [ Rose Dynamic ]
    f c@(Node dc chsc)
#if 1
     | isNothing mrc  = chsc'
     | p rc           = [c]
     | otherwise      = chsc'
#else
     | isNothing mrc  = trace ("*1> "++showDyn dc) $ chsc'
     | p rc           = trace ("*2> "++showDyn dc) $ [c]
     | otherwise      = trace ("*3> "++showDyn dc) $ chsc'
#endif
     where
      mrc = fromDynamic dc
      rc = fromJust mrc
      chsc' = chsc

  filterBi' :: forall r. (r -> Bool) -> Bi r -> Bi r
  filterBi' p (Node (d,rp) chsp) = Node (d,rp) chsp'  -- XXX root stays...
   where
    chsp' = map (filterBi' p) $ concatMap f chsp
    f :: Bi r -> [ Bi r ]
    f c@(Node (_,rc) chsc)
     | p rc       = [c]
     | otherwise  = chsc'
     where
      chsc' = chsc

-------------------------------------------------------------------------------

  -- condense can (in principle) diverge, so watch your algorithm...

  condenseHomo :: (Homo a -> Homo a) -> Homo a -> Homo a
  condenseHomo = condenseRose
  condenseHetero :: (Hetero -> Hetero) -> Hetero -> Hetero
  condenseHetero = condenseRose
  condenseBi :: (Bi a -> Bi a) -> Bi a -> Bi a
  condenseBi = condenseRose

  -- Had kept the original Eq versions; but there's simply no point,
  -- as the values are never changed by the algorithm!
  -- See cotemp (20140616131313) ./t01...

-------------------------------------------------------------------------------

  -- I started by assuming the "fix" function would be appropriate,
  -- then didn't figure out how to use it.  Then I wrote this; although
  -- Math.Sequence.Converge could be used, it's such little code for
  -- an extra library dep.  I toyed with names "myfix", "converge",
  -- "limit", and finally settled on "condense".

  condenseRose :: (Rose a -> Rose a) -> Rose a -> Rose a  -- can diverge!...
  condenseRose f z = condenseRose' $ iterate f z
--condenseRose f z = condenseRose' $ ( iterate f z :: [ Rose a ] )
   where
    -- It would be preferable to accumulate the size info with f,
    -- that is, to wrap f into an f' which also accumulates and
    -- returns the size; there's no excuse to traverse it twice,
    -- and I highly doubt this will fuse...
    condenseRose' :: [ Rose a ] -> Rose a
    condenseRose' (x:y:t) | sizeOfRose x == sizeOfRose y  = x
                          | otherwise                     = condenseRose' (y:t)
    -- no other cases needed -- we know the argument is infinite

  -- May as well provide it since it makes sense and is the most general:
  condenseEq :: Eq a => (a -> a) -> a -> a  -- can diverge!...
  condenseEq f z = condenseEq' $ iterate f z
   where
    condenseEq' (x:y:t) | x == y     = x
                        | otherwise  = condenseEq' (y:t)
    -- no other cases needed -- we know the argument is infinite

-------------------------------------------------------------------------------

  -- | 'filterHomoM_' acts on a lifted type to avoid needing to
  -- specify any default values; however, the root node cannot
  -- be eliminated by this algorithm, so in case the root is
  -- a 'Nothing', we need to return its child branches as a forest.
  filterHomoM_ :: HomoM r -> [Homo r]
  filterHomoM_ x
   | otherwise = map (fmap fromJust) forest
   where
    p = not . isNothing
    forest
     | p r_root  = [final]
     | otherwise = chs_root
    -- Needed! (and the error hasn't fired so far...)
    final@(Node r_root chs_root) = prune $ condenseHomo (filterHomo' p) x
    prune (Node r chs) = Node r (map prune chs')
     where
      chs' = filter pp chs
      pp (Node rx chsx)
       | null chsx  = not $ isNothing rx
       | otherwise  = error "filterHomo-prune: interior non-root Nothing!"

  -- | 'filterHomoM_' plus a root default value in the homogeneous type;
  -- this allows us to always return a single rooted tree in type @'Homo' r@.
  -- Compare to 'filterHomoM_' which, lacking such a root default,
  -- is obliged to return @['Homo' r]@.
  filterHomoM_' :: r -> HomoM r -> Homo r
  filterHomoM_' rdflt x
   | null forest    = error "filterHomoM_': null forest"
   | [x] <- forest  = x
   | otherwise      = Node rdflt forest
   where
    forest = filterHomoM_ x

-------------------------------------------------------------------------------

  -- XXX So much cloned code here; how to do a single?

  -- | Tolerate lifted nodes in the result, in exchange for
  -- better structure preservation.
  --
  -- Lineal ordering is preserved among 'Just' nodes.
  --
  -- In the end, this is probably the most useful (unless one that
  -- takes a generic predicate, and acts on original types obtained
  -- via fromDyn[amic]...).
  filterHomoM :: (r -> Bool) -> Homo r -> HomoM r
  filterHomoM p x = x''
   where
    p' y = if p y
           then Just y
           else Nothing
    x_ = fmap  p' x
    x' = condenseHomo defuzz x_
    -- XXX Surely can do bottom-up and avoid iterating?
    defuzz :: HomoM r -> HomoM r
    defuzz (Node v chs) = Node v $ map defuzz chs'
     where
      chs' = filter g chs
      g (Node Nothing []) = False
      g _ = True
    x'' = condenseHomo contractGlue x'
    contractGlue :: HomoM r -> HomoM r
    contractGlue (Node r chs) = Node r $ map contractGlue chs'
     where
      chs' = map contractNothing1 chs
      contractNothing1 (Node Nothing [ch@(Node _ chs)]) = ch
      contractNothing1 v = v

  -- | As per 'filterHomoM', but we string along the 'Dynamic' component.
  filterBiM :: (r -> Bool) -> Bi r -> BiM r
  filterBiM p x = x''
   where
    p' y = if p y
           then Just y
           else Nothing
    x_ = fmap (\ (d,r) -> (d,p' r) ) x
    x' = condenseBi defuzz x_
    -- XXX Surely can do bottom-up and avoid iterating?
    defuzz :: BiM r -> BiM r
    defuzz (Node v chs) = Node v $ map defuzz chs'
     where
      chs' = filter g chs
      g (Node (_,Nothing) []) = False
      g _ = True
    x'' = condenseBi contractGlue x'
    contractGlue :: BiM r -> BiM r
    contractGlue (Node r chs) = Node r $ map contractGlue chs'
     where
      chs' = map contractNothing1 chs
      contractNothing1 (Node (_,Nothing) [ch@(Node _ chs)]) = ch
      contractNothing1 v = v

  -- | Tolerate lifted nodes in the result, in exchange for
  -- better structure preservation.
  --
  -- Lineal ordering is preserved among 'Just' nodes.
  filterHomoMM :: HomoM r -> HomoM r
  filterHomoMM x = x''
   where
    x' = condenseHomo defuzz x
    -- XXX Surely can do bottom-up and avoid iterating?
    defuzz :: HomoM r -> HomoM r
    defuzz (Node v chs) = Node v $ map defuzz chs'
     where
      chs' = filter g chs
      g (Node Nothing []) = False
      g _ = True
    x'' = condenseHomo contractGlue x'
    contractGlue :: HomoM r -> HomoM r
    contractGlue (Node r chs) = Node r $ map contractGlue chs'
     where
      chs' = map contractNothing1 chs
      contractNothing1 (Node Nothing [ch@(Node _ chs)]) = ch
      contractNothing1 v = v

  -- | As per 'filterHomoMM', but we string along the 'Dynamic' component.
  filterBiMM :: BiM r -> BiM r
--filterBiMM :: Show r => BiM r -> BiM r
  filterBiMM x = x''
   where
    x' = condenseBi defuzz x
    -- XXX Surely can do bottom-up and avoid iterating?
    defuzz :: BiM r -> BiM r
    defuzz (Node v chs) = Node v $ map defuzz chs'
     where
      chs' = filter g chs
      g (Node (_,Nothing) []) = False
      g _ = True
    x'' = condenseBi contractGlue x'
    contractGlue :: BiM r -> BiM r
    contractGlue (Node r chs) = Node r $ map contractGlue chs'
     where
      chs' = map contractNothing1 chs
      contractNothing1 (Node (_,Nothing) [ch@(Node _ chs)]) = ch
      contractNothing1 v = v

-------------------------------------------------------------------------------

  -- | Takes a generic query (create this with mkQP), and a value,
  -- and produce the forest of trees comprised by Just nodes.
  -- (Refer to 'filterHomoM_' for more details.)
  gfilter :: forall r d. Data d =>
                (forall d. (Data d, Typeable d) => d -> Maybe r)
             -> d
             -> [Homo r]
  gfilter fmk x = filterHomoM_ $ ghom fmk x

  -- | Analogous to 'gfilter', but takes a default value in @r@ and
  -- returns a single tree (instead of a forest).  Uses 'filterHomoM_''.
  gfilter_ ::
              forall r d. Data d =>
                 r
              -> (forall d. (Data d, Typeable d) => d -> Maybe r)
              -> d
              -> Homo r
  gfilter_ rdflt fmk x =
                    ( filterHomoM_' rdflt
                  $ ghom fmk x ) :: Homo r

-------------------------------------------------------------------------------

  -- | Would like to be able to call this automatically from gfilter,
  -- but I think the user code must call it, and pass the result
  -- to gfilter...
#if 0
#elif 0
  -- nope (compiles, but get type errors when try to use)
  mkQP :: forall r a. Typeable a =>
             (r -> Bool)
          -> (a -> Maybe r)
          -> a
          -> Maybe r
#elif 0
  -- nope
  mkQP :: forall r a. Typeable a =>
             (r -> Bool)
          -> (forall b. Typeable b => b -> Maybe r)
          -> a
          -> Maybe r
#elif 0
  -- nope
  mkQP :: forall r t. ( Typeable t
--                    , Eq r
                      )
      =>
         (r -> Bool)
      -> (forall u. Typeable u => u -> Maybe r)
      -> t
      -> Maybe r
#elif 1
  -- This one works.
  -- You don't need the quantification, if you drop the explicit
  -- expression sig (:: Maybe b) in the function definition.
  mkQP :: forall r a b.
          ( Typeable a
          , Typeable b
--        , Eq r
          )
    =>
       (r -> Bool)
--     (forall c. Data c => c -> Bool)
    -> (b -> Maybe r)
--  -> (b -> r)
    -> a
    -> Maybe r
#endif
  mkQP p br a = case cast a :: Maybe b of
                  Just b  -> let brb = br b in
                             if isNothing brb
                               then Nothing
                               else if p (fromJust brb)
                                      then brb
                                      else Nothing
                  Nothing -> Nothing

-------------------------------------------------------------------------------