deepseq-bounded-0.7.0.1: src/Control/DeepSeq/Bounded/NFDataP.hs
-------------------------------------------------------------------------------
{- 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.7.0.1/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.7.0.1/docs/Control-DeepSeq-Bounded-NFDataPDyn.html NFDataPDyn> /should get attention.) /
--
-------------------------------------------------------------------------------
module Control.DeepSeq.Bounded.NFDataP
(
-- * Pattern-bounded analogues of 'deepseq' and 'force'
deepseqp, forcep -- take String arg (pattern DSL)
-- * Avoid DSL compilation overhead
--
-- However, we don't anticipate that this overhead would be
-- significant in most applications, because using <deepseq-bounded>
-- in a tight loop would only be done for diagnostic purposes.
, deepseqp_, forcep_ -- take Pattern structure arg
-- * 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 $!!
-------------------------------------------------------------------------------
-- 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). /
--
-- / 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.
#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.
#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.
#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
-------------------------------------------------------------------------------
#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
-------------------------------------------------------------------------------