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