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

  {-  LANGUAGE CPP #-}

#define DO_TRACE 0

-- XXX Note: Show constraints are for debugging purposes.
#define INCLUDE_SHOW_INSTANCES 0

-- Formerly DEBUG_WITH_DEEPSEQ_GENERICS.
-- Now also needed to force issuance of all compilePat warnings
-- (so not strictly a debugging flag anymore).
-- [Except it didn't work...]
--- #define NFDATA_INSTANCE_PATTERN 1  -- now it's a .cabal flag

-- Now specified via --flag=[-]USE_WWW_DEEPSEQ
--- #define USE_WW_DEEPSEQ 1

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

  -- For tracing only:
  {-  LANGUAGE BangPatterns #-}

  {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

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

-- |
-- Module      :  Control.DeepSeq.Bounded.NFDataP
-- Copyright   :  (c) 2014, Andrew G. Seniuk
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- This module provides an overloaded function, 'deepseqp', for partially
-- (or fully) evaluating data structures to bounded depth via pattern
-- matching on term shape, and on class, type, and constructor names.
--
-- There are two ways to use this API.
--
--  (1) You can use the 'PatNode' constructors directly.
--
--  (2) You can compile your patterns from strings in a concise
--      embedded language.
--
-- There's no difference in expressive power, but use of the DSL
-- is recommended, because the embedded 'Pattern' compiler can catch
-- some errors that GHC cannot (using 'PatNode' constructors explicitly).
-- Also, the pattern strings are easier to read and write.
--
-- __Motivation__
--
-- A typical use is to ensure any exceptions hidden within lazy
-- fields of a data structure do not leak outside the scope of the
-- exception handler; another is to force evaluation of a data structure in
-- one thread, before passing it to another thread (preventing work moving
-- to the wrong threads). Unlike "DeepSeq", potentially infinite coinductive
-- data types are supported by principled bounding of deep evaluation.
--
-- It is also useful for diagnostic purposes when trying to understand
-- and manipulate space\/time trade-offs in lazy code,
-- and as an optimal substitute for 'deepseq'
-- (where \"optimal\" doesn't include changing the code to remove
-- the need for artificial forcing!).
--
-- 'deepseqp' with optimal patterns is usually a better solution
-- even than stict fields in your data structures, because the
-- latter will behave strictly everywhere the constructors
-- are used, instead of just where its laziness is problematic.
--
-- There may be possible applications to the prevention of resource leaks
-- in lazy streaming, but I'm not certain.
--
-- __Semantics__
--
-- (For additional details, see "Control.DeepSeq.Bounded.Pattern".)
--
-- 'deepseqp' and friends artifically force evaluation of a term
-- so long as the pattern matches.
--
-- A mismatch occurs at a pattern node when the corresponding constructor node either:
--
--  * has arity different than the number of subpatterns (only when subpatterns given)
--
--  * has class\/type\/name not named in the constraint (only when constraint given)
--
-- A mismatch will cause evaluation down that branch to stop, but any
-- upstream matching/forcing will continue uninterrupted.
-- Note that patterns may extend beyond the values they match against,
-- without incurring any mismatch. This semantics is not the only
-- possible, but bear in mind that order of evaluation is nondeterministic,
-- barring further measures.
--
-- See also "NFDataPDyn" for another approach, which dynamically
-- generates forcing patterns, and can depend on value info
-- (in addition to type info).
--

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

  module Control.DeepSeq.Bounded.NFDataP

  (

     -- * Pattern-bounded analogues of 'deepseq' and 'force'

       deepseqp, forcep    -- take String arg (pattern DSL)

     -- * Avoid DSL compilation overhead
     --
     -- However, we don't anticipate that this overhead would be
     -- significant in most applications, because using <deepseq-bounded>
     -- in a tight loop would only be done for diagnostic purposes.

     , deepseqp_, forcep_  -- take Pattern structure arg

#if 0
       -- Don't bother, really.
     , deepseqpM, forcepM  -- return lifted argument so can cope with bottom
     , deepseqpM_, forcepM_
#endif

     -- * Related modules re-exported

     , module Control.DeepSeq.Bounded.Pattern
     , module Control.DeepSeq.Bounded.PatAlg  -- actually exports former

     -- * Class of things that can be evaluated over an arbitrary finite pattern

     , NFDataP(..)

  )

  where

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

  import Control.DeepSeq.Bounded.Pattern
  import Control.DeepSeq.Bounded.PatAlg ( unionPats, liftPats )

  import Control.DeepSeq.Bounded.NFDataN  -- finally used ("*3" etc.)

#if USE_WW_DEEPSEQ
  import Control.DeepSeq ( NFData )
  import Control.DeepSeq ( rnf )
#endif

--import Data.Data  -- "redundant" last checked

  import Data.Typeable ( Typeable )
#if 1
  import Data.Typeable ( typeOf )
#else
-- XXX These are NOT interchangeable!
#if __GLASGOW_HASKELL__ >= 781
  import Data.Typeable ( typeRep )
#else
  import Data.Typeable ( typeOf )
#endif
#endif
  import Data.Typeable ( mkTyCon3, mkTyConApp )
  import Data.Typeable ( typeRepTyCon )

#if PARALLELISM_EXPERIMENT
  import Control.Parallel ( par )
#endif

  import Data.Int
  import Data.Word
  import Data.Ratio
  import Data.Complex
  import Data.Array
  import Data.Fixed
  import Data.Version

  import Data.Maybe ( Maybe(..), isJust, fromJust )

  import System.IO.Unsafe ( unsafePerformIO )

  import Debug.Trace ( trace )

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

#if DO_TRACE
  mytrace = trace
#else
  mytrace _ = id
#endif

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

--infixr 0 $!!

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

-- XXX NOTE: These need to return Maybe __, in order to handle
-- patterns rooted at a WI (i.e. "#" or equivalent "#{...}").
-- Since don't want to do that by default, will simply make
-- it a DSL compilePat error...

-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
  -- | 'deepseqp': evaluates the first argument to the depth specified
  -- by a 'Pattern', before returning the second.
  --
  -- Quoting from the DeepSeq.hs (deepseq package):
  --
  -- / \"'deepseq' can be useful for forcing pending exceptions, eradicating space leaks, or forcing lazy I\/O to happen.  It is also useful in conjunction with parallel Strategies (see the @parallel@ package). /
  --
  -- / There is no guarantee about the ordering of evaluation.  The implementation may evaluate the components of the structure in any order or in parallel.  To impose an actual order on evaluation, use 'pseq' from "Control.Parallel" in the @parallel@ package.\" /
  --
  -- Composition fuses (see 'deepseqp_').
{--} -- XXX LATER: This is flawed for # at root of pattern.
#if INCLUDE_SHOW_INSTANCES
  deepseqp :: (Show a, NFDataP a) => String -> a -> b -> b
#else
  deepseqp :: NFDataP a => String -> a -> b -> b
#endif
#if 0
#elif 0
  deepseqp patstr a b = fromJust $ deepseqp_ (compilePat patstr) a b
--deepseqp patstr = fromJust $ deepseqp_ (compilePat patstr)
#elif 1
  deepseqp patstr = deepseqp_ (compilePat patstr)
#elif 0
  deepseqp patstr a b = rnfp (compilePat patstr) a `seq` b
  -- XXX Partially-applied; is that okay in GHC RULES?
  {-# RULES
    "deepseqp/composition"    forall p1 p2 x.  (.) (deepseqp p2) (deepseqp p1) x = deepseqp_ ( unionPats [compilePat p1, compilePat p2] ) x
      #-}
#endif

  -- | Self-composition fuses via
  --
  -- @
  --     "deepseqp_/composition"
  --        forall p1 p2 x1 x2.
  --            (.) ('deepseqp_' p2 x2) ('deepseqp_' p1 x1)
  --          = 'deepseqp_' ( 'liftPats' [p1, p2] ) (x1,x2)
  -- @
  --
  -- (Other fusion rules, not yet documented, may also be in effect.)
{--}
  -- XXX Oh! We have a fundamental problem here!
  -- I realised that
  --   forcep "#" (undefined::Int)
  -- was bottoming out. Then sought to repair that by "doing nothing"
  -- if WI etc. here, as in rnfp.
  -- However, how can we return type b, and "do nothing"?
  --  - if go "`seq` b" does this not force b?
  --    (don't see why it should actually)
  --  - if go "`seq` ()", this is a type error for deepseqp
  --  - if go "`seq` (undefined::b)", this defeats the purpose, as we
  --    precisely do not want to hit bottom... still, this might be
  --    a possible way, if can do it right....
  --  - if go "`seq` defaultValue_in_type_b" -- this is never acceptable
  --    in library code...
  --  - we CAN return Maybe b! This is, after all, deepseqp_
  --    Can decide how to cope with that in the caller.
  --    But at least the need to return type b here is lifted...
  -- As for the RULES, I think they're not ready to use now...
-- XXX LATER: This is flawed for # at root of pattern.
-- Maybe not quite flawed, just "untestable" if there's bottom at
-- the root of the value (that is to say, the value is (undefined::b).
#if INCLUDE_SHOW_INSTANCES
  deepseqp_ :: (Show a, NFDataP a) => Pattern -> a -> b -> b
#else
  deepseqp_ :: NFDataP a => Pattern -> a -> b -> b
#endif
#if 0
#elif 0
  deepseqp_ pat@(Node WI _) _ b = b
  deepseqp_ pat@(Node (TR treps) chs) a b = if elem ta treps then doit `seq` b else b
   where ta = show $ typeRepTyCon $ typeOf a
         doit = rnfp pat a `seq` b
  deepseqp_ pat@(Node (TI treps) chs) a b = if elem ta treps then b else doit `seq` b
   where ta = show $ typeRepTyCon $ typeOf a
         doit = rnfp pat a `seq` b
  deepseqp_ pat a b = rnfp pat a `seq` b
#elif 1
  deepseqp_ pat a b = rnfp pat a `seq` b
  -- XXX Need to double-check that this makes sense; didn't think
  -- it through -- when b != a, things are not so simple.
  -- XXX Partially-applied; is that okay in GHC RULES?
  {-# RULES
    "deepseqp_/composition"    forall p1 p2 x1 x2.  (.) (deepseqp_ p2 x2) (deepseqp_ p1 x1) = deepseqp_ ( liftPats [p1, p2] ) (x1,x2)
      #-}
--  "deepseqp_/composition"    forall p1 p2 x.  (.) (deepseqp_ p2) (deepseqp_ p1) x = deepseqp_ ( unionPats [p1, p2] ) x
#endif

  -- | Lifted result, so can cope with undefined values and
  -- still take the head in the caller (if call is after 'seq' or '$!'
  -- for instance).
#if INCLUDE_SHOW_INSTANCES
  deepseqpM :: (Show a, NFDataP a) => String -> a -> b -> Maybe b
#else
  deepseqpM :: NFDataP a => String -> a -> b -> Maybe b
#endif
  deepseqpM patstr a b = deepseqpM_ (compilePat patstr) a b
#if INCLUDE_SHOW_INSTANCES
  deepseqpM_ :: (Show a, NFDataP a) => Pattern -> a -> b -> Maybe b
#else
  deepseqpM_ :: NFDataP a => Pattern -> a -> b -> Maybe b
#endif
  deepseqpM_ pat@(Node WI _) _ _ = Nothing
  deepseqpM_ pat@(Node (TR treps) chs) a b = if elem ta treps then doit `seq` Just b else Nothing
   where ta = show $ typeRepTyCon $ typeOf a
         doit = rnfp pat a `seq` b
  deepseqpM_ pat@(Node (TI treps) chs) a b = if elem ta treps then Nothing else doit `seq` Just b
   where ta = show $ typeRepTyCon $ typeOf a
         doit = rnfp pat a `seq` b
  deepseqpM_ pat a b = rnfp pat a `seq` Just b

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

#if 0
  -- | the deep analogue of '$!'.  In the expression @f $!! x@, @x@ is
  -- fully evaluated before the function @f@ is applied to it.
  ($!!) :: (NFData a) => (a -> b) -> a -> b
  f $!! x = x `deepseq` f x
#endif

  -- | a variant of 'deepseqp' that is sometimes convenient:
  --
  -- > forcep pat x = x `deepseqp pat` x
  --
  -- @forcep pat x@ evaluates @x@ to the depth determined by @pat@, and
  -- then returns @x@.  Note that @forcep pat x@ only takes effect
  -- when the value of @forcep pat x@ itself is demanded, so essentially
  -- it turns shallow evaluation into evaluation to arbitrary bounded depth.
  --
  -- Composition fuses (see 'forcep_').
{--}
-- XXX What about mixed cases??...
-- XXX LATER: This is flawed for # at root of pattern.
#if INCLUDE_SHOW_INSTANCES
  forcep :: (Show a, NFDataP a) => String -> a -> a
#else
  forcep :: NFDataP a => String -> a -> a
#endif
#if 0
#elif 0
  forcep patstr x
   | p          = fromJust ma
-- | otherwise  = error "here"
   | otherwise  = undefined::a
   where ma = deepseqp_ (compilePat patstr) x x
         p = isJust ma
#elif 0
  forcep patstr x = fromJust $ deepseqp_ (compilePat patstr) x x
#elif 0
  forcep patstr x
   | b          = x
   | otherwise  = fromJust y
   where y = deepseqp_ (compilePat patstr) x (Just x)
         pat@(Node p chs) = compilePat patstr
         b | WI <- p      = True
           | TR _ <- p    = True
           | TN _ _ <- p  = True
           | TW _ <- p    = True
           | TI _ <- p    = True
           | otherwise    = False
#elif 1
  forcep patstr x = deepseqp_ (compilePat patstr) x x
--forcep patstr x = deepseqp patstr x x
  {-# RULES
    "forcep/composition"    forall p1 p2 x.  (.) (forcep p2) (forcep p1) x = forcep_ ( unionPats [compilePat p1, compilePat p2] ) x
      #-}
#endif

  -- | Self-composition fuses via
  --
  -- @
  --     "forcep_/composition"
  --        forall p1 p2 x.
  --            (.) ('forcep_' p2) ('forcep_' p1) x
  --          = 'forcep_' ( 'unionPats' [p1, p2] ) x
  -- @
  --
  -- (Other fusion rules, not yet documented, may also be in effect.)
{--}
-- XXX LATER: This is flawed for # at root of pattern.
#if INCLUDE_SHOW_INSTANCES
  forcep_ :: (Show a, NFDataP a) => Pattern -> a -> a
#else
  forcep_ :: NFDataP a => Pattern -> a -> a
#endif
#if 0
  forcep_ pat x = fromJust $ deepseqp_ pat x x
#else
  forcep_ pat x = deepseqp_ pat x x
  {-# RULES
    "forcep_/composition"    forall p1 p2 x.  (.) (forcep_ p2) (forcep_ p1) x = forcep_ ( unionPats [p1, p2] ) x
      #-}
#endif

  -- | Lifted result, so can cope with undefined values and
  -- still take the head in the caller (if call is after 'seq' or '$!'
  -- for instance).
#if INCLUDE_SHOW_INSTANCES
  forcepM :: (Show a, NFDataP a) => String -> a ->  Maybe a
#else
  forcepM :: NFDataP a => String -> a ->  Maybe a
#endif
  forcepM patstr a = forcepM_ (compilePat patstr) a
#if INCLUDE_SHOW_INSTANCES
  forcepM_ :: (Show a, NFDataP a) => Pattern -> a -> Maybe a
#else
  forcepM_ :: NFDataP a => Pattern -> a -> Maybe a
#endif
  forcepM_ pat x = deepseqpM_ pat x x

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

  -- | A class of types that can be evaluated over an arbitrary finite pattern.
#if USE_WW_DEEPSEQ
  class (Typeable a, NFDataN a, NFData a) => NFDataP a where
#else
  class (Typeable a, NFDataN a) => NFDataP a where
#endif
    -- | Self-composition fuses via
    --
    -- @
    --     "rnfp/composition"
    --        forall p1 p2 x.
    --            (.) ('rnfp' p2) ('rnfp' p1) x
    --          = 'rnfp' ( 'unionPats' [p1, p2] ) x
    -- @
    --
    -- (Other fusion rules, not yet documented, may also be in effect.)
    {-  NOINLINE rnfp #-}
#if INCLUDE_SHOW_INSTANCES
    rnfp :: Show a => Pattern -> a -> ()
#else
    rnfp :: Pattern -> a -> ()
#endif
    rnfp (Node WI _) _ = ()
    rnfp (Node (TR treps) chs) d = if elem td treps then d `seq` () else ()
     where td = show $ typeRepTyCon $ typeOf d
    rnfp (Node (TI treps) chs) d = if elem td treps then () else d `seq` ()
     where td = show $ typeRepTyCon $ typeOf d
#if 1
    rnfp _ d = d `seq` ()
--  rnfp _ _ = ()
#else
    -- XXX temporarily (at least) commenting out; not making any
    -- use of patternShapeOK -- but there is room for more
    -- error-trapping code in here, definitely...
    rnfp pat a | not $ patternShapeOK pat a  = ()
               | otherwise  = rnf a
#endif

  {-# RULES
    "rnfp/composition"    forall p1 p2 x.  (.) (rnfp p2) (rnfp p1) x = rnfp ( unionPats [p1, p2] ) x
      #-}
--  "rnfp/composition"    forall p1 p2 x.  compose (rnfp p2) (rnfp p1) x = rnfp ( unionPats [p1, p2] ) x
--  "rnfp/composition"    forall p1 p2 x.  ( rnfp p2 . rnfp p1 ) x = rnfp ( unionPats [p1, p2] ) x

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

  -- It seems that people will tell you this should not
  -- be a class method; helper functions of class methods
  -- should not be inside the class?...
  -- I've just read in
  -- https://www.fpcomplete.com/user/thoughtpolice/using-reflection
  -- that there's an optimisation (which may also affect type issues)
  -- when a class has a single method only; so I moved rnfp' out of
  -- the NFDataP class finally (it was recommended to do so before,
  -- but I never understood why; now I at least had some reason).
  -- (It has not affected my type errors in this case though; no
  -- surprise as DeepSeqBounded/T02/t.hs shows it happening with
  -- a single-method class.)
#if USE_WW_DEEPSEQ
  rnfp' :: (Typeable a, NFDataN a, NFData a) => PatNode -> () -> a -> ()
#else
  rnfp' :: (Typeable a, NFDataN a) => PatNode -> () -> a -> ()
#endif
-- Sig. as it was as a class method of NFDataP:
--rnfp' :: PatNode -> () -> a -> ()
  rnfp' pat recurs d
   -- I can only conclude that we've already evaluated the argument
   -- by the time this code runs (or that we evaluate it after...).
   -- But this code doesn't do the dirty deed!
   = {-trace ( "rnfp' " ++ show pat) $-}
     let td = show $ typeRepTyCon $ typeOf d in  -- no problem on bottom
     case pat of
      WI -> error "rnfp: unexpected WI (please report this bug!)"
      TR treps -> error "rnfp: unexpected TR (please report this bug!)"
      TI treps -> error "rnfp: unexpected TI (please report this bug!)"
#if PARALLELISM_EXPERIMENT
      -- XXX will this work? ... YES IT SEEMS TO!!! (Esp. evident in ghci.)
      PR -> recurs `par` ()
      PN n -> rnfn n d `par` ()
#if USE_WW_DEEPSEQ
      PW -> rnf d `par` ()  -- the only place deepseq package is used
#endif
#endif
#ifdef SEQUENTIALISM_EXPERIMENT
#error Sorry, SEQUENTIALISM_EXPERIMENT is not done yet.
-- XXX Alas! This won't work, at least not according to the same method
-- as PR etc.  There's no possible use in the `pseq` () section!
-- (Unlike `par` (), which is already working for parallel speedup.)
-- So, SEQUENTIALISM_EXPERIMENT may be the one where we would need
-- to edit all the instances individually...  This again raises the
-- question of how we handle higher-arity nodes? It makes no sense
-- (unlike parallel) to pseq just one sibling. If you pseq a subset
-- of siblings, their subharnesses will be sequenced, yes (and the
-- remainder will be order-free).
--   Unfortunately, to express this is not easy (unlike for parallel).
-- So, this is on hold for the time being.
--    SR -> recurs `pseq` ()
#endif
      WR -> recurs
      WS -> ()
--      WS -> d `seq` ()
      WN n -> rnfn n d
#if USE_WW_DEEPSEQ
      WW -> rnf d  -- the only place deepseq package is used
#endif
      -- This code stays the same whether we (are able to) compare
      -- actual TypeRep's for equality, or we just hack it
      -- and match:  show . typeRepTyCon . typeOf
      TR treps ->  if       elem td treps then recurs else ()
#if 0
      -- This is not right. To pull this off (b/c it depends on
      -- types in the value your matching with), need to construct
      -- the pattern dynamically.  In particular, to produce Nil
      -- where a TR (or TS) constraint causes (or would cause)
      -- match failure.
      TS treps ->  if       elem td treps then () else ()
#endif
      TN n treps ->  if       elem td treps then rnfn n d else ()
#if USE_WW_DEEPSEQ
      TW treps ->  if       elem td treps then rnf d else ()
#endif
#if 0
      NTR treps -> if not $ elem td treps then recurs else ()
      NTN n treps -> if not $ elem td treps then rnfn n d else ()
#if USE_WW_DEEPSEQ
      NTW treps -> if not $ elem td treps then rnf d else ()
#endif
#endif
      _ -> error "rnfp: Unexpected constructor!"

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

#if 0
  compose = (.)
  {-# NOINLINE compose #-}
  -- Can't do this, unfortunately.  GHC warns it may get inlined before
  -- rules have a chance to fire.  I would rather avoid forcing the API
  -- user to use some custom "compose" function, since base (.) works
  -- perfectly, except it's hard to control its inlining...
  {-  NOINLINE (.) #-}
#endif

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

  instance NFDataP Int
  instance NFDataP Word
  instance NFDataP Integer
  instance NFDataP Float
  instance NFDataP Double

  instance NFDataP Char
#if 0
-- (testing something or other)
  instance NFDataP Bool
   where
    rnfp (Node WI _) _ = ()
    rnfp _ d = d `seq` ()
#else
  instance NFDataP Bool
#endif
  instance NFDataP ()

  instance NFDataP Int8
  instance NFDataP Int16
  instance NFDataP Int32
  instance NFDataP Int64

  instance NFDataP Word8
  instance NFDataP Word16
  instance NFDataP Word32
  instance NFDataP Word64

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

  instance Typeable a => NFDataP (Fixed a)
--instance NFDataP (Fixed a)

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

  -- [Quoted from deepseq:]
  -- This instance is for convenience and consistency with 'seq'.
  -- This assumes that WHNF is equivalent to NF for functions.
  instance (Typeable a, Typeable b) => NFDataP (a -> b)
--instance NFDataP (a -> b)

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

#if 0

-- XXX ignore if in IO (cludge easing an experiment...)

#if USE_WW_DEEPSEQ
  instance NFData a => NFData (IO a) where
    rnf x = ()  -- XXX ignore if in IO (cludge easing an experiment...)
#endif

  instance NFDataP a => NFDataP (IO a) where
    rnfp pat x = ()  -- XXX ignore if in IO (cludge easing an experiment...)

#endif

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

--Rational and complex numbers.

-- not taken to be a level of depth
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Integral a, NFDataP a) => NFDataP (Ratio a) where
#else
  instance (Integral a, NFDataP a) => NFDataP (Ratio a) where
#endif
    -- XXX This is very dubious!...
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp pat x = rnfp pat (numerator x, denominator x)

  -- Note that (Complex a) constructor (:+) has strict fields,
  -- so unwrapping the ctor also forces both components.
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, RealFloat a, NFDataP a) => NFDataP (Complex a) where
#else
  instance (RealFloat a, NFDataP a) => NFDataP (Complex a) where
#endif
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) d
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        2 -> let [px,py] = chs ; (x:+y) = d
             in       rnfp px x
                `seq` rnfp py y
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(Complex a)" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d  -- unreachable

-- XXX Never until now (so much later) did I properly consider how to
-- handle a no-arg (nullary) constructor! It's not hard, but it's
-- significantly different than the other cases, as there's no
-- subvalue we can grab hold of -- there's no "d"; so this invalidates
-- all the code, in the posary (complement of nullary, coinage :) case
-- case, which references d.
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, NFDataP a) => NFDataP (Maybe a) where
#else
  instance NFDataP a => NFDataP (Maybe a) where
#endif
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) Nothing
     | not $ null chs   = pat_match_fail
     | otherwise        = ()
     where
      pat_match_fail = patMatchFail' "Nothing" pat chs ()
    rnfp (Node pat chs) (Just d)
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        1 -> let [p_J] = chs
             in       rnfp p_J d
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "Just" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d  -- unreachable

#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Show b, NFDataP a, NFDataP b) => NFDataP (Either a b) where
#else
  instance (NFDataP a, NFDataP b) => NFDataP (Either a b) where
#endif
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) (Left d)
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        1 -> let [p_L] = chs ;
             in       rnfp p_L d
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "Left" pat chs d
--    pat_match_fail = patMatchFail' "(Either a b)" pat chs d
    rnfp (Node pat chs) (Right d)
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        1 -> let [p_R] = chs
             in       rnfp p_R d
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "Right" pat chs d
--    pat_match_fail = patMatchFail' "(Either a b)" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d  -- unreachable

--- #if __GLASGOW_HASKELL__ < 781
--- -- requires -XStandaloneDeriving
--- -- orphan instance, but better than dropping support
--- -- (It seems it already has its Show instance!)
--- deriving instance Data Data.Version.Version
--- #endif

--deriving instance Data TypeRep  -- can't b/c not all data ctors are in scope!

  -- Data.Version ctor does /not/ have strict fields.
  instance NFDataP Data.Version.Version where
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) d
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        2 -> let [pbr,ptags] = chs ; Data.Version.Version branch tags = d
             in       rnfp pbr branch
                `seq` rnfp ptags tags
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "Data.Version.Version" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d  -- unreachable

  -- Data.List ctors do /not/ have strict fields (i.e. (:) is not strict).
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, NFDataP a) => NFDataP [a] where
#else
  instance NFDataP a => NFDataP [a] where
#endif
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp _ [] = ()  -- perhaps dubious?...
    rnfp (Node pat chs) d
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        2 -> let [px,pxs] = chs ; (x:xs) = d
             in       rnfp px x
                `seq` rnfp pxs xs
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "[a]" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d  -- unreachable

  -- Data.Array ctor does /not/ have strict fields.
  -- not taken to be a level of depth
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Show b, Ix a, NFDataP a, NFDataP b) => NFDataP (Array a b) where
#else
  instance (Ix a, NFDataP a, NFDataP b) => NFDataP (Array a b) where
#endif
    -- XXX This is very dubious!...
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp pat x =        rnfp pat (bounds x, Data.Array.elems x)
                  `seq` ()  -- needed?

#if INCLUDE_SHOW_INSTANCES
  instance (Show a,Typeable a,NFDataP a, Show b,Typeable b,NFDataP b) => NFDataP (a,b) where
#else
  instance (Typeable a,NFDataP a, Typeable b,NFDataP b) => NFDataP (a,b) where
#endif
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) d
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        2 -> let [px,py] = chs ; (x,y) = d
             in       rnfp px x
                `seq` rnfp py y
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,)" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d  -- unreachable

#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c) => NFDataP (a,b,c) where
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c) => NFDataP (a,b,c) where
#endif
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) d
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        3 -> {-trace "WWW" $-} let [px,py,pz] = chs ; (x,y,z) = d
             in       ({-trace "XXX" $-} rnfp px x)
                `seq` ({-trace "YYY" $-} rnfp py y)
-- This WILL change the semantics unfortunately...
--              `seq` (trace ("YYY "++show py++" "++show y) $ rnfp py y)
                `seq` ({-trace "ZZZ" $-} rnfp pz z)
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,)" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d  -- unreachable

#if INCLUDE_SHOW_INSTANCES
  instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c, Show d, Typeable d, NFDataP d) => NFDataP (a,b,c,d) where
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d) => NFDataP (a,b,c,d) where
#endif
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) d
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        4 -> let [px1,px2,px3,px4] = chs ; (x1,x2,x3,x4) = d
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,)" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d

#if INCLUDE_SHOW_INSTANCES
  instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5) =>
#else
  instance (Typeable a1, NFDataP a1, Typeable a2, NFDataP a2, Typeable a3, NFDataP a3, Typeable a4, NFDataP a4, Typeable a5, NFDataP a5) =>
#endif
         NFDataP (a1, a2, a3, a4, a5) where
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) d
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        5 -> let [px1,px2,px3,px4,px5] = chs ; (x1,x2,x3,x4,x5) = d
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` rnfp px5 x5
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,)" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d

#if INCLUDE_SHOW_INSTANCES
  instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5, Show a6, Typeable a6, NFDataP a6) =>
#else
  instance (Typeable a1, NFDataP a1, Typeable a2, NFDataP a2, Typeable a3, NFDataP a3, Typeable a4, NFDataP a4, Typeable a5, NFDataP a5, Typeable a6, NFDataP a6) =>
#endif
         NFDataP (a1, a2, a3, a4, a5, a6) where
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) d
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        6 -> let [px1,px2,px3,px4,px5,px6] = chs ; (x1,x2,x3,x4,x5,x6) = d
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` rnfp px5 x5
                `seq` rnfp px6 x6
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,,)" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d

#if INCLUDE_SHOW_INSTANCES
  instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5, Show a6, Typeable a6, NFDataP a6, Show a7, Typeable a7, NFDataP a7) =>
#else
  instance (Typeable a1, NFDataP a1, Typeable a2, NFDataP a2, Typeable a3, NFDataP a3, Typeable a4, NFDataP a4, Typeable a5, NFDataP a5, Typeable a6, NFDataP a6, Typeable a7, NFDataP a7) =>
#endif
         NFDataP (a1, a2, a3, a4, a5, a6, a7) where
    {-  NOINLINE rnfp #-}
    rnfp (Node WI _) _ = ()
    rnfp (Node pat chs) d
     | TR treps <- pat  = if elem td treps then recurs else ()
     | TI treps <- pat  = if elem td treps then () else recurs
     | otherwise        = rnfp' pat recurs d
     where
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pat of
              WS -> ()
              _ -> pat_match_fail
        7 -> let [px1,px2,px3,px4,px5,px6,px7] = chs ; (x1,x2,x3,x4,x5,x6,x7) = d
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` rnfp px5 x5
                `seq` rnfp px6 x6
                `seq` rnfp px7 x7
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,,,)" pat chs d
    rnfp (Node pat chs) d = patMatchFail pat chs d

-- No Typeable instances for tuples larger than 7 in 7.8.1, seemingly.
#if 0
  instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5, Show a6, Typeable a6, NFDataP a6, Show a7, Typeable a7, NFDataP a7, Show a8, Typeable a8, NFDataP a8) =>
         NFDataP (a1, a2, a3, a4, a5, a6, a7, a8) where
    rnfp Nil _ = ()
    rnfp (Node pat [px1,px2,px3,px4,px5,px6,px7,px8]) d@(x1,x2,x3,x4,x5,x6,x7,x8) = rnfp' pat recurs d
     where recurs =       rnfp px1 x1
                    `seq` rnfp px2 x2
                    `seq` rnfp px3 x3
                    `seq` rnfp px4 x4
                    `seq` rnfp px5 x5
                    `seq` rnfp px6 x6
                    `seq` rnfp px7 x7
                    `seq` rnfp px8 x8
    rnfp (Node pat chs) d = patMatchFail pat chs d

  instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5, Show a6, Typeable a6, NFDataP a6, Show a7, Typeable a7, NFDataP a7, Show a8, Typeable a8, NFDataP a8, Show a9, Typeable a9, NFDataP a9) =>
         NFDataP (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
    rnfp Nil _ = ()
    rnfp (Node pat [px1,px2,px3,px4,px5,px6,px7,px8,px9]) d@(x1,x2,x3,x4,x5,x6,x7,x8,x9) = rnfp' pat recurs d
     where recurs =       rnfp px1 x1
                    `seq` rnfp px2 x2
                    `seq` rnfp px3 x3
                    `seq` rnfp px4 x4
                    `seq` rnfp px5 x5
                    `seq` rnfp px6 x6
                    `seq` rnfp px7 x7
                    `seq` rnfp px8 x8
                    `seq` rnfp px9 x9
    rnfp (Node pat chs) d = patMatchFail pat chs d
#endif

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

  patMatchFail :: (Show a, Show b) => a -> b -> c -> ()
  patMatchFail pat chs d
#if WARN_PATTERN_MATCH_FAILURE
   = ( unsafePerformIO $! putStrLn $! "NFDataP: warning: couldn't match " ++ show pat ++ " (having children " ++ show chs ++ ")" ) `seq` ()
#else
   = ()
#endif
-- = error $ "NFDataP: Couldn't match " ++ show pat ++ " (having children " ++ show chs ++ ")\nwith data " ++ show d

  patMatchFail' :: (Show a, Show b) => String -> a -> b -> c -> ()
  patMatchFail' inst pat chs d
#if WARN_PATTERN_MATCH_FAILURE
   = ( unsafePerformIO $! putStrLn $! "NFDataP: warning: instance " ++ inst ++ ": bad PatNode child list" ) `seq` patMatchFail pat chs d
#else
   = ()
#endif

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