deepseq-bounded-0.6.0.0: src/Control/DeepSeq/Bounded/NFDataP_old_grammar.hs
-------------------------------------------------------------------------------
{- LANGUAGE CPP #-}
#define DO_TRACE 0
-- XXX Note: Show constraints are for debugging purposes.
#define INCLUDE_SHOW_INSTANCES 0
-- Formerly DEBUG_WITH_DEEPSEQ_GENERICS.
-- Now also needed to force issuance of all compilePat warnings
-- (so not strictly a debugging flag anymore).
-- [Except it didn't work...]
--- #define NFDATA_INSTANCE_PATTERN 1 -- now it's a .cabal flag
-- Now specified via --flag=[-]USE_WWW_DEEPSEQ
--- #define USE_WW_DEEPSEQ 1
-------------------------------------------------------------------------------
-- For tracing only:
{- LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
-------------------------------------------------------------------------------
-- |
-- Module : Control.DeepSeq.Bounded.NFDataP_old_grammar
-- Copyright : Andrew G. Seniuk 2014-2015
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Andrew Seniuk <rasfar@gmail.com>
-- Stability : provisional
-- Portability : portable
--
{--}
-- (Top-level comments are in NFDataP.hs.)
-------------------------------------------------------------------------------
module Control.DeepSeq.Bounded.NFDataP_old_grammar
where
-------------------------------------------------------------------------------
import Control.DeepSeq.Bounded.Pattern
import Control.DeepSeq.Bounded.Compile
import Control.DeepSeq.Bounded.PatUtil ( unionPats, liftPats )
import Control.DeepSeq.Bounded.NFDataN -- finally used ("*3" etc.)
#if USE_WW_DEEPSEQ
import Control.DeepSeq ( NFData )
import Control.DeepSeq ( rnf )
#endif
--import Data.Data -- "redundant" last checked
import Data.Typeable ( Typeable )
#if 1
import Data.Typeable ( typeOf )
#else
-- XXX These are NOT interchangeable!
#if __GLASGOW_HASKELL__ >= 781
import Data.Typeable ( typeRep )
#else
import Data.Typeable ( typeOf )
#endif
#endif
import Data.Typeable ( mkTyCon3, mkTyConApp )
import Data.Typeable ( typeRepTyCon )
#if PARALLELISM_EXPERIMENT
import Control.Parallel ( par )
#endif
import Data.Int
import Data.Word
import Data.Ratio
import Data.Complex
import Data.Array
import Data.Fixed
import Data.Version
import Data.Maybe ( Maybe(..), isJust, fromJust )
import System.IO.Unsafe ( unsafePerformIO )
import Debug.Trace ( trace )
-------------------------------------------------------------------------------
#if DO_TRACE
mytrace = trace
#else
mytrace _ = id
#endif
-------------------------------------------------------------------------------
--infixr 0 $!!
-------------------------------------------------------------------------------
-- XXX NOTE: These need to return Maybe __, in order to handle
-- patterns rooted at a WI (i.e. "#" or equivalent "#{...}").
-- Since don't want to do that by default, will simply make
-- it a DSL compilePat error...
-- XXX NOTE TO SELF: These comments are verbatim from Control.DeepSeq:
-- | 'deepseqp': evaluates the first argument to the depth specified
-- by a 'Pattern', before returning the second.
--
-- Quoting from the DeepSeq.hs (deepseq package):
--
-- / \"'deepseq' can be useful for forcing pending exceptions, eradicating space leaks, or forcing lazy I\/O to happen. It is also useful in conjunction with parallel Strategies (see the @parallel@ package). /
--
-- / There is no guarantee about the ordering of evaluation. The implementation may evaluate the components of the structure in any order or in parallel. To impose an actual order on evaluation, use 'pseq' from "Control.Parallel" in the @parallel@ package.\" /
--
-- Composition fuses (see 'deepseqp_').
{--} -- XXX LATER: This is flawed for # at root of pattern.
#if INCLUDE_SHOW_INSTANCES
deepseqp :: (Show a, NFDataP a) => String -> a -> b -> b
#else
deepseqp :: NFDataP a => String -> a -> b -> b
#endif
#if 0
#elif 0
deepseqp patstr a b = fromJust $ deepseqp_ (compilePat patstr) a b
--deepseqp patstr = fromJust $ deepseqp_ (compilePat patstr)
#elif 1
deepseqp patstr = deepseqp_ (compilePat patstr)
#elif 0
deepseqp patstr a b = rnfp (compilePat patstr) a `seq` b
-- XXX Partially-applied; is that okay in GHC RULES?
{-# RULES
"deepseqp/composition" forall p1 p2 x. (.) (deepseqp p2) (deepseqp p1) x = deepseqp_ ( unionPats [compilePat p1, compilePat p2] ) x
#-}
#endif
-- | Self-composition fuses via
--
-- @
-- "deepseqp_/composition"
-- forall p1 p2 x1 x2.
-- (.) ('deepseqp_' p2 x2) ('deepseqp_' p1 x1)
-- = 'deepseqp_' ( 'liftPats' [p1, p2] ) (x1,x2)
-- @
--
-- (Other fusion rules, not yet documented, may also be in effect.)
{--}
-- XXX Oh! We have a fundamental problem here!
-- I realised that
-- forcep "#" (undefined::Int)
-- was bottoming out. Then sought to repair that by "doing nothing"
-- if WI etc. here, as in rnfp.
-- However, how can we return type b, and "do nothing"?
-- - if go "`seq` b" does this not force b?
-- (don't see why it should actually)
-- - if go "`seq` ()", this is a type error for deepseqp
-- - if go "`seq` (undefined::b)", this defeats the purpose, as we
-- precisely do not want to hit bottom... still, this might be
-- a possible way, if can do it right....
-- - if go "`seq` defaultValue_in_type_b" -- this is never acceptable
-- in library code...
-- - we CAN return Maybe b! This is, after all, deepseqp_
-- Can decide how to cope with that in the caller.
-- But at least the need to return type b here is lifted...
-- As for the RULES, I think they're not ready to use now...
-- XXX LATER: This is flawed for # at root of pattern.
-- Maybe not quite flawed, just "untestable" if there's bottom at
-- the root of the value (that is to say, the value is (undefined::b).
#if INCLUDE_SHOW_INSTANCES
deepseqp_ :: (Show a, NFDataP a) => Pattern -> a -> b -> b
#else
deepseqp_ :: NFDataP a => Pattern -> a -> b -> b
#endif
#if 0
#elif 0
deepseqp_ pat@(Node WI _) _ b = b
deepseqp_ pat@(Node (TR treps) chs) a b = if elem ta treps then doit `seq` b else b
where ta = show $ typeRepTyCon $ typeOf a
doit = rnfp pat a `seq` b
deepseqp_ pat@(Node (TI treps) chs) a b = if elem ta treps then b else doit `seq` b
where ta = show $ typeRepTyCon $ typeOf a
doit = rnfp pat a `seq` b
deepseqp_ pat a b = rnfp pat a `seq` b
#elif 1
deepseqp_ pat a b = rnfp pat a `seq` b
-- XXX Need to double-check that this makes sense; didn't think
-- it through -- when b != a, things are not so simple.
-- XXX Partially-applied; is that okay in GHC RULES?
{-# RULES
"deepseqp_/composition" forall p1 p2 x1 x2. (.) (deepseqp_ p2 x2) (deepseqp_ p1 x1) = deepseqp_ ( liftPats [p1, p2] ) (x1,x2)
#-}
-- "deepseqp_/composition" forall p1 p2 x. (.) (deepseqp_ p2) (deepseqp_ p1) x = deepseqp_ ( unionPats [p1, p2] ) x
#endif
-- | Lifted result, so can cope with undefined values and
-- still take the head in the caller (if call is after 'seq' or '$!'
-- for instance).
#if INCLUDE_SHOW_INSTANCES
deepseqpM :: (Show a, NFDataP a) => String -> a -> b -> Maybe b
#else
deepseqpM :: NFDataP a => String -> a -> b -> Maybe b
#endif
deepseqpM patstr a b = deepseqpM_ (compilePat patstr) a b
#if INCLUDE_SHOW_INSTANCES
deepseqpM_ :: (Show a, NFDataP a) => Pattern -> a -> b -> Maybe b
#else
deepseqpM_ :: NFDataP a => Pattern -> a -> b -> Maybe b
#endif
deepseqpM_ pat@(Node WI _) _ _ = Nothing
deepseqpM_ pat@(Node (TR treps) chs) a b = if elem ta treps then doit `seq` Just b else Nothing
where ta = show $ typeRepTyCon $ typeOf a
doit = rnfp pat a `seq` b
deepseqpM_ pat@(Node (TI treps) chs) a b = if elem ta treps then Nothing else doit `seq` Just b
where ta = show $ typeRepTyCon $ typeOf a
doit = rnfp pat a `seq` b
deepseqpM_ pat a b = rnfp pat a `seq` Just b
-------------------------------------------------------------------------------
#if 0
-- | the deep analogue of '$!'. In the expression @f $!! x@, @x@ is
-- fully evaluated before the function @f@ is applied to it.
($!!) :: (NFData a) => (a -> b) -> a -> b
f $!! x = x `deepseq` f x
#endif
-- | A variant of 'deepseqp' that is sometimes convenient:
--
-- > forcep pat x = 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@. Note that @forcep pat x@ only takes effect
-- when the value of @forcep pat x@ itself is demanded, so essentially
-- it turns shallow evaluation into evaluation to arbitrary bounded depth.
--
-- Composition fuses (see 'forcep_').
{--}
-- XXX What about mixed cases??...
-- XXX LATER: This is flawed for # at root of pattern.
#if INCLUDE_SHOW_INSTANCES
forcep :: (Show a, NFDataP a) => String -> a -> a
#else
forcep :: NFDataP a => String -> a -> a
#endif
#if 0
#elif 0
forcep patstr x
| p = fromJust ma
-- | otherwise = error "here"
| otherwise = undefined::a
where ma = deepseqp_ (compilePat patstr) x x
p = isJust ma
#elif 0
forcep patstr x = fromJust $ deepseqp_ (compilePat patstr) x x
#elif 0
forcep patstr x
| b = x
| otherwise = fromJust y
where y = deepseqp_ (compilePat patstr) x (Just x)
pat@(Node p chs) = compilePat patstr
b | WI <- p = True
| TR _ <- p = True
| TN _ _ <- p = True
| TW _ <- p = True
| TI _ <- p = True
| otherwise = False
#elif 1
forcep patstr x = deepseqp_ (compilePat patstr) x x
--forcep patstr x = deepseqp patstr x x
{-# RULES
"forcep/composition" forall p1 p2 x. (.) (forcep p2) (forcep p1) x = forcep_ ( unionPats [compilePat p1, compilePat p2] ) x
#-}
#endif
-- | Self-composition fuses via
--
-- @
-- "forcep_/composition"
-- forall p1 p2 x.
-- (.) ('forcep_' p2) ('forcep_' p1) x
-- = 'forcep_' ( 'unionPats' [p1, p2] ) x
-- @
--
-- (Other fusion rules, not yet documented, may also be in effect.)
{--}
-- XXX LATER: This is flawed for # at root of pattern.
#if INCLUDE_SHOW_INSTANCES
forcep_ :: (Show a, NFDataP a) => Pattern -> a -> a
#else
forcep_ :: NFDataP a => Pattern -> a -> a
#endif
#if 0
forcep_ pat x = fromJust $ deepseqp_ pat x x
#else
forcep_ pat x = deepseqp_ pat x x
{-# RULES
"forcep_/composition" forall p1 p2 x. (.) (forcep_ p2) (forcep_ p1) x = forcep_ ( unionPats [p1, p2] ) x
#-}
#endif
-- | Lifted result, so can cope with undefined values and
-- still take the head in the caller (if call is after 'seq' or '$!'
-- for instance).
#if INCLUDE_SHOW_INSTANCES
forcepM :: (Show a, NFDataP a) => String -> a -> Maybe a
#else
forcepM :: NFDataP a => String -> a -> Maybe a
#endif
forcepM patstr a = forcepM_ (compilePat patstr) a
#if INCLUDE_SHOW_INSTANCES
forcepM_ :: (Show a, NFDataP a) => Pattern -> a -> Maybe a
#else
forcepM_ :: NFDataP a => Pattern -> a -> Maybe a
#endif
forcepM_ pat x = deepseqpM_ pat x x
-------------------------------------------------------------------------------
-- | A class of types that can be evaluated over an arbitrary finite pattern.
#if USE_WW_DEEPSEQ
class (Typeable a, NFDataN a, NFData a) => NFDataP a where
#else
class (Typeable a, NFDataN a) => NFDataP a where
#endif
-- | Self-composition fuses via
--
-- @
-- "rnfp/composition"
-- forall p1 p2 x.
-- (.) ('rnfp' p2) ('rnfp' p1) x
-- = 'rnfp' ( 'unionPats' [p1, p2] ) x
-- @
--
-- (Other fusion rules, not yet documented, may also be in effect.)
{- NOINLINE rnfp #-}
#if INCLUDE_SHOW_INSTANCES
rnfp :: Show a => Pattern -> a -> ()
#else
rnfp :: Pattern -> a -> ()
#endif
rnfp (Node WI _) _ = ()
rnfp (Node (TR treps) chs) d = if elem td treps then d `seq` () else ()
where td = show $ typeRepTyCon $ typeOf d
rnfp (Node (TI treps) chs) d = if elem td treps then () else d `seq` ()
where td = show $ typeRepTyCon $ typeOf d
#if 1
rnfp _ d = d `seq` ()
-- rnfp _ _ = ()
#else
-- XXX temporarily (at least) commenting out; not making any
-- use of patternShapeOK -- but there is room for more
-- error-trapping code in here, definitely...
rnfp pat a | not $ patternShapeOK pat a = ()
| otherwise = rnf a
#endif
{-# RULES
"rnfp/composition" forall p1 p2 x. (.) (rnfp p2) (rnfp p1) x = rnfp ( unionPats [p1, p2] ) x
#-}
-- "rnfp/composition" forall p1 p2 x. compose (rnfp p2) (rnfp p1) x = rnfp ( unionPats [p1, p2] ) x
-- "rnfp/composition" forall p1 p2 x. ( rnfp p2 . rnfp p1 ) x = rnfp ( unionPats [p1, p2] ) x
-------------------------------------------------------------------------------
#if USE_WW_DEEPSEQ
rnfp' :: (Typeable a, NFDataN a, NFData a) => PatNode -> () -> a -> ()
#else
rnfp' :: (Typeable a, NFDataN a) => PatNode -> () -> a -> ()
#endif
-- Sig. as it was as a class method of NFDataP:
--rnfp' :: PatNode -> () -> a -> ()
rnfp' pat recurs d
-- I can only conclude that we've already evaluated the argument
-- by the time this code runs (or that we evaluate it after...).
-- But this code doesn't do the dirty deed!
= {-trace ( "rnfp' " ++ show pat) $-}
let td = show $ typeRepTyCon $ typeOf d in -- no problem on bottom
case pat of
WI -> error "rnfp: unexpected WI (please report this bug!)"
TR treps -> error "rnfp: unexpected TR (please report this bug!)"
TI treps -> error "rnfp: unexpected TI (please report this bug!)"
#if PARALLELISM_EXPERIMENT
-- XXX will this work? ... YES IT SEEMS TO!!! (Esp. evident in ghci.)
PR -> recurs `par` ()
PN n -> rnfn n d `par` ()
#if USE_WW_DEEPSEQ
PW -> rnf d `par` () -- the only place deepseq package is used
#endif
#endif
#ifdef SEQUENTIALISM_EXPERIMENT
#error Sorry, SEQUENTIALISM_EXPERIMENT is not done yet.
-- XXX Alas! This won't work, at least not according to the same method
-- as PR etc. There's no possible use in the `pseq` () section!
-- (Unlike `par` (), which is already working for parallel speedup.)
-- So, SEQUENTIALISM_EXPERIMENT may be the one where we would need
-- to edit all the instances individually... This again raises the
-- question of how we handle higher-arity nodes? It makes no sense
-- (unlike parallel) to pseq just one sibling. If you pseq a subset
-- of siblings, their subharnesses will be sequenced, yes (and the
-- remainder will be order-free).
-- Unfortunately, to express this is not easy (unlike for parallel).
-- So, this is on hold for the time being.
-- SR -> recurs `pseq` ()
#endif
WR -> recurs
WS -> ()
-- WS -> d `seq` ()
WN n -> rnfn n d
#if USE_WW_DEEPSEQ
WW -> rnf d -- the only place deepseq package is used
#endif
-- This code stays the same whether we (are able to) compare
-- actual TypeRep's for equality, or we just hack it
-- and match: show . typeRepTyCon . typeOf
TR treps -> if elem td treps then recurs else ()
#if 0
-- This is not right. To pull this off (b/c it depends on
-- types in the value your matching with), need to construct
-- the pattern dynamically. In particular, to produce Nil
-- where a TR (or TS) constraint causes (or would cause)
-- match failure.
TS treps -> if elem td treps then () else ()
#endif
TN n treps -> if elem td treps then rnfn n d else ()
#if USE_WW_DEEPSEQ
TW treps -> if elem td treps then rnf d else ()
#endif
#if 0
NTR treps -> if not $ elem td treps then recurs else ()
NTN n treps -> if not $ elem td treps then rnfn n d else ()
#if USE_WW_DEEPSEQ
NTW treps -> if not $ elem td treps then rnf d else ()
#endif
#endif
_ -> error "rnfp: Unexpected constructor!"
-------------------------------------------------------------------------------
#if 0
compose = (.)
{-# NOINLINE compose #-}
-- Can't do this, unfortunately. GHC warns it may get inlined before
-- rules have a chance to fire. I would rather avoid forcing the API
-- user to use some custom "compose" function, since base (.) works
-- perfectly, except it's hard to control its inlining...
{- NOINLINE (.) #-}
#endif
-------------------------------------------------------------------------------
instance NFDataP Int
instance NFDataP Word
instance NFDataP Integer
instance NFDataP Float
instance NFDataP Double
instance NFDataP Char
#if 0
-- (testing something or other)
instance NFDataP Bool
where
rnfp (Node WI _) _ = ()
rnfp _ d = d `seq` ()
#else
instance NFDataP Bool
#endif
instance NFDataP ()
instance NFDataP Int8
instance NFDataP Int16
instance NFDataP Int32
instance NFDataP Int64
instance NFDataP Word8
instance NFDataP Word16
instance NFDataP Word32
instance NFDataP Word64
-------------------------------------------------------------------------------
instance Typeable a => NFDataP (Fixed a)
--instance NFDataP (Fixed a)
-------------------------------------------------------------------------------
-- [Quoted from deepseq:]
-- This instance is for convenience and consistency with 'seq'.
-- This assumes that WHNF is equivalent to NF for functions.
instance (Typeable a, Typeable b) => NFDataP (a -> b)
--instance NFDataP (a -> b)
-------------------------------------------------------------------------------
#if 0
-- XXX ignore if in IO (cludge easing an experiment...)
#if USE_WW_DEEPSEQ
instance NFData a => NFData (IO a) where
rnf x = () -- XXX ignore if in IO (cludge easing an experiment...)
#endif
instance NFDataP a => NFDataP (IO a) where
rnfp pat x = () -- XXX ignore if in IO (cludge easing an experiment...)
#endif
-------------------------------------------------------------------------------
--Rational and complex numbers.
-- not taken to be a level of depth
#if INCLUDE_SHOW_INSTANCES
instance (Show a, Integral a, NFDataP a) => NFDataP (Ratio a) where
#else
instance (Integral a, NFDataP a) => NFDataP (Ratio a) where
#endif
-- XXX This is very dubious!...
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp pat x = rnfp pat (numerator x, denominator x)
-- Note that (Complex a) constructor (:+) has strict fields,
-- so unwrapping the ctor also forces both components.
#if INCLUDE_SHOW_INSTANCES
instance (Show a, RealFloat a, NFDataP a) => NFDataP (Complex a) where
#else
instance (RealFloat a, NFDataP a) => NFDataP (Complex a) where
#endif
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) d
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
2 -> let [px,py] = chs ; (x:+y) = d
in rnfp px x
`seq` rnfp py y
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "(Complex a)" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d -- unreachable
-- XXX Never until now (so much later) did I properly consider how to
-- handle a no-arg (nullary) constructor! It's not hard, but it's
-- significantly different than the other cases, as there's no
-- subvalue we can grab hold of -- there's no "d"; so this invalidates
-- all the code, in the posary (complement of nullary, coinage :) case
-- case, which references d.
#if INCLUDE_SHOW_INSTANCES
instance (Show a, NFDataP a) => NFDataP (Maybe a) where
#else
instance NFDataP a => NFDataP (Maybe a) where
#endif
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) Nothing
| not $ null chs = pat_match_fail
| otherwise = ()
where
pat_match_fail = patMatchFail' "Nothing" pat chs ()
rnfp (Node pat chs) (Just d)
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
1 -> let [p_J] = chs
in rnfp p_J d
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "Just" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d -- unreachable
#if INCLUDE_SHOW_INSTANCES
instance (Show a, Show b, NFDataP a, NFDataP b) => NFDataP (Either a b) where
#else
instance (NFDataP a, NFDataP b) => NFDataP (Either a b) where
#endif
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) (Left d)
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
1 -> let [p_L] = chs ;
in rnfp p_L d
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "Left" pat chs d
-- pat_match_fail = patMatchFail' "(Either a b)" pat chs d
rnfp (Node pat chs) (Right d)
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
1 -> let [p_R] = chs
in rnfp p_R d
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "Right" pat chs d
-- pat_match_fail = patMatchFail' "(Either a b)" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d -- unreachable
--- #if __GLASGOW_HASKELL__ < 781
--- -- requires -XStandaloneDeriving
--- -- orphan instance, but better than dropping support
--- -- (It seems it already has its Show instance!)
--- deriving instance Data Data.Version.Version
--- #endif
--deriving instance Data TypeRep -- can't b/c not all data ctors are in scope!
-- Data.Version ctor does /not/ have strict fields.
instance NFDataP Data.Version.Version where
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) d
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
2 -> let [pbr,ptags] = chs ; Data.Version.Version branch tags = d
in rnfp pbr branch
`seq` rnfp ptags tags
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "Data.Version.Version" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d -- unreachable
-- Data.List ctors do /not/ have strict fields (i.e. (:) is not strict).
#if INCLUDE_SHOW_INSTANCES
instance (Show a, NFDataP a) => NFDataP [a] where
#else
instance NFDataP a => NFDataP [a] where
#endif
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp _ [] = () -- perhaps dubious?...
rnfp (Node pat chs) d
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
2 -> let [px,pxs] = chs ; (x:xs) = d
in rnfp px x
`seq` rnfp pxs xs
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "[a]" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d -- unreachable
-- Data.Array ctor does /not/ have strict fields.
-- not taken to be a level of depth
#if INCLUDE_SHOW_INSTANCES
instance (Show a, Show b, Ix a, NFDataP a, NFDataP b) => NFDataP (Array a b) where
#else
instance (Ix a, NFDataP a, NFDataP b) => NFDataP (Array a b) where
#endif
-- XXX This is very dubious!...
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp pat x = rnfp pat (bounds x, Data.Array.elems x)
`seq` () -- needed?
#if INCLUDE_SHOW_INSTANCES
instance (Show a,Typeable a,NFDataP a, Show b,Typeable b,NFDataP b) => NFDataP (a,b) where
#else
instance (Typeable a,NFDataP a, Typeable b,NFDataP b) => NFDataP (a,b) where
#endif
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) d
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
2 -> let [px,py] = chs ; (x,y) = d
in rnfp px x
`seq` rnfp py y
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "(,)" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d -- unreachable
#if INCLUDE_SHOW_INSTANCES
instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c) => NFDataP (a,b,c) where
#else
instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c) => NFDataP (a,b,c) where
#endif
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) d
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
3 -> {-trace "WWW" $-} let [px,py,pz] = chs ; (x,y,z) = d
in ({-trace "XXX" $-} rnfp px x)
`seq` ({-trace "YYY" $-} rnfp py y)
-- This WILL change the semantics unfortunately...
-- `seq` (trace ("YYY "++show py++" "++show y) $ rnfp py y)
`seq` ({-trace "ZZZ" $-} rnfp pz z)
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "(,,)" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d -- unreachable
#if INCLUDE_SHOW_INSTANCES
instance (Show a, Typeable a, NFDataP a, Show b, Typeable b, NFDataP b, Show c, Typeable c, NFDataP c, Show d, Typeable d, NFDataP d) => NFDataP (a,b,c,d) where
#else
instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d) => NFDataP (a,b,c,d) where
#endif
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) d
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
4 -> let [px1,px2,px3,px4] = chs ; (x1,x2,x3,x4) = d
in rnfp px1 x1
`seq` rnfp px2 x2
`seq` rnfp px3 x3
`seq` rnfp px4 x4
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "(,,,)" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d
#if INCLUDE_SHOW_INSTANCES
instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5) =>
#else
instance (Typeable a1, NFDataP a1, Typeable a2, NFDataP a2, Typeable a3, NFDataP a3, Typeable a4, NFDataP a4, Typeable a5, NFDataP a5) =>
#endif
NFDataP (a1, a2, a3, a4, a5) where
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) d
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
5 -> let [px1,px2,px3,px4,px5] = chs ; (x1,x2,x3,x4,x5) = d
in rnfp px1 x1
`seq` rnfp px2 x2
`seq` rnfp px3 x3
`seq` rnfp px4 x4
`seq` rnfp px5 x5
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "(,,,,)" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d
#if INCLUDE_SHOW_INSTANCES
instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5, Show a6, Typeable a6, NFDataP a6) =>
#else
instance (Typeable a1, NFDataP a1, Typeable a2, NFDataP a2, Typeable a3, NFDataP a3, Typeable a4, NFDataP a4, Typeable a5, NFDataP a5, Typeable a6, NFDataP a6) =>
#endif
NFDataP (a1, a2, a3, a4, a5, a6) where
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) d
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
6 -> let [px1,px2,px3,px4,px5,px6] = chs ; (x1,x2,x3,x4,x5,x6) = d
in rnfp px1 x1
`seq` rnfp px2 x2
`seq` rnfp px3 x3
`seq` rnfp px4 x4
`seq` rnfp px5 x5
`seq` rnfp px6 x6
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "(,,,,,)" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d
#if INCLUDE_SHOW_INSTANCES
instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5, Show a6, Typeable a6, NFDataP a6, Show a7, Typeable a7, NFDataP a7) =>
#else
instance (Typeable a1, NFDataP a1, Typeable a2, NFDataP a2, Typeable a3, NFDataP a3, Typeable a4, NFDataP a4, Typeable a5, NFDataP a5, Typeable a6, NFDataP a6, Typeable a7, NFDataP a7) =>
#endif
NFDataP (a1, a2, a3, a4, a5, a6, a7) where
{- NOINLINE rnfp #-}
rnfp (Node WI _) _ = ()
rnfp (Node pat chs) d
| TR treps <- pat = if elem td treps then recurs else ()
| TI treps <- pat = if elem td treps then () else recurs
| otherwise = rnfp' pat recurs d
where
td = show $ typeRepTyCon $ typeOf d
recurs = case length chs of
0 -> case pat of
WS -> ()
_ -> pat_match_fail
7 -> let [px1,px2,px3,px4,px5,px6,px7] = chs ; (x1,x2,x3,x4,x5,x6,x7) = d
in rnfp px1 x1
`seq` rnfp px2 x2
`seq` rnfp px3 x3
`seq` rnfp px4 x4
`seq` rnfp px5 x5
`seq` rnfp px6 x6
`seq` rnfp px7 x7
`seq` () -- needed?
_ -> pat_match_fail
pat_match_fail = patMatchFail' "(,,,,,,)" pat chs d
rnfp (Node pat chs) d = patMatchFail pat chs d
-- No Typeable instances for tuples larger than 7 in 7.8.1, seemingly.
#if 0
instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5, Show a6, Typeable a6, NFDataP a6, Show a7, Typeable a7, NFDataP a7, Show a8, Typeable a8, NFDataP a8) =>
NFDataP (a1, a2, a3, a4, a5, a6, a7, a8) where
rnfp Nil _ = ()
rnfp (Node pat [px1,px2,px3,px4,px5,px6,px7,px8]) d@(x1,x2,x3,x4,x5,x6,x7,x8) = rnfp' pat recurs d
where recurs = rnfp px1 x1
`seq` rnfp px2 x2
`seq` rnfp px3 x3
`seq` rnfp px4 x4
`seq` rnfp px5 x5
`seq` rnfp px6 x6
`seq` rnfp px7 x7
`seq` rnfp px8 x8
rnfp (Node pat chs) d = patMatchFail pat chs d
instance (Show a1, Typeable a1, NFDataP a1, Show a2, Typeable a2, NFDataP a2, Show a3, Typeable a3, NFDataP a3, Show a4, Typeable a4, NFDataP a4, Show a5, Typeable a5, NFDataP a5, Show a6, Typeable a6, NFDataP a6, Show a7, Typeable a7, NFDataP a7, Show a8, Typeable a8, NFDataP a8, Show a9, Typeable a9, NFDataP a9) =>
NFDataP (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
rnfp Nil _ = ()
rnfp (Node pat [px1,px2,px3,px4,px5,px6,px7,px8,px9]) d@(x1,x2,x3,x4,x5,x6,x7,x8,x9) = rnfp' pat recurs d
where recurs = rnfp px1 x1
`seq` rnfp px2 x2
`seq` rnfp px3 x3
`seq` rnfp px4 x4
`seq` rnfp px5 x5
`seq` rnfp px6 x6
`seq` rnfp px7 x7
`seq` rnfp px8 x8
`seq` rnfp px9 x9
rnfp (Node pat chs) d = patMatchFail pat chs d
#endif
-------------------------------------------------------------------------------
patMatchFail :: (Show a, Show b) => a -> b -> c -> ()
patMatchFail pat chs d
#if WARN_PATTERN_MATCH_FAILURE
= ( unsafePerformIO $! putStrLn $! "NFDataP: warning: couldn't match " ++ show pat ++ " (having children " ++ show chs ++ ")" ) `seq` ()
#else
= ()
#endif
-- = error $ "NFDataP: Couldn't match " ++ show pat ++ " (having children " ++ show chs ++ ")\nwith data " ++ show d
patMatchFail' :: (Show a, Show b) => String -> a -> b -> c -> ()
patMatchFail' inst pat chs d
#if WARN_PATTERN_MATCH_FAILURE
= ( unsafePerformIO $! putStrLn $! "NFDataP: warning: instance " ++ inst ++ ": bad PatNode child list" ) `seq` patMatchFail pat chs d
#else
= ()
#endif
-------------------------------------------------------------------------------