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

  {-  LANGUAGE CPP #-}

#define DO_TRACE 0

#define HANDLE_ATTRS_DATA_CONSTRAINT 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

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

  -- Used to create a custom Exception instance -- needed?
  -- I know we are no longer allowed to write our own instance?
  -- I thought Exceptions were in Haskell 98?...
  {-# LANGUAGE DeriveDataTypeable #-}

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

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

#if ! HASKELL98_FRAGMENT
  {-# LANGUAGE ScopedTypeVariables #-}
  {-  LANGUAGE RankNTypes #-}
  {-# LANGUAGE ConstraintKinds #-}
#endif

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

-- |
-- Module      :  Control.DeepSeq.Bounded.NFDataP
-- Copyright   :  Andrew G. Seniuk 2014-2015
-- 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.
--
-- With some qualifications (concerning 'WI' nodes, and 'PatNodeAttrs'
-- configuration), composition fuses, and what's more, it's commutative...
--
-- __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 <http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html DeepSeq>, potentially infinite values of 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.
-- / (This behaviour can now be changed with 'PatNodeAttrs', available since 0.6.) /
--
-- 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.
-- / (This behaviour can also now be changed with 'PatNodeAttrs'.) /
--
-- See also <http://hackage.haskell.org/package/deepseq-bounded-0.8.0.0/docs/Control-DeepSeq-Bounded-NFDataPDyn.html NFDataPDyn> for another approach, which dynamically
-- generates forcing patterns, and can depend on value info
-- (in addition to type info).
-- / (These dynamic aspects never received the attention I intended to give them, I got so caught up in seqaid, which offers similar features. Hopefully actual use of these tools in the near future will give me some perspective on whether/
-- <http://hackage.haskell.org/package/deepseq-bounded-0.8.0.0/docs/Control-DeepSeq-Bounded-NFDataPDyn.html NFDataPDyn> /should get attention.) /
--

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

  module Control.DeepSeq.Bounded.NFDataP
  (

#if OVERLOADED_STRINGS

       deepseqp, forcep    -- take Pattern arg or String **literal**
     , deepseqp_, forcep_  -- aliases to the aforegoing (for compatability)

#else

     -- * 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

#endif

     -- * A custom exception, raised by choice 'PatNode's, that can be caught in the caller

#if USE_PING_PATNODE
     , DeepSeqBounded_PingException(..)
#endif

     -- * Related modules re-exported

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

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

     , NFDataP(..)

     -- * Shared with GNFDataP (internal use)

     , handleAttrs  -- used by GNFDataP at least

  )
  where

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

  import Control.DeepSeq.Bounded.Pattern
  import Control.DeepSeq.Bounded.Compile
  import Control.DeepSeq.Bounded.PatUtil ( unionPats, liftPats )

-- debugging...
#if 1
  import Control.DeepSeq.Bounded.PatUtil (
             probDensRose
           , weightedRose
           , unzipRose
           , showRose
#if ! HASKELL98_FRAGMENT
           , Shape
           , shapeOf
           , ghom
#endif
         )
#endif

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

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

#if HANDLE_ATTRS_DATA_CONSTRAINT
  -- Brought back only to add Data d constraint to handleAttrs, which
  -- is a hack so can print something distinct for multiple +-nodes...
  import Data.Data
#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 USE_PAR_PATNODE
  import Control.Parallel ( par )
#endif
#if USE_PSEQ_PATNODE
  import Control.Parallel ( pseq )
#endif
#if USE_PING_PATNODE
  import Control.Concurrent ( myThreadId, killThread )
  import Control.Concurrent ( forkIO )
#endif

  import Control.Concurrent ( threadDelay )

  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, isNothing )

  import Control.Exception ( Exception )
  import Control.Exception ( asyncExceptionFromException )
  import Control.Exception ( throwTo )
  import Control.Exception ( throw )
  import Control.Exception( AsyncException( UserInterrupt ) )

  import Control.Monad ( liftM )

  -- XXX unsafePerformIO *is* used [besides indirectly with trace and throwTo].
  -- Grep the source on a case by case basis...
  import System.IO.Unsafe ( unsafeInterleaveIO )
  import System.IO.Unsafe ( unsafeDupablePerformIO )
  import System.IO.Unsafe ( unsafePerformIO )
  import Control.Exception ( evaluate )

  import System.Random ( randomIO )

  import Debug.Trace ( trace )

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

#if USE_PING_PATNODE
  data DeepSeqBounded_PingException = DeepSeqBounded_PingException String
    deriving (Show, Typeable)

  instance Exception DeepSeqBounded_PingException
#endif

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

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

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

--infixr 0 $!!

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

#if OVERLOADED_STRINGS

  {-# DEPRECATED deepseqp_, forcep_ "OverloadedStrings is in effect for pattern strings (since 0.8), so you can use deepseqp and forcep with either a Pattern or a String literal as first argument. To work with String variables, write your own wrapper function calling compilePat (or build with OVERLOEADED_STRINGS flag False). These underscore versions will be removed in 0.9 (mere days from now...)." #-}
  -- For compatibility with prior, non-OVERLOADED_STRINGS API.
  -- I can actually upload this without a major version bump,
  -- even though it very much has the feel of one.  That's
  -- extension magic for ya!
  ------
  -- It seems the signatures are needed, unfortunately.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  deepseqp_ :: NFDataP_ictx a => Pattern -> a -> b -> b
--deepseqp_ :: NFDataP_cctx a => Pattern -> a -> b -> b
#else
#if INCLUDE_SHOW_INSTANCES
  deepseqp_ :: (Show a, NFDataP a) => Pattern -> a -> b -> b
#else
  deepseqp_ :: NFDataP a => Pattern -> a -> b -> b
#endif
#endif
  deepseqp_ = deepseqp
  -- | 'deepseqp_' and 'forcep_' are merely aliases to the
  -- non-underscored functions.  They are vestigial and
  -- retained for compatibility until the next major
  -- version bump.  Then it seems safe to remove them,
  -- since can always build with @OVERLOADED_STRINGS@ flag
  -- set @False@ if their absence is a problem (or define
  -- the aliases yourself). So, DEPRECATED, and slated
  -- for removal in 0.8.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  forcep_ :: NFDataP_ictx a => Pattern -> a -> a
--forcep_ :: NFDataP_cctx a => Pattern -> a -> a
#else
#if INCLUDE_SHOW_INSTANCES
  forcep_ :: (Show a, NFDataP a) => Pattern -> a -> a
#else
  forcep_ :: NFDataP a => Pattern -> a -> a
#endif
#endif
  forcep_ = forcep

-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
  -- | 'deepseqp' evaluates the first argument to the extent specified
  -- by a 'Pattern', before returning the second.
  --
  -- Quoting from the <http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html DeepSeq> documentation (<http://hackage.haskell.org/package/deepseq deepseq> package):
  --
  -- \"<http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:deepseq 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/ <http://hackage.haskell.org/package/parallel parallel> /package). /
  --
  -- 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.)
{--}
  -- [No longer true, but discussing doPseq here is too much, so tacit.]
  -- / 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.\" /
{--}
-- 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 ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  deepseqp :: NFDataP_ictx a => Pattern -> a -> b -> b
--deepseqp :: NFDataP_cctx a => Pattern -> a -> b -> b
#else
#if INCLUDE_SHOW_INSTANCES
  deepseqp :: (Show a, NFDataP a) => Pattern -> a -> b -> b
#else
  deepseqp :: NFDataP a => Pattern -> a -> b -> b
#endif
#endif
  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

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

#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

-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
  -- | A variant of 'deepseqp' that is sometimes convenient:
  --
  -- > forcep pat x = deepseqp pat x x   -- (cannot write x `deepseqp pat` x by analogy with x `deepseq` x)
  --
  -- @forcep pat x@ evaluates @x@ to the depth determined by @pat@, and
  -- then returns @x@.  Again from
  -- <http://hackage.haskell.org/package/deepseq deepseq>:
  -- / \"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.\" /
  --
  -- 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 What about fusion of mixed applications?...
-- XXX LATER: This is "flawed" for # at root of pattern. (See deepseqp.)
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  forcep :: NFDataP_ictx a => Pattern -> a -> a
--forcep :: NFDataP_cctx a => Pattern -> a -> a
#else
#if INCLUDE_SHOW_INSTANCES
  forcep :: (Show a, NFDataP a) => Pattern -> a -> a
#else
  forcep :: NFDataP a => Pattern -> a -> a
#endif
#endif
  forcep pat x = deepseqp pat x x
  {-# RULES
    "forcep/composition"    forall p1 p2 x.  (.) (forcep p2) (forcep p1) x = forcep ( unionPats [p1, p2] ) x
      #-}

#else
-- else not OVERLOADED_STRINGS

-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
  -- | 'deepseqp' evaluates the first argument to the extent specified
  -- by a 'Pattern', before returning the second.
  --
  -- Quoting from the <http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html DeepSeq> documentation (<http://hackage.haskell.org/package/deepseq deepseq> package):
  --
  -- \"<http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:deepseq 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/ <http://hackage.haskell.org/package/parallel parallel> /package). /
  --
  -- Composition fuses (see 'deepseqp_').
{--}
  -- [No longer true, but discussing doPseq here is too much, so tacit.]
  -- / 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.\" /
{--}
  -- XXX LATER: This is "flawed" for # at root of pattern. (See deepseqp_.)
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  deepseqp :: NFDataP_ictx a => String -> a -> b -> b
--deepseqp :: NFDataP_cctx a => String -> a -> b -> b
#else
#if INCLUDE_SHOW_INSTANCES
  deepseqp :: (Show a, NFDataP a) => String -> a -> b -> b
#else
  deepseqp :: NFDataP a => String -> a -> b -> b
#endif
#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 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 ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  deepseqp_ :: NFDataP_ictx a => Pattern -> a -> b -> b
--deepseqp_ :: NFDataP_cctx a => Pattern -> a -> b -> b
#else
#if INCLUDE_SHOW_INSTANCES
  deepseqp_ :: (Show a, NFDataP a) => Pattern -> a -> b -> b
#else
  deepseqp_ :: NFDataP a => Pattern -> a -> b -> b
#endif
#endif
#if 0
#elif 0
  deepseqp_ pat@(Node WI _) _ b = b
  deepseqp_ pat@(Node (TR as) 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
         treps = typeConstraints as
  deepseqp_ pat@(Node (TI as) 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
         treps = typeConstraints as
  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

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

#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

-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
  -- | A variant of 'deepseqp' that is sometimes convenient:
  --
  -- > forcep pat x = deepseqp pat x x   -- (cannot write x `deepseqp pat` x by analogy with x `deepseq` x)
  --
  -- @forcep pat x@ evaluates @x@ to the depth determined by @pat@, and
  -- then returns @x@.  Again from
  -- <http://hackage.haskell.org/package/deepseq deepseq>:
  -- / \"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 fusion of mixed applications?...
-- XXX LATER: This is "flawed" for # at root of pattern. (See deepseqp_.)
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  forcep :: NFDataP_ictx a => String -> a -> a
--forcep :: NFDataP_cctx a => String -> a -> a
#else
#if INCLUDE_SHOW_INSTANCES
  forcep :: (Show a, NFDataP a) => String -> a -> a
#else
  forcep :: NFDataP a => String -> a -> a
#endif
#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 pas chs) = compilePat patstr
         b | WI <- pas  = True
           | TR <- pas  = True
           | TN <- pas  = True
           | TW <- pas  = True
           | TI <- pas  = 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. (See deepseqp_.)
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  forcep_ :: NFDataP_ictx a => Pattern -> a -> a
--forcep_ :: NFDataP_cctx a => Pattern -> a -> a
#else
#if INCLUDE_SHOW_INSTANCES
  forcep_ :: (Show a, NFDataP a) => Pattern -> a -> a
#else
  forcep_ :: NFDataP a => Pattern -> a -> a
#endif
#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

#endif
-- of if OVERLOADED_STRINGS else

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

#if ! HASKELL98_FRAGMENT
-- We don't need 7.10 for tuple predicates /here/, but when try to
-- use in seqaid, the TH splice complains
--   Can't represent tuple predicates in Template Haskell:
--     Control.DeepSeq.Bounded.NFDataP_new_grammar.NFDataP_cctx
-- That is with GHC 7.8.4.
-- So we need template-haskell-2.10, which means need base >= base-4.8.0.0,
-- which means need GHC >= 7.10.
#if __GLASGOW_HASKELL__ >= 710
  -- XXX Not H98! -XConstraintKinds
  type NFDataP_cctx a
        = (
              Typeable a
#if HANDLE_ATTRS_DATA_CONSTRAINT
            , Data a
#endif
            , NFDataN a
#if USE_WW_DEEPSEQ
            , NFData a
#endif
          )
#if 0
-- XXX Because TH < 2.10 cannot hand tuple predicates,
-- even if the corresponding GHC can!
-- And this didn't help anyway, still get the error
-- when TH runs in seqaid...
  type NFDataP_ictx a
        = (
              Typeable a
#if HANDLE_ATTRS_DATA_CONSTRAINT
            , Data a
#endif
            , NFDataN a
#if USE_WW_DEEPSEQ
            , NFData a
#endif
            , NFDataP a
#if INCLUDE_SHOW_INSTANCES
            , Show a
#endif
          )
#else
  type NFDataP_ictx a
        = (
              NFDataP_cctx a
            , NFDataP a
#if INCLUDE_SHOW_INSTANCES
            , Show a
#endif
          )
#endif
#endif
#endif

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

  -- | A class of types that can be evaluated over an arbitrary finite pattern.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  class NFDataP_cctx a => NFDataP a where
#else
  class (
          Typeable a
#if HANDLE_ATTRS_DATA_CONSTRAINT
        , Data a
#endif
        , NFDataN a
#if USE_WW_DEEPSEQ
        , NFData a
#endif
        ) => 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
#if 0
--  rnfp p x | p `seq` trace "Boo!" () `seq` p == Node XX []  = undefined  -- does NOT work
--  rnfp p x | trace "Boo!" p `seq` p == Node XX []  = undefined  -- WORKS!!!
--  rnfp p x | trace "Boo!" () `seq` p == (trace "FOO!!" (Node XX []))  = undefined  -- FOO!! /is/ printed, though only once (like Boo)
--  rnfp p x | trace "Boo!" () `seq` p == Node XX []  = undefined  -- NOT works (printed once only)
--  rnfp p x | (trace "Boo!" p) == Node XX []  = undefined  -- WORKS!!! (printed every time)
--  rnfp p x | trace "Boo!" () `seq` p == Node TN{} []  = undefined
--  rnfp p x | trace "Boo!" () `seq` False  = undefined
--  rnfp p x | trace "Boo!" True, p `seq` False  = undefined
--  rnfp p x | trace "Boo!" False  = undefined
#endif
#if 1
    rnfp p x | handleAttrs p x == Node XX []  = undefined
--  rnfp p@(Node pn _) x | as <- getPatNodeAttrs pn, 9 == uniqueID as  = error $ showPatNodeRaw pn
--  rnfp p@(Node pn@(WI _) _) x = error $ showPatNodeRaw pn
--  rnfp p@(Node pn@WI{} _) x = error $ showPatNodeRaw pn
--  rnfp p@(Node WI{} _) x = handleAttrs p x `seq` ()
    rnfp (Node WI{} _) _ = ()
#else
    rnfp (Node WI{} _) _ = ()
#endif
    rnfp (Node (TR as) chs) d = if elem td treps then d `seq` () else ()
     where td = show $ typeRepTyCon $ typeOf d
           treps = typeConstraints as
    rnfp (Node (TI as) chs) d = if elem td treps then () else d `seq` ()
     where td = show $ typeRepTyCon $ typeOf d
           treps = typeConstraints as
#if USE_WW_DEEPSEQ
    -- complement of TI, equivalent to TR in this special case
    rnfp (Node (TW as) chs) d = if elem td treps then d `seq` () else ()
     where td = show $ typeRepTyCon $ typeOf d
           treps = typeConstraints as
#endif
#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

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

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  rnfp' :: NFDataP_ictx a => PatNode -> () -> a -> ()
#else
#if USE_WW_DEEPSEQ
  rnfp' :: (Typeable a, NFDataN a, NFData a) => PatNode -> () -> a -> ()
#else
  rnfp' :: (Typeable a, NFDataN a) => PatNode -> () -> a -> ()
#endif
#endif
  rnfp' pas 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  -- no problem on bottom
         as = getPatNodeAttrs pas
         treps = typeConstraints as
         n = depth as
     in
#if USE_PAR_PATNODE
     if doSpark as
     then
       case pas of
        WS{} -> () `par` ()
        WR{} -> recurs `par` ()
        WN{} -> rnfn n d `par` ()
#if USE_WW_DEEPSEQ
        WW{} -> rnf d `par` ()  -- should reimplement deepseq for uniformity...
#endif
        WI{} -> error "rnfp: unexpected =WI (please report this bug!)"
        _ -> error $ "rnfp: Unexpected PatNode (with doSpark): " ++ show pas ++ "(please report this bug!)"
     else
#endif
       case pas of
        WR{} -> recurs
        WS{} -> ()
--      WS{} -> d `seq` ()
        WN{} -> rnfn n d
#if USE_WW_DEEPSEQ
        WW{} -> rnf d  -- should reimplement deepseq for uniformity...
#endif
#if 0
        -- 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{} ->  if       elem td treps then recurs else ()
#endif
#if 0
        -- This is not right. To pull this off (b/c it depends on
        -- types in the value you're 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{} ->  if       elem td treps then () else ()
#endif
        TN{} ->  if       elem td treps then rnfn n d else ()
#if USE_WW_DEEPSEQ
        TW{} ->  if       elem td treps then rnf d else ()
#endif
#if 0
        NTR{} -> if not $ elem td treps then recurs else ()
        NTN{} -> if not $ elem td treps then rnfn n d else ()
#if USE_WW_DEEPSEQ
        NTW{} -> if not $ elem td treps then rnf d else ()
#endif
#endif
        -- these handled upstream
        WI{} -> error "rnfp: unexpected WI (please report this bug!)"
        TR{} -> error "rnfp: unexpected TR (please report this bug!)"
        TI{} -> error "rnfp: unexpected TI (please report this bug!)"
        _ -> error $ "rnfp: Unexpected PatNode: " ++ show pas ++ " (please report this bug!)"

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

#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

-------------------------------------------------------------------------------
-- Base nullary types.

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

  instance NFDataP Char
  instance NFDataP Bool
  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

-------------------------------------------------------------------------------
--- Fixed a

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

-------------------------------------------------------------------------------
--- a -> b

  -- [Quoted from deepseq:]
  -- This instance is for convenience and consistency with 'seq'.
  -- This assumes that WHNF is equivalent to NF for functions.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b) => NFDataP (a -> b)
#else
  instance (
             Typeable a, Typeable b
#if HANDLE_ATTRS_DATA_CONSTRAINT
           , Data a, Data b  -- XXX why only needed in THIS instance?
#endif
           ) => NFDataP (a -> b)
--instance NFDataP (a -> b)
#endif

-------------------------------------------------------------------------------
--- Ratio a

  -- not taken to be a level of depth
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, Integral a) => NFDataP (Ratio a) where
#else
#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
#endif
    -- XXX This is very dubious!...
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat x = rnfp pat (numerator x, denominator x)

-------------------------------------------------------------------------------
--- Complex a

  -- Note that (Complex a) constructor (:+) has strict fields,
  -- so unwrapping the ctor also forces both components.
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, RealFloat a) => NFDataP (Complex a) where
#else
#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
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        2 -> let [px,py] = chs
                 (x:+y) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px x
                                   , rnfp py y
                                   ]
#else
             in       rnfp px x
                `seq` rnfp py y
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(Complex a)" pas chs d

-------------------------------------------------------------------------------
--- Maybe a

-- 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 ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance NFDataP_ictx a => NFDataP (Maybe a) where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, NFDataP a) => NFDataP (Maybe a) where
#else
  instance NFDataP a => NFDataP (Maybe a) where
#endif
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) Nothing
     | not $ null chs  = pat_match_fail
     | otherwise       = ()
     where
      pat_match_fail = patMatchFail' "Nothing" pas chs ()
    rnfp (Node pas chs) (Just d)
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas 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" pas chs d
    rnfp (Node pas chs) d = patMatchFail pas chs d  -- unreachable

-------------------------------------------------------------------------------
--- Either a b

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b) => NFDataP (Either a b) where
#else
#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
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp (Node pas chs) (Left d)
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas 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" pas chs d
--    pat_match_fail = patMatchFail' "(Either a b)" pas chs d
    rnfp (Node pas chs) (Right d)
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise     = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas 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" pas chs d
--    pat_match_fail = patMatchFail' "(Either a b)" pas chs d
    rnfp (Node pas chs) d = patMatchFail pas chs d  -- unreachable

-------------------------------------------------------------------------------
--- Data.Version.Version

--- #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 p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        2 -> let [pbr,ptags] = chs
                 Data.Version.Version branch tags = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [rnfp pbr branch, rnfp ptags tags]
#else
             in       rnfp pbr branch
                `seq` rnfp ptags tags
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "Data.Version.Version" pas chs d

-------------------------------------------------------------------------------
--- [a]

  -- Data.List ctors do /not/ have strict fields (i.e. (:) is not strict).
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance NFDataP_ictx a => NFDataP [a] where
#else
#if INCLUDE_SHOW_INSTANCES
  instance (Show a, NFDataP a) => NFDataP [a] where
#else
  instance NFDataP a => NFDataP [a] where
#endif
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp _ [] = ()  -- perhaps dubious?...
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        2 -> let [px,pxs] = chs
                 (x:xs) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [rnfp px x, rnfp pxs xs]
#else
             in       rnfp px x
                `seq` rnfp pxs xs
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "[a]" pas chs d

-------------------------------------------------------------------------------
--- Array a b

  -- Data.Array ctor does /not/ have strict fields.
  -- not taken to be a level of depth
#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (Ix a, NFDataP_ictx a, NFDataP_ictx b) => NFDataP (Array a b) where
#else
#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
#endif
    -- XXX This is very dubious!...
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pas x =        rnfp pas (bounds x, Data.Array.elems x)
                  `seq` ()  -- needed?

-------------------------------------------------------------------------------
--- (a,b)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b) => NFDataP (a,b) where
#else
#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
#endif
    {-  NOINLINE rnfp #-}
--  rnfp _ _ = error "booy"
--  rnfp p x | trace "hoop!" (handleAttrs p x) `seq` p == Node XX []  = undefined
    rnfp p x | handleAttrs p x `seq` p == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        2 -> let [px,py] = chs
                 (x,y) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [rnfp px x, rnfp py y]
#else
             in       rnfp px x
                `seq` rnfp py y
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c) => NFDataP (a,b,c) where
#else
#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
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        3 -> {-trace "WWW" $-}
             let [px,py,pz] = chs
                 (x,y,z) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px x
                                   , rnfp py y
                                   , rnfp pz z
                                   ]
#else
             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)
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c,d)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d) => NFDataP (a,b,c,d) where
#else
#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
#endif
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        4 -> let [px1,px2,px3,px4] = chs
                 (x1,x2,x3,x4) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   ]
#else
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c,d,e)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d, NFDataP_ictx e) =>
#else
#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, Show e, Typeable e, NFDataP e) =>
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d, Typeable e, NFDataP e) =>
#endif
#endif
         NFDataP (a, b, c, d, e) where
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        5 -> let [px1,px2,px3,px4,px5] = chs
                 (x1,x2,x3,x4,x5) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   , rnfp px5 x5
                                   ]
#else
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` rnfp px5 x5
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c,d,e,f)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d, NFDataP_ictx e, NFDataP_ictx f) =>
#else
#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, Show e, Typeable e, NFDataP e, Show f, Typeable f, NFDataP f) =>
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d, Typeable e, NFDataP e, Typeable f, NFDataP f) =>
#endif
#endif
         NFDataP (a, b, c, d, e, f) where
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        6 -> let [px1,px2,px3,px4,px5,px6] = chs
                 (x1,x2,x3,x4,x5,x6) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   , rnfp px5 x5
                                   , rnfp px6 x6
                                   ]
#else
             in       rnfp px1 x1
                `seq` rnfp px2 x2
                `seq` rnfp px3 x3
                `seq` rnfp px4 x4
                `seq` rnfp px5 x5
                `seq` rnfp px6 x6
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,,)" pas chs d

-------------------------------------------------------------------------------
--- (a,b,c,d,e,f,g)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d, NFDataP_ictx e, NFDataP_ictx f, NFDataP_ictx g) =>
#else
#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, Show e, Typeable e, NFDataP e, Show f, Typeable f, NFDataP f, Show g, Typeable g, NFDataP g) =>
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d, Typeable e, NFDataP e, Typeable f, NFDataP f, Typeable g, NFDataP g) =>
#endif
#endif
         NFDataP (a, b, c, d, e, f, g) where
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        7 -> let [px1,px2,px3,px4,px5,px6,px7] = chs
                 (x1,x2,x3,x4,x5,x6,x7) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   , rnfp px5 x5
                                   , rnfp px6 x6
                                   , rnfp px7 x7
                                   ]
#else
             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
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,,,)" pas chs d

#if 0

-- XXX No Typeable instances for tuples larger than 7 in 7.8.1, seemingly?

-------------------------------------------------------------------------------
--- (a,b,c,d,e,f,g,h)

#if ( ! HASKELL98_FRAGMENT ) && ( __GLASGOW_HASKELL__ >= 710 )
  instance (NFDataP_ictx a, NFDataP_ictx b, NFDataP_ictx c, NFDataP_ictx d, NFDataP_ictx e, NFDataP_ictx f, NFDataP_ictx g, NFDataP_ictx h) =>
#else
#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, Show e, Typeable e, NFDataP e, Show f, Typeable f, NFDataP f, Show g, Typeable g, NFDataP g, Show h, Typeable h, NFDataP h) =>
#else
  instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d, Typeable e, NFDataP e, Typeable f, NFDataP f, Typeable g, NFDataP g, Typeable h, NFDataP h) =>
#endif
#endif
         NFDataP (a, b, c, d, e, f, g, h) where
    {-  NOINLINE rnfp #-}
    rnfp p x | handleAttrs p x == Node XX []  = undefined
    rnfp (Node WI{} _) _ = ()
    rnfp pat@(Node pas chs) d
     | TR{} <- pas  = if elem td treps then recurs else ()
#if USE_WW_DEEPSEQ
     | TI{} <- pas  = if elem td treps then () else rnf d
     | TW{} <- pas  = if elem td treps then rnf d else ()
#else
     | TI{} <- pas  = if elem td treps then () else rnfn 999999 d  -- XXX thack!
#endif
     | otherwise    = rnfp' pas recurs d
     where
      as = getPatNodeAttrs pas
      treps = typeConstraints as
      td = show $ typeRepTyCon $ typeOf d
      recurs = case length chs of
        0 -> case pas of
              WS{} -> ()
              _ -> pat_match_fail
        8 -> let [px1,px2,px3,px4,px5,px6,px7,px8] = chs
                 (x1,x2,x3,x4,x5,x6,x7,x8) = d
#if USE_PSEQ_PATNODE
             in pseq_condition pat [ rnfp px1 x1
                                   , rnfp px2 x2
                                   , rnfp px3 x3
                                   , rnfp px4 x4
                                   , rnfp px5 x5
                                   , rnfp px6 x6
                                   , rnfp px7 x7
                                   , rnfp px8 x8
                                   ]
#else
             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` rnfp px8 x8
#endif
                `seq` ()  -- needed?
        _ -> pat_match_fail
      pat_match_fail = patMatchFail' "(,,,,,,,)" pas chs d

#endif

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

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

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

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

-- XXX Seeing as we're having troubles anyway, and considering
-- that most of this function requires popping into unsafePerformIO
-- anyway -- should the whole thing be returning IO, and then just
-- use unsafePerformIO in caller?

  -- This function collects all the "harmless impure things" we
  -- need to pop into IO to do.  To what extent we get away with
  -- this remains to be investigated...
  ------
  -- So, which of the PatNodeAttrs product type can be dealt with here?
  --   NOT doSpark  - dealt with downstream in rnfp'
  --   NOT doPseq   - about to be dealt with downstream (hopefully rnfp')...
  --       doDelay
  --       doTrace
  --       doPing
  --       doDie
  --       doTiming
  -----
  -- XXX Returning Pattern instead of Bool, in a continued attempt
  -- to outsmart GHC and get certain things to be evaluated...

  {-  NOINLINE handleAttrs #-}
#if 0
-- XXX XXX XXX testing only!!!! XXX XXX XXX
  handleAttrs pat@(Node p _) x = pat
#else
#if ! HASKELL98_FRAGMENT
#if HANDLE_ATTRS_DATA_CONSTRAINT
  handleAttrs :: forall d. Data d => Pattern -> d -> Pattern
--handleAttrs :: forall d. Data d => Pattern -> d -> Bool
  handleAttrs (Node p _) x
#else
  handleAttrs :: forall d. Typeable d => Pattern -> d -> Pattern
--handleAttrs :: forall d. Typeable d => Pattern -> d -> Bool
  handleAttrs (Node p _) x
#endif
#else
  handleAttrs :: Pattern -> a -> Pattern
--handleAttrs :: Pattern -> a -> Bool
  handleAttrs (Node p _) _
#endif
--- | doTrace as && trace ("HERE! "++show p++"\n"++show as) False = undefined
--- | trace ("HERE! "++show p++"\n"++show as) False = undefined
#if 0
    | uniqueID as ==  4 && trace ("HERE! "++show p++"\n"++show as) False = undefined
    | uniqueID as ==  9 && trace ("HERE! "++show p++"\n"++show as) False = undefined
    | uniqueID as == 11 && trace ("HERE! "++show p++"\n"++show as) False = undefined
#endif
--- | otherwise  = unsafePerformIO $! do
    | otherwise  = unsafePerformIO $ do
--- | otherwise  = trace ("BUHGO!") $ unsafePerformIO $ do
--- | otherwise  = trace ("BUHGO!") $ unsafeDupablePerformIO $ do
       let p0 = p
       p1 <- if doDelay as
             then dly p0 b
             else return p0
#if USE_TRACE_PATNODE
       p2 <- if doTrace as
             then trc p1 b msg_trc
             else return p1
#else
       let p2 = p1
#endif
#if USE_PING_PATNODE
       p3 <- if doPing as
             then png p2 b msg_png
             else return p2
#else
       let p3 = p2
#endif
#if USE_DIE_PATNODE
       p4 <- if doDie as
             then die p3 b msg_die
             else return p3
#else
       let p4 = p3
#endif
#if USE_TIMING_PATNODE
       p5 <- if doTiming as
             then timing p4 b msg_timing
             else return p4
#else
       let p5 = p4
#endif
       return $! Node p5 []
    | otherwise                   = Node p []  -- don't forget!
--- | otherwise                   = p     -- don't forget!
--- | otherwise                   = True  -- don't forget!
   where
#if 1
    b = False  -- WORKED for Ping/png; not working for Trace/trc...
#else
    b = unsafePerformIO $ ( randomIO :: IO Bool )  -- WORKS!!! (even though value is constant!)
#endif
    {-# NOINLINE dly #-}  -- XXX crucial
    dly p b
---  | trace "dly msg!" False = undefined
     | otherwise  = do
         if b
           then do
             !_ <- threadDelay $ delayus as
             return p
--           return $ not b
           else do
             !_ <- threadDelay $ delayus as
             return p
--           return '
#if USE_TRACE_PATNODE
    msg_trc =    "NFDataP: TRACE: " ++ show (uniqueID as)
#if ! HASKELL98_FRAGMENT
              ++ " " ++ show (typeOf x)
#if HANDLE_ATTRS_DATA_CONSTRAINT
              ++ "\n" ++ showRose (shapeOf x)
#endif
#endif
    {-# NOINLINE trc #-}  -- XXX crucial
    trc p b msg
---  | trace "trc msg!" False = undefined
     | otherwise  = do
         if b
           then do
---          !_ <- forkIO $ return (trace msg ())
---          !_ <- forkIO (return (trace msg ()))
             !_ <- trace msg $ return ()
             return p
--           return $ not b
           else do
---          !_ <- forkIO $ return (trace msg ())
---          !_ <- forkIO (return (trace msg ()))
             !_ <- trace msg $ return ()
             return p
--           return '
#endif
#if USE_PING_PATNODE
    msg_png =    "NFDataP: PING: " ++ show (uniqueID as)
#if ! HASKELL98_FRAGMENT
              ++ " " ++ show (typeOf x)
#if HANDLE_ATTRS_DATA_CONSTRAINT
              ++ "\n" ++ showRose (shapeOf x)
#endif
#endif
    {-# NOINLINE png #-}  -- XXX crucial
    -- Consider mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
    png p b msg
---  | trace "png msg!" False = undefined
#if 1
     | isNothing mpngtid  = do
--        b <- randomIO :: IO Bool
---      let b = False in
         if b
           then do
             return p
--           return $ not b
           else do
             return p
--           return b
#else
     | isNothing mpngtid  = False
#endif
     | otherwise  = do
--        b <- randomIO :: IO Bool
---      let b = False in
         if b
           then do
             !_ <- forkIO $ throw $ DeepSeqBounded_PingException msg
---          putStrLn "Carrying on FALSE ..."
             return p
--           return $ not b
           else do
             -- This worked! (exception thrown, yet continues)
             -- Getting repeatable actions still eludes...
--           evaluate (unsafeInterleaveIO (do
--           evaluate (unsafeDupablePerformIO (do
             !_ <- forkIO $ throw $ DeepSeqBounded_PingException msg
---          putStrLn "Carrying on TRUE ..."
             return p
--           return b
     where mpngtid = pingParentTID as
#endif
#if USE_DIE_PATNODE
    msg_die =    "NFDataP: DIE: " ++ show (uniqueID as)
#if ! HASKELL98_FRAGMENT
              ++ " " ++ show (typeOf x)
#if HANDLE_ATTRS_DATA_CONSTRAINT
              ++ "\n" ++ showRose (shapeOf x)
#endif
#endif
    {-# NOINLINE die #-}  -- XXX crucial (except perhaps in this die case...)
    die p b msg = do
      if b
        then do
          putStrLn msg >> myThreadId >>= killThread
          return p
--        return $ not b
        else do
          putStrLn msg >> myThreadId >>= killThread
          return p
--        return b
#endif
#if USE_TIMING_PATNODE
    msg_timing =    "NFDataP: TIMING: " ++ show (uniqueID as)
#if ! HASKELL98_FRAGMENT
                 ++ " " ++ show (typeOf x)
#if HANDLE_ATTRS_DATA_CONSTRAINT
                 ++ "\n" ++ showRose (shapeOf x)
#endif
#endif
    {-# NOINLINE timing #-}
    timing p b msg = do
      if b
        then do
          -- ... XXX
          return p
--        return $ not b
        else do
          -- ... XXX
          return p
--        return b
#endif
    as = getPatNodeAttrs p  -- XXX THIS IS BAD (bottleneck)
             -- [See 000-readme, cotemp 20150104.]
             -- Is there not a simpler way to get at the PatNodeAttr?
             -- One thing could do, is put the node type (WR, etc.)
             -- in PatNodeAttrs, and then PatNode = PatNodeAttrs.
             -- There's no real disadvantage, right? -- we can still
             -- pattern match almost as do now:
             --   (Node WR{} cs)               -- now
             --   (Node PN{nodeKind=WR}  cs)   -- hopefully!
#endif

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

#if USE_PSEQ_PATNODE

  -- Note that, if USE_PSEQ_PATNODE flag is True, then Control.Parallel.pseq
  -- is used instead of Prelude.seq, whether or not a >cdba permutation was
  -- specified.  I'd kinda rather continue to use seq for the cases where
  -- no permutation was specified...
  pseq_condition :: Pattern -> [()] -> ()
--pseq_condition :: [Pattern] -> [()] -> ()
--pseq_condition :: [Pattern] -> [ Pattern -> x -> () ] -> ()
--pseq_condition :: [Pattern] -> [Pattern -> x -> ()] -> [Pattern -> x -> ()]
#if 0
#elif 1
  pseq_condition pat@(Node pn cs) fs
   | isNothing mperm  = foldr  seq () fs
   | otherwise        = foldr pseq () $ map (\i->(fs!!i)) perm
   where
    mperm = pseqPerm $ getPatNodeAttrs pn
    perm = fromJust mperm
#elif 0
  pseq_condition pat@(Node pn cs) fs
   = foldr pseq () fs'  -- is foldr the right fold?
   where
    mperm = pseqPerm $ getPatNodeAttrs pn
    perm = fromJust mperm
    fs' | isNothing mperm  = fs
        | otherwise        = map (\i->(fs!!i)) perm
#elif 0
  pseq_condition pats fs = foldr seq () fs  -- is foldr the right fold?
#endif

#endif

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


{-# LANGUAGE CPP                 #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if MIN_VERSION_base(4,9,0)
{-# LANGUAGE TypeApplications    #-}
#endif

{-# OPTIONS_GHC -Wall #-}

{- | This module contains a bunch of pre-defined proxies
     so that users don't /always/ have to write @(Proxy :: Proxy Word8)@,
     etc.

     It is recommended that you import this module qualified to avoid
     naming conflicts.
-}

module Proxy
  ( Proxy1(..)
  , Proxy2(..)
  , bool
  , char
#if MIN_VERSION_base(4,7,0)
  , complex
#endif
#if MIN_VERSION_base(4,9,0)
  , compose
#endif
#if MIN_VERSION_base(4,7,0)
  , const
#endif
  , constr
#if MIN_VERSION_base(4,9,0)
  , constraint
#endif
  , datarep
  , datatype
  , dynamic
  , e0
  , e1
  , e2
  , e3
  , e6
  , e9
  , e12
#if MIN_VERSION_base(4,7,0)
  , either
#endif
#if MIN_VERSION_base(4,7,0)
  , fixed
#endif
  , fixity
#if MIN_VERSION_base(4,10,0)
  , hrefl
#endif
#if MIN_VERSION_base(4,8,0)
  , identity
#endif
#if MIN_VERSION_base(4,7,0)
  , ioref
#endif
  , int
  , int8
  , int16
  , int32
  , int64
  , ordering
#if MIN_VERSION_base(4,9,0)
  , functorproduct
#endif
#if MIN_VERSION_base(4,7,0)
  , refl
#endif
  , string
#if MIN_VERSION_base(4,9,0)
  , functorsum
#endif
  , word
  , word8
  , word16
  , word32
  , word64
  , unique
  , version
#if MIN_VERSION_base(4,8,0)
  , void
#endif

#if MIN_VERSION_base(4,9,0)
  , mkProxy1
  , mkProxy2
#endif
  ) where

import Data.Complex (Complex)
import Data.Data (Constr, DataType, DataRep, Fixity)
import Data.Dynamic (Dynamic)
#if MIN_VERSION_base(4,7,0)
import Data.Fixed (Fixed, E0, E1, E2, E3, E6, E9, E12)
#endif
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Compose (Compose)
#endif
#if MIN_VERSION_base(4,7,0)
import Data.Functor.Const (Const)
#endif
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity
#endif
#if MIN_VERSION_base(4,9,0)
import qualified Data.Functor.Product as Functor
#endif
#if MIN_VERSION_base(4,9,0)
import qualified Data.Functor.Sum as Functor
#endif
#if MIN_VERSION_base(4,7,0)
import Data.IORef (IORef)
#endif
import Data.Int (Int8, Int16, Int32, Int64)
#if MIN_VERSION_base(4,9,0)
import Data.Kind (Constraint)
#endif
import Data.Proxy (Proxy(..))
import Data.Word (Word8, Word16, Word32, Word64)
#if MIN_VERSION_base(4,7,0)
import Data.Type.Equality
  ( (:~:)
#if MIN_VERSION_base(4,10,0)
  , (:~~:)
#endif
  )
#endif
import Data.Unique (Unique)
import Data.Version (Version)
#if MIN_VERSION_base(4,8,0)
import Data.Void (Void)
#endif

import Prelude hiding (const, either, product, sum)

-- | In older versions of GHC, Proxy is not poly-kinded,
--   so we provide Proxy1.
data Proxy1 (f :: * -> *) = Proxy1

-- | In older versions of GHC, Proxy is not poly-kinded,
--   so we provide Proxy2.
data Proxy2 (f :: * -> * -> *) = Proxy2

bool :: Proxy Bool
bool = Proxy

char :: Proxy Char
char = Proxy

#if MIN_VERSION_base(4,7,0)
complex :: Proxy Complex
complex = Proxy
#endif

#if MIN_VERSION_base(4,9,0)
compose :: Proxy Compose
compose = Proxy
#endif

#if MIN_VERSION_base(4,7,0)
const :: Proxy Const
const = Proxy
#endif

constr :: Proxy Constr
constr = Proxy

#if MIN_VERSION_base(4,9,0)
constraint :: Proxy Constraint
constraint = Proxy
#endif

datarep :: Proxy DataRep
datarep = Proxy

datatype :: Proxy DataType
datatype = Proxy

dynamic :: Proxy Dynamic
dynamic = Proxy

#if MIN_VERSION_base(4,7,0)
either :: Proxy Either
either = Proxy
#endif

#if MIN_VERSION_base(4,7,0)
fixed :: Proxy Fixed
fixed = Proxy
#endif

e0 :: Proxy E0
e0 = Proxy

e1 :: Proxy E1
e1 = Proxy

e2 :: Proxy E2
e2 = Proxy

e3 :: Proxy E3
e3 = Proxy

e6 :: Proxy E6
e6 = Proxy

e9 :: Proxy E9
e9 = Proxy

e12 :: Proxy E12
e12 = Proxy

fixity :: Proxy Fixity
fixity = Proxy

#if MIN_VERSION_base(4,10,0)
hrefl :: Proxy (:~~:)
hrefl = Proxy
#endif

#if MIN_VERSION_base(4,8,0)
identity :: Proxy Identity
identity = Proxy
#endif

#if MIN_VERSION_base(4,7,0)
ioref :: Proxy IORef
ioref = Proxy
#endif

int :: Proxy Int
int = Proxy

int8 :: Proxy Int8
int8 = Proxy

int16 :: Proxy Int16
int16 = Proxy

int32 :: Proxy Int32
int32 = Proxy

int64 :: Proxy Int64
int64 = Proxy

#if MIN_VERSION_base(4,9,0)
functorproduct :: Proxy Functor.Product
functorproduct = Proxy
#endif

#if MIN_VERSION_base(4,7,0)
refl :: Proxy (:~:)
refl = Proxy
#endif

string :: Proxy String
string = Proxy

#if MIN_VERSION_base(4,9,0)
functorsum :: Proxy Functor.Sum
functorsum = Proxy
#endif

word :: Proxy Word
word = Proxy

word8 :: Proxy Word8
word8 = Proxy

word16 :: Proxy Word16
word16 = Proxy

word32 :: Proxy Word32
word32 = Proxy

word64 :: Proxy Word64
word64 = Proxy

ordering :: Proxy Ordering
ordering = Proxy

unique :: Proxy Unique
unique = Proxy

version :: Proxy Version
version = Proxy

#if MIN_VERSION_base(4,8,0)
void :: Proxy Void
void = Proxy
#endif

#if MIN_VERSION_base(4,9,0)
mkProxy1 :: forall f a. Proxy (f a)
mkProxy1 = Proxy @(f a)

mkProxy2 :: forall f a b. Proxy (f a b)
mkProxy2 = Proxy @(f a b)
#endif


-- | Common infrastructure for CVode/ARKode
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Numeric.Sundials.Common where

import Foreign.C.Types
import Foreign.Ptr
import Foreign.C.String
import Numeric.Sundials.Foreign as T
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as VSM
import Numeric.LinearAlgebra.HMatrix as H hiding (Vector)
import GHC.Prim
import Control.DeepSeq
import Katip
import Data.Aeson
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as Map
import Control.Monad.Reader
import GHC.Generics (Generic)
import Foreign.ForeignPtr
import Language.C.Types as CT
import Language.C.Inline.Context
import qualified Language.Haskell.TH as TH

-- | A collection of variables that we allocate on the Haskell side and
-- pass into the C code to be filled.
data CVars vec = CVars
  { c_diagnostics :: vec SunIndexType
    -- ^ Mutable vector to which we write diagnostic data while
    -- solving. Its size corresponds to the number of fields in
    -- 'SundialsDiagnostics'.
  , c_root_info :: vec CInt
    -- ^ Just a temporary vector (of the size equal to the number of event
    -- specs) that we use to get root info. Isn't used for output.
  , c_event_index :: vec CInt
    -- ^ For each event occurrence, this indicates which of the events
    -- occurred. Size: max_num_events.
  , c_event_time :: vec CDouble
    -- ^ For each event occurrence, this indicates the time of the
    -- occurrence. Size: max_num_events.
  , c_n_events :: vec CInt
    -- ^ Vector of size 1 that gives the total number of events occurred.
  , c_n_rows :: vec CInt
    -- ^ The total number of rows in the output matrix.
  , c_output_mat :: vec CDouble
    -- ^ The output matrix stored in the row-major order.
    -- Dimensions: (1 + dim) * (2 * max_events + nTs).
  , c_actual_event_direction :: vec CInt
    -- ^ Vector of size max_num_events that gives the direction of the
    -- occurred event.
  , c_local_error :: vec CDouble
    -- ^ Vector containing local error estimates. Size: the dimensionality
    -- of the system.
  , c_var_weight :: vec CDouble
    -- ^ Vector containing variable weights (derived from the tolerances).
    -- Size: the dimensionality of the system.
  , c_local_error_set :: vec CInt
    -- The flag (size 1) indicating whether c_local_error is filled with meaningful
    -- values. *Should be initialized with 0.*
  }

allocateCVars :: OdeProblem -> IO (CVars (VS.MVector RealWorld))
allocateCVars OdeProblem{..} = do
  let dim = VS.length odeInitCond
  c_diagnostics <- VSM.new 11
  c_root_info <- VSM.new $ V.length odeEventDirections
  c_event_index <- VSM.new odeMaxEvents
  c_event_time <- VSM.new odeMaxEvents
  c_actual_event_direction <- VSM.new odeMaxEvents
  c_n_events <- VSM.new 1
  c_n_rows <- VSM.new 1
  c_local_error <- VSM.new dim
  c_var_weight <- VSM.new dim
  c_local_error_set <- VSM.new 1
  VSM.write c_local_error_set 0 0
  c_output_mat <- VSM.new $
    (1 + dim) * (2 * odeMaxEvents + VS.length odeSolTimes)
  return CVars {..}

-- NB: the mutable CVars must not be used after this
freezeCVars :: CVars (VS.MVector RealWorld) -> IO (CVars VS.Vector)
freezeCVars CVars{..} = do
  c_diagnostics <- VS.unsafeFreeze c_diagnostics
  c_root_info <- VS.unsafeFreeze c_root_info
  c_event_index <- VS.unsafeFreeze c_event_index
  c_event_time <- VS.unsafeFreeze c_event_time
  c_actual_event_direction <- VS.unsafeFreeze c_actual_event_direction
  c_n_events <- VS.unsafeFreeze c_n_events
  c_n_rows <- VS.unsafeFreeze c_n_rows
  c_output_mat <- VS.unsafeFreeze c_output_mat
  c_local_error <- VS.unsafeFreeze c_local_error
  c_var_weight <- VS.unsafeFreeze c_var_weight
  c_local_error_set <- VS.unsafeFreeze c_local_error_set
  return CVars {..}

-- | Similar to 'CVars', except these are immutable values that are
-- accessed (read-only) by the C code and specify the system to be solved.
data CConsts = CConsts
  { c_dim :: SunIndexType -- ^ the dimensionality (number of variables/equations)
  , c_method :: CInt -- ^ the ODE method (specific to the solver)
  , c_n_sol_times :: CInt
  , c_sol_time :: VS.Vector CDouble
  , c_init_cond :: VS.Vector CDouble
  , c_rhs :: FunPtr OdeRhsCType
  , c_rhs_userdata :: Ptr UserData
  , c_rtol :: CDouble
  , c_atol :: VS.Vector CDouble
  , c_n_event_specs :: CInt
  , c_event_fn :: FunPtr EventConditionCType
  , c_apply_event
      :: CInt -- number of triggered events
      -> Ptr CInt -- event indices
      -> CDouble -- time
      -> Ptr T.SunVector -- y
      -> Ptr T.SunVector -- new y
      -> Ptr CInt -- (out) stop the solver?
      -> Ptr CInt -- (out) record the event?
      -> IO CInt
  , c_jac_set :: CInt
  , c_jac :: FunPtr OdeJacobianCType
  , c_sparse_jac :: CInt
      -- ^ If 0, use a dense matrix.
      -- If non-0, use a sparse matrix with that number of non-zero
      -- elements.
  , c_requested_event_direction :: VS.Vector CInt
  , c_next_time_event :: IO CDouble
  , c_max_events :: CInt
  , c_minstep :: CDouble
  , c_fixedstep :: CDouble
  , c_max_n_steps :: SunIndexType
  , c_max_err_test_fails :: CInt
  , c_init_step_size_set :: CInt
  , c_init_step_size :: CDouble
  }

data MethodType = Explicit | Implicit
  deriving (Show, Eq)

class IsMethod method where
  methodToInt :: method -> CInt
  methodType :: method -> MethodType

matrixToSunMatrix :: Matrix Double -> T.SunMatrix
matrixToSunMatrix m = T.SunMatrix { T.rows = nr, T.cols = nc, T.vals = vs }
  where
    nr = fromIntegral $ H.rows m
    nc = fromIntegral $ H.cols m
    vs = coerce . VS.concat $ toColumns m

-- Contrary to the documentation, it appears that CVodeGetRootInfo
-- may use both 1 and -1 to indicate a root, depending on the
-- direction of the sign change. See near the end of cvRootfind.
intToDirection :: Integral d => d -> Maybe CrossingDirection
intToDirection d =
  case d of
    1  -> Just Upwards
    -1 -> Just Downwards
    _  -> Nothing

-- | Almost inverse of 'intToDirection'. Map 'Upwards' to 1, 'Downwards' to
-- -1, and 'AnyDirection' to 0.
directionToInt :: Integral d => CrossingDirection -> d
directionToInt d =
  case d of
    Upwards -> 1
    Downwards -> -1
    AnyDirection -> 0

foreign import ccall "wrapper"
  mkOdeRhsC :: OdeRhsCType -> IO (FunPtr OdeRhsCType)

foreign import ccall "wrapper"
  mkOdeJacobianC :: OdeJacobianCType -> IO (FunPtr OdeJacobianCType)

foreign import ccall "wrapper"
  mkEventConditionsC :: EventConditionCType -> IO (FunPtr EventConditionCType)

assembleSolverResult
  :: OdeProblem
  -> CInt
  -> CVars VS.Vector
  -> IO (Either ErrorDiagnostics SundialsSolution)
assembleSolverResult OdeProblem{..} ret CVars{..} = do
  let
    dim = VS.length odeInitCond
    n_rows = fromIntegral . VS.head $ c_n_rows
    output_mat = coerce . reshape (dim + 1) . subVector 0 ((dim + 1) * n_rows) $ c_output_mat
    (local_errors, var_weights) =
      if c_local_error_set VS.! 0 == 0
        then (mempty, mempty)
        else coerce (c_local_error, c_var_weight)
    diagnostics = SundialsDiagnostics
      (fromIntegral $ c_diagnostics VS.!0)
      (fromIntegral $ c_diagnostics VS.!1)
      (fromIntegral $ c_diagnostics VS.!2)
      (fromIntegral $ c_diagnostics VS.!3)
      (fromIntegral $ c_diagnostics VS.!4)
      (fromIntegral $ c_diagnostics VS.!5)
      (fromIntegral $ c_diagnostics VS.!6)
      (fromIntegral $ c_diagnostics VS.!7)
      (fromIntegral $ c_diagnostics VS.!8)
      (fromIntegral $ c_diagnostics VS.!9)
      (toEnum . fromIntegral $ c_diagnostics VS.! 10)
  return $
    if ret == T.cV_SUCCESS
      then
        Right $ SundialsSolution
          { actualTimeGrid = extractTimeGrid output_mat
          , solutionMatrix = dropTimeGrid output_mat
          , diagnostics
          }
      else
        Left ErrorDiagnostics
          { partialResults = output_mat
          , errorCode = fromIntegral ret
          , errorEstimates = local_errors
          , varWeights = var_weights
          }
  where
    -- The time grid is the first column of the result matrix
    extractTimeGrid :: Matrix Double -> VS.Vector Double
    extractTimeGrid = head . toColumns
    dropTimeGrid :: Matrix Double -> Matrix Double
    dropTimeGrid = fromColumns . tail . toColumns

-- | An auxiliary function to construct a storable vector from a C pointer
-- and length.
--
-- There doesn't seem to be a safe version of 'VS.unsafeFromForeignPtr0',
-- nor a way to clone an immutable vector, so we emulate it via an
-- intermediate mutable vector.
vecFromPtr
  :: VS.Storable a
  => Ptr a
  -> Int
  -> IO (VS.Vector a)
vecFromPtr ptr n = do
  fptr <- newForeignPtr_ ptr
  let mv = VSM.unsafeFromForeignPtr0 fptr n
  VS.freeze mv -- this does the copying and makes the whole thing safe

----------------------------------------------------------------------
--                           Logging
----------------------------------------------------------------------

-- | The Katip payload for logging Sundials errors
data SundialsErrorContext = SundialsErrorContext
  { sundialsErrorCode :: !Int
  , sundialsErrorModule :: !T.Text
  , sundialsErrorFunction :: !T.Text
  } deriving Generic
instance ToJSON SundialsErrorContext
instance ToObject SundialsErrorContext
instance LogItem SundialsErrorContext where
  payloadKeys _ _ = AllKeys

type ReportErrorFn =
  (  CInt    -- error code
  -> CString -- module name
  -> CString -- function name
  -> CString -- the message
  -> Ptr ()  -- user data (ignored)
  -> IO ()
  )

cstringToText :: CString -> IO T.Text
cstringToText = fmap T.decodeUtf8 . BS.packCString

reportErrorWithKatip :: LogEnv -> ReportErrorFn
reportErrorWithKatip log_env err_code c_mod_name c_func_name c_msg _userdata = do
  -- See Note [CV_TOO_CLOSE]
  if err_code == T.cV_TOO_CLOSE then pure () else do
  let
  mod_name <- cstringToText c_mod_name
  func_name <- cstringToText c_func_name
  msg <- cstringToText c_msg
  let
    severity :: Severity
    severity =
      if err_code <= 0
        then ErrorS
        else InfoS
    errCtx :: SundialsErrorContext
    errCtx = SundialsErrorContext
      { sundialsErrorCode = fromIntegral err_code
      , sundialsErrorModule = mod_name
      , sundialsErrorFunction = func_name
      }
  flip runReaderT log_env . unKatipT $ do
    logF errCtx "sundials" severity (logStr msg)

debugMsgWithKatip :: LogEnv -> CString -> IO ()
debugMsgWithKatip log_env cstr = do
  text <- cstringToText cstr
  flip runReaderT log_env . unKatipT $ do
    logF () "hmatrix-sundials" DebugS (logStr text)

-- From the former Types module

data EventHandlerResult = EventHandlerResult
  { eventStopSolver :: !Bool
    -- ^ should we stop the solver after handling this event?
  , eventRecord :: !Bool
    -- ^ should we record the state before and after the event in the ODE
    -- solution?
  , eventNewState :: !(VS.Vector Double)
    -- ^ the new state after the event has been applied
  }

type EventHandler
  =  Double -- ^ time
  -> VS.Vector Double -- ^ values of the variables
  -> VS.Vector Int
    -- ^ Vector of triggered event indices.
    -- If the vector is empty, this is a time-based event.
  -> IO EventHandlerResult

data OdeProblem = OdeProblem
  { odeEventConditions :: EventConditions
    -- ^ The event conditions
  , odeEventDirections :: V.Vector CrossingDirection
    -- ^ The requested directions of 0 crossing for each event. Also, the
    -- length of this vector tells us the number of events (even when
    -- 'odeEventConditions' is represented by a single C function).
  , odeMaxEvents :: !Int
    -- ^ The maximal number of events that may occur. This is needed to
    -- allocate enough space to store the events. If more events occur, an
    -- error is returned.
  , odeEventHandler :: EventHandler -- ^ The event handler.
  , odeTimeBasedEvents :: TimeEventSpec
  , odeRhs :: OdeRhs
    -- ^ The right-hand side of the system: either a Haskell function or
    -- a pointer to a compiled function.
  , odeJacobian :: Maybe OdeJacobian
    -- ^ The optional Jacobian (the arguments are the time and the state
    -- vector).
  , odeInitCond :: VS.Vector Double
    -- ^ The initial conditions of the problem.
  , odeSolTimes :: VS.Vector Double
    -- ^ The requested solution times. The actual solution times may be
    -- larger if any events occurred.
  , odeTolerances :: Tolerances
    -- ^ How much error is tolerated in each variable.
  }

data Tolerances = Tolerances
  { relTolerance :: !CDouble
  , absTolerances :: Either CDouble (VS.Vector CDouble)
    -- ^ If 'Left', then the same tolerance is used for all variables.
    --
    -- If 'Right', the vector should contain one tolerance per variable.
  } deriving (Show, Eq, Ord)

-- | The type of the C ODE RHS function.
type OdeRhsCType = CDouble -> Ptr SunVector -> Ptr SunVector -> Ptr UserData -> IO CInt

data UserData

-- | The right-hand side of an ODE system.
--
-- Can be either a Haskell function or a pointer to a C function.
data OdeRhs
  = OdeRhsHaskell (CDouble -> VS.Vector CDouble -> IO (VS.Vector CDouble))
  | OdeRhsC (FunPtr OdeRhsCType) (Ptr UserData)

-- | A version of 'OdeRhsHaskell' that accepts a pure function
odeRhsPure
  :: (CDouble -> VS.Vector CDouble -> VS.Vector CDouble)
  -> OdeRhs
odeRhsPure f = OdeRhsHaskell $ \t y -> return $ f t y

type OdeJacobianCType
  =  SunRealType   -- ^ @realtype t@
  -> Ptr SunVector -- ^ @N_Vector y@
  -> Ptr SunVector -- ^ @N_Vector fy@
  -> Ptr SunMatrix -- ^ @SUNMatrix Jac@
  -> Ptr UserData  -- ^ @void *user_data@
  -> Ptr SunVector -- ^ @N_Vector tmp1@
  -> Ptr SunVector -- ^ @N_Vector tmp2@
  -> Ptr SunVector -- ^ @N_Vector tmp3@
  -> IO CInt       -- ^ return value (0 if successful, >0 for a recoverable error, <0 for an unrecoverable error)

-- | The Jacobian of the right-hand side of an ODE system.
--
-- Can be either a Haskell function or a pointer to a C function.
data OdeJacobian
  = OdeJacobianHaskell (Double -> VS.Vector Double -> Matrix Double)
  | OdeJacobianC (FunPtr OdeJacobianCType)

data JacobianRepr
  = SparseJacobian !SparsePattern -- ^ sparse Jacobian with the given sparse pattern
  | DenseJacobian
  deriving (Show)

type EventConditionCType
  =  SunRealType     -- ^ @realtype t@
  -> Ptr SunVector   -- ^ @N_Vector y@
  -> Ptr SunRealType -- ^ @realtype *gout@
  -> Ptr UserData    -- ^ @void *user_data@
  -> IO CInt

data EventConditions
  = EventConditionsHaskell (Double -> VS.Vector Double -> VS.Vector Double)
  | EventConditionsC (FunPtr EventConditionCType)

-- | A way to construct 'EventConditionsHaskell' when there is no shared
-- computation among different functions
eventConditionsPure :: V.Vector (Double -> VS.Vector Double -> Double) -> EventConditions
eventConditionsPure conds = EventConditionsHaskell $ \t y ->
  V.convert $ V.map (\cond -> cond t y) conds

data SundialsDiagnostics = SundialsDiagnostics {
    odeGetNumSteps               :: Int
  , odeGetNumStepAttempts        :: Int
  , odeGetNumRhsEvals_fe         :: Int
  , odeGetNumRhsEvals_fi         :: Int
  , odeGetNumLinSolvSetups       :: Int
  , odeGetNumErrTestFails        :: Int
  , odeGetNumNonlinSolvIters     :: Int
  , odeGetNumNonlinSolvConvFails :: Int
  , dlsGetNumJacEvals            :: Int
  , dlsGetNumRhsEvals            :: Int
  , odeMaxEventsReached          :: Bool
  } deriving (Eq, Show, Generic, NFData)

instance Semigroup SundialsDiagnostics where
   (<>) (SundialsDiagnostics
          numSteps_1
          numStepAttempts_1
          numRhsEvals_fe_1
          numRhsEvals_fi_1
          numLinSolvSetups_1
          numErrTestFails_1
          numNonlinSolvIters_1
          numNonlinSolvConvFails_1
          numJacEvals_1
          numRhsEvals_1
          reachedMaxEvents_1)

        (SundialsDiagnostics
          numSteps_2
          numStepAttempts_2
          numRhsEvals_fe_2
          numRhsEvals_fi_2
          numLinSolvSetups_2
          numErrTestFails_2
          numNonlinSolvIters_2
          numNonlinSolvConvFails_2
          numJacEvals_2
          numRhsEvals_2
          reachedMaxEvents_2)

      = SundialsDiagnostics
          (numSteps_2 + numSteps_1)
          (numStepAttempts_2 + numStepAttempts_1)
          (numRhsEvals_fe_2 + numRhsEvals_fe_1)
          (numRhsEvals_fi_2 + numRhsEvals_fi_1)
          (numLinSolvSetups_2 + numLinSolvSetups_1)
          (numErrTestFails_2 + numErrTestFails_1)
          (numNonlinSolvIters_2 + numNonlinSolvIters_1)
          (numNonlinSolvConvFails_2 + numNonlinSolvConvFails_1)
          (numJacEvals_2 + numJacEvals_1)
          (numRhsEvals_2 + numRhsEvals_1)
          (reachedMaxEvents_1 || reachedMaxEvents_2)

instance Monoid SundialsDiagnostics
  where
    mempty = SundialsDiagnostics 0 0 0 0 0 0 0 0 0 0 False

data SundialsSolution =
  SundialsSolution
  { actualTimeGrid :: VS.Vector Double    -- ^ actual time grid returned by the solver (with duplicated event times)
  , solutionMatrix :: Matrix Double       -- ^ matrix of solutions: each column is an unknwown
  , diagnostics    :: SundialsDiagnostics -- ^ usual Sundials diagnostics
  }

data ErrorDiagnostics = ErrorDiagnostics
  { errorCode :: !Int
    -- ^ The numeric error code. Mostly useless at this point, since it is
    -- set to 1 under most error conditions. See 'solveOdeC'.
  , errorEstimates :: !(VS.Vector Double)
    -- ^ The local error estimates as returned by @CVodeGetEstLocalErrors@.
    -- Either an empty vector, or has the same dimensionality as the state
    -- space.
  , varWeights :: !(VS.Vector Double)
    -- ^ The weights with which errors are combined, equal to @1 / (atol_i + y_i * rtol)@.
    -- Either an empty vector, or has the same dimensionality as the state
    -- space.
  , partialResults :: !(Matrix Double)
    -- ^ Partial solution of the ODE system, up until the moment when
    -- solving failed. Contains the time as its first column.
  } deriving Show

-- | The direction in which a function should cross the x axis
data CrossingDirection = Upwards | Downwards | AnyDirection
  deriving (Generic, Eq, Show, NFData)

-- | A time-based event, implemented as an action that returns the time of
-- the next time-based event.
--
-- If there's an additional condition attached to a time-based event, it
-- should be verified in the event handler.
--
-- The action is supposed to be stateful, and the state of the action
-- should be updated by the event handler so that after a given time-based
-- event is handled, the action starts returning the time of the next
-- unhandled time-based event.
--
-- If there is no next time-based event, the action should return +Inf.
newtype TimeEventSpec = TimeEventSpec (IO Double)

sunTypesTable :: Map.Map TypeSpecifier TH.TypeQ
sunTypesTable = Map.fromList
  [
    (TypeName "sunindextype", [t| SunIndexType |] )
  , (TypeName "realtype",     [t| SunRealType |] )
  , (TypeName "N_Vector",     [t| Ptr SunVector |] )
  , (TypeName "SUNMatrix",    [t| Ptr SunMatrix |] )
  , (TypeName "UserData",     [t| UserData |] )
  ]

-- | Allows to map between Haskell and C types
sunCtx :: Context
sunCtx = mempty {ctxTypesTable = sunTypesTable}


{-# LANGUAGE RecordWildCards #-}

module Statistics.Block
    ( BlockHeader (..)
    , blockHeadersF
    , blockChain
    , blockChainF
    , txBlocksF
    , inBlockChainF
    , txCntInChainF
    , TxFate (..)
    , txFateF
    ) where

import           Control.Foldl (Fold (..), fold)
import qualified Data.Map.Lazy as ML
import qualified Data.Map.Strict as MS
import           Data.Maybe (fromJust, isJust)
import qualified Data.Set as S
import qualified Data.Text as T
import           Data.Time.Units (Microsecond)

import           JSONLog (IndexedJLTimedEvent (..))
import           Pos.Infra.Util.JsonLog.Events (JLBlock (..), JLEvent (..))
import           Prelude (id)
import           Statistics.Tx (txFirstReceivedF)
import           Types
import           Universum hiding (fold)

data BlockHeader = BlockHeader
    { bhNode      :: !NodeId
    , bhTimestamp :: !Timestamp
    , bhHash      :: !BlockHash
    , bhPrevBlock :: !BlockHash
    , bhSlot      :: !Slot
    , bhTxCnt     :: !Int
    } deriving Show

type SMap k a = MS.Map k a
type LMap k a = ML.Map k a

blockHeadersF :: Fold IndexedJLTimedEvent (SMap BlockHash BlockHeader)
blockHeadersF = Fold step MS.empty id
  where
    step :: SMap Text BlockHeader -> IndexedJLTimedEvent -> SMap Text BlockHeader
    step m IndexedJLTimedEvent{..} = case ijlEvent of
        JLCreatedBlock JLBlock{..} ->
            let bh = BlockHeader
                    { bhNode      = ijlNode
                    , bhTimestamp = ijlTimestamp
                    , bhHash      = jlHash
                    , bhPrevBlock = jlPrevBlock
                    , bhSlot      = jlSlot
                    , bhTxCnt     = length jlTxs
                    }
            in MS.insert jlHash bh m

        _                          -> m

blockChain :: SMap BlockHash BlockHeader -> Set BlockHash
blockChain m = S.fromList $ maybe [] id $ (fmap fst . uncons) $ sortByLengthDesc [getLongestChain h | h <- allHashes]
  where
    allHashes :: [BlockHash]
    allHashes = MS.keys m

    sortByLengthDesc :: [[a]] -> [[a]]
    sortByLengthDesc = sortBy (compare `on` (negate . length))

    successors :: SMap BlockHash [BlockHash]
    successors = foldl' f MS.empty allHashes

    getSuccessors :: BlockHash -> [BlockHash]
    getSuccessors h = MS.findWithDefault [] h successors

    f :: SMap BlockHash [BlockHash] -> BlockHash -> SMap BlockHash [BlockHash]
    f s h = let BlockHeader{..} = m MS.! h
            in  MS.alter (Just . maybe [bhHash] (bhHash :)) bhPrevBlock s

    longestChains :: LMap Text [Text]
    longestChains = ML.fromList [(h, getLongestChain h) | h <- allHashes]

    getLongestChain :: Text -> [Text]
    getLongestChain h = case sortByLengthDesc $ map (longestChains ML.!) $ getSuccessors h of
        []      -> [h]
        (c : _) -> h : c

blockChainF :: Fold IndexedJLTimedEvent (Set BlockHash)
blockChainF = blockChain <$> blockHeadersF

txBlocksF :: Fold IndexedJLTimedEvent (SMap TxHash [(Timestamp, BlockHash)])
txBlocksF = Fold step MS.empty id
  where
    step :: SMap Text [(Microsecond, Text)]
         -> IndexedJLTimedEvent
         -> SMap Text [(Microsecond, Text)]
    step m IndexedJLTimedEvent{..} = case ijlEvent of
        JLCreatedBlock JLBlock{..} -> foldl' (f ijlTimestamp jlHash) m [T.take 16 x | x <- jlTxs]
        _                          -> m

    f :: Timestamp
      -> Text
      -> SMap Text [(Timestamp, Text)]
      -> Text
      -> SMap Text [(Timestamp, Text)]
    f ts h m tx = let y = (ts, h)
                  in  MS.alter (Just . maybe [y] (y :)) tx m

inBlockChainF :: Fold IndexedJLTimedEvent (SMap TxHash Timestamp)
inBlockChainF = f <$> txFateF
  where
    f :: SMap TxHash TxFate -> SMap TxHash Timestamp
    f = MS.map fromJust . MS.filter isJust .  MS.map txInBlockChain

txCntInChainF :: Fold IndexedJLTimedEvent [(NodeId, Timestamp, Int)]
txCntInChainF = f <$> blockHeadersF <*> blockChainF
  where
    f :: Map BlockHash BlockHeader -> Set BlockHash -> [(NodeId, Timestamp, Int)]
    f m cs = [(bhNode, bhTimestamp, bhTxCnt) | (_, BlockHeader{..}) <- MS.toList m, bhHash `S.member` cs]

data TxFate =
      InNoBlock
    | InBlockChain !Timestamp !BlockHash !(Set (Timestamp, BlockHash))
    | InFork !(Set (Timestamp, BlockHash))
    deriving Show

txInBlockChain :: TxFate -> Maybe Timestamp
txInBlockChain InNoBlock             = Nothing
txInBlockChain (InBlockChain ts _ _) = Just ts
txInBlockChain (InFork _)            = Nothing

txFateF :: Fold IndexedJLTimedEvent (SMap TxHash TxFate)
txFateF = f <$> txFirstReceivedF <*> txBlocksF <*> blockChainF
  where
    f :: SMap TxHash Timestamp -> SMap TxHash [(Timestamp, BlockHash)] -> Set BlockHash -> SMap TxHash TxFate
    f received blocks chain = MS.fromList [(tx, fate tx) | tx <- MS.keys received]
      where
        fate :: TxHash -> TxFate
        fate tx = case MS.lookup tx blocks of
            Nothing -> InNoBlock
            Just xs -> fold (Fold step (Nothing, S.empty) extract) xs

        step :: (Maybe (Timestamp, BlockHash), Set (Timestamp, BlockHash))
             -> (Timestamp, BlockHash)
             -> (Maybe (Timestamp, BlockHash), Set (Timestamp, BlockHash))
        step (Nothing, s) (ts, h)
            | S.member h chain = (Just (ts, h), s)
            | otherwise        = (Nothing     , S.insert (ts, h) s)
        step (p      , s) q    = (p           , S.insert q       s)

        extract :: (Maybe (Timestamp, BlockHash), Set (Timestamp, BlockHash)) -> TxFate
        extract (Nothing     , s) = InFork s
        extract (Just (ts, h), s) = InBlockChain ts h s