deepseq-bounded 0.6.2.0 → 0.7.0.0

raw patch · 28 files changed

+9005/−16693 lines, 28 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.txt +23/−9
• deepseq-bounded.cabal +10/−105
• src/Control/DeepSeq/Bounded.hs +0/−4
• src/Control/DeepSeq/Bounded/Compile.hs +523/−2
• src/Control/DeepSeq/Bounded/Compile_new_grammar.hs +0/−249
• src/Control/DeepSeq/Bounded/Compile_old_grammar.hs +0/−260
• src/Control/DeepSeq/Bounded/Compile_shared_utils.hs +0/−174
• src/Control/DeepSeq/Bounded/Compile_shared_utils2.hs +0/−344
• src/Control/DeepSeq/Bounded/Flags.hs +0/−116
• src/Control/DeepSeq/Bounded/Generic/GNFDataP.hs +376/−8
• src/Control/DeepSeq/Bounded/Generic/GNFDataP_new_grammar.hs +0/−454
• src/Control/DeepSeq/Bounded/Generic/GNFDataP_old_grammar.hs +0/−411
• src/Control/DeepSeq/Bounded/NFDataP.hs +1674/−248
• src/Control/DeepSeq/Bounded/NFDataP_new_grammar.hs +0/−1580
• src/Control/DeepSeq/Bounded/NFDataP_old_grammar.hs +0/−926
• src/Control/DeepSeq/Bounded/PatUtil.hs +1230/−129
• src/Control/DeepSeq/Bounded/PatUtil_new_grammar.hs +0/−1207
• src/Control/DeepSeq/Bounded/PatUtil_old_grammar.hs +0/−717
• src/Control/DeepSeq/Bounded/Pattern.hs +750/−99
• src/Control/DeepSeq/Bounded/Pattern_new_grammar.hs +0/−800
• src/Control/DeepSeq/Bounded/Pattern_old_grammar.hs +0/−270
• tests/Blah.hs +3322/−23
• tests/Blah98.hs +1096/−18
• tests/Blah98_new_grammar.hs +0/−1102
• tests/Blah98_old_grammar.hs +0/−1102
• tests/Blah_new_grammar.hs +0/−3326
• tests/Blah_old_grammar.hs +0/−3000
• tests/Tests.hs +1/−10

@@ -1,13 +1,24 @@ -NOTE: My real "changelog" (a private document) is-over 8000 lines long, and I haven't really taken pains-to assure that this summary is complete.--The transition-5-6-7.html file probably contains better-information. It is in the ./HTML directory of the source-distribution, or online at-http://www.fremissant.net/deepseq-bounded/transition-5-6-7.html-(most up to date).+** 0.6.2.0 -> 0.7.0.0+ - although slated for early March, I'm just going ahead+   and releasing 0.7 now, which finalises the grammar, and+   largely closes the book on the first volume of this enterprise+ - plans from here to version 1.0:+    - definitely get rid of the T* nodes, and just rely on the attribute+    - still undecided to refactor PatNode as product instead of sum...+       - if do refactor, it'll be easier with T* nodes absorbed+    - if I can get better test suites in there, that would be swell+    - if things pass thorough testing, that will bring me to 0.8+       - in case a major bump itch was pending for any reason,+         NOW's the time to pull the bumper, rather than later!+    - between 0.8 and 1.0, there needs to be work on Seqable+       - though maybe there's not much to do, since it's (A) so minimalist,+         and (B) designed for use by auto-instrumentation tools+    - so basically, if everything in deepseq-bounded has polish+      and is well-tested, there's nothing holding back 1.0 I think...+       - just go 0.9 then give it a grace period, like let's say+         two months (seeing 0.9.1 0.9.2 ...), and after that,+         when things feel right, upload whatever I've got as 1.0  0.6.1.0 -> 0.6.2.0  - everything relating to attoparsec has been ripped out@@ -54,6 +65,9 @@  - decrufting of Compile_new_grammar.hs  ** 0.5.5 -> 0.6.0.0+ - the transition-5-6-7.html file contains additional details.+    - it is in the ./HTML directory of the source distribution, or online at+      http://www.fremissant.net/deepseq-bounded/transition-5-6-7.html  - many misc. bug fixes  - much polishing of documentation (corrections, elaborations, refinements)  - renamed module "...Bounded.Generics" to "...Bounded.Generic"

@@ -2,7 +2,7 @@ -------------------------------------------------------------------------------  name:		deepseq-bounded-version:        0.6.2.0+version:        0.7.0.0 synopsis:       Bounded deepseq, including support for generic deriving license:	BSD3 license-file:	LICENSE@@ -23,8 +23,6 @@ --tested-with:    GHC==7.6.3, GHC==7.8.*, GHC==7.10.1   -- illegal syntax  description:-    /NOTE: Version 0.6.* is a transitional version. Please refer to/ <http://www.fremissant.net/deepseq-bounded/transition-5-6-7.html this page> /for details about what has changed since 0.5.5, and what's in store when bump 0.6 to 0.7./-    .     This package provides methods for partially (or fully) evaluating data     structures (\"bounded deep evaluation\").     .@@ -58,6 +56,8 @@     Recent developments supporting parallelisation control (in <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html Pattern>     and <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Seqable.html Seqable> modules) may justify renaming this library to     something which encompasses both strictness and parallelism aspects.+    .+    / NOTE: Versions >=0.6.* are substantially different from the original 0.5.* release, particularly as regards NFDataP. I should deprecate 0.5.* soon. /  extra-source-files:       README@@ -134,18 +134,6 @@ --Default: False   Manual: True -Flag PARALLELISM_EXPERIMENT-  Description: Deprecated; will be gone in 0.7. Only has any effect if NEW_IMPROVED_PATTERN_GRAMMAR is False (which is also deprecated, and will be gone in 0.7).-  Default: True---Default: False-  Manual: True--Flag NEW_IMPROVED_PATTERN_GRAMMAR-  Description: The language is about 25% less verbose with this flag set True. Set True by default since version 0.6.0.0. DEPRECATION WARNING: This flag will be removed in a major version or two, in the interests of maintainability. In case there are very early adopters out there, please update your code ASAP to use the new grammar...-  Default: True---Default: False-  Manual: True- -- Flag DEPTH_USES_INT64 --   Description: This won't be implemented for a while, probably. -- --Default: True@@ -282,30 +270,6 @@           , Control.DeepSeq.Bounded.Generic.GSeqable           , Control.DeepSeq.Bounded.NFDataPDyn -  -- temporary during NEW_IMPROVED_PATTERN_GRAMMAR transition...-  other-modules:-      Control.DeepSeq.Bounded.Flags-    , Control.DeepSeq.Bounded.Compile_shared_utils-    , Control.DeepSeq.Bounded.Compile_shared_utils2-  if flag(NEW_IMPROVED_PATTERN_GRAMMAR)-    other-modules:-        Control.DeepSeq.Bounded.Pattern_new_grammar-      , Control.DeepSeq.Bounded.Compile_new_grammar-      , Control.DeepSeq.Bounded.PatUtil_new_grammar-      , Control.DeepSeq.Bounded.NFDataP_new_grammar-    if ! flag(HASKELL98_FRAGMENT)-      other-modules:-          Control.DeepSeq.Bounded.Generic.GNFDataP_new_grammar-  else-    other-modules:-        Control.DeepSeq.Bounded.Pattern_old_grammar-      , Control.DeepSeq.Bounded.Compile_old_grammar-      , Control.DeepSeq.Bounded.PatUtil_old_grammar-      , Control.DeepSeq.Bounded.NFDataP_old_grammar-    if ! flag(HASKELL98_FRAGMENT)-      other-modules:-          Control.DeepSeq.Bounded.Generic.GNFDataP_old_grammar-   ghc-options: -optP-Wundef -fno-warn-overlapping-patterns    if flag(USE_CPPHS)@@ -333,8 +297,6 @@       -- but this could be done without the State monad (I read...). --  , mtl == 2.1.3.1     , mtl == 2.1.*--- Causes cabal configure to hang, again (was happening with cpphs dep before)!---- , mtl  ---- We don't really depend on the cpphs /library/, but installing ---- the library also installs the cpphs executable, so in case@@ -363,13 +325,10 @@   else      cpp-options: -DUSE_WW_DEEPSEQ=0 -  if flag(NEW_IMPROVED_PATTERN_GRAMMAR)-     if flag(USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS)-        cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=1-     else-        cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=0-  else+  if flag(USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS)      cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=1+  else+     cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=0    if flag(ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19)      cpp-options: -DABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19=1@@ -381,14 +340,6 @@   else      cpp-options: -DABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9=0 -  if flag(NEW_IMPROVED_PATTERN_GRAMMAR)-     cpp-options: -DPROVIDE_OLD_SHRINK_PAT=0-  else-     if flag(PROVIDE_OLD_SHRINK_PAT)-        cpp-options: -DPROVIDE_OLD_SHRINK_PAT=1-     else-        cpp-options: -DPROVIDE_OLD_SHRINK_PAT=0-   if flag(WARN_PATTERN_MATCH_FAILURE)      cpp-options: -DWARN_PATTERN_MATCH_FAILURE=1   else@@ -409,11 +360,6 @@   else      cpp-options: -DHASKELL98_FRAGMENT=0 -  if flag(NEW_IMPROVED_PATTERN_GRAMMAR)-     cpp-options: -DNEW_IMPROVED_PATTERN_GRAMMAR=1-  else-     cpp-options: -DNEW_IMPROVED_PATTERN_GRAMMAR=0- --if flag(DEPTH_USE_INT64) --   cpp-options: -DDEPTH_USE_INT64=1 --else@@ -434,18 +380,7 @@   else      cpp-options: -DUSE_PAR_SEQABLE=0 -  -- PARALLELISM_EXPERIMENT flag is deprecated (will vanish in 0.7)   if ! flag(HASKELL98_FRAGMENT)-     if flag(PARALLELISM_EXPERIMENT)-        build-depends:-            parallel == 3.2.*-        cpp-options: -DPARALLELISM_EXPERIMENT=1-     else-        cpp-options: -DPARALLELISM_EXPERIMENT=0-  else-     cpp-options: -DPARALLELISM_EXPERIMENT=0--  if ! flag(HASKELL98_FRAGMENT)      if flag(USE_PAR_PATNODE)         build-depends:             parallel == 3.2.*@@ -548,22 +483,11 @@      other-modules:       Blah98   else      other-modules:       Blah, Bottom, FooG-  if flag(NEW_IMPROVED_PATTERN_GRAMMAR)-    if flag(HASKELL98_FRAGMENT)-       other-modules:       Blah98_new_grammar-    else-       other-modules:       Blah_new_grammar-  else-    if flag(HASKELL98_FRAGMENT)-       other-modules:       Blah98_old_grammar-    else-       other-modules:       Blah_old_grammar    ghc-options: -optP-Wundef -fno-warn-overlapping-patterns    if flag(USE_CPPHS)-     ghc-options: -pgmPcpphs -optP --cpp---   ghc-options: -pgmPcpphs -optP--cpp+     ghc-options: -pgmPcpphs -optP--cpp --else --   ghc-options: -cpp @@ -634,18 +558,10 @@   else      cpp-options: -DWARN_PATTERN_MATCH_FAILURE=0 -  if flag(NEW_IMPROVED_PATTERN_GRAMMAR)-     cpp-options: -DNEW_IMPROVED_PATTERN_GRAMMAR=1-  else-     cpp-options: -DNEW_IMPROVED_PATTERN_GRAMMAR=0--  if flag(NEW_IMPROVED_PATTERN_GRAMMAR)-     if flag(USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS)-        cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=1-     else-        cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=0-  else+  if flag(USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS)      cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=1+  else+     cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=0    -- (Probably not actually referenced in the tests.)   if flag(ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19)@@ -675,17 +591,6 @@         cpp-options: -DUSE_PAR_SEQABLE=0   else      cpp-options: -DUSE_PAR_SEQABLE=0--  -- PARALLELISM_EXPERIMENT flag is deprecated (will vanish in 0.7)-  if ! flag(HASKELL98_FRAGMENT)-     if flag(PARALLELISM_EXPERIMENT)-        build-depends:-            parallel == 3.2.*-        cpp-options: -DPARALLELISM_EXPERIMENT=1-     else-        cpp-options: -DPARALLELISM_EXPERIMENT=0-  else-     cpp-options: -DPARALLELISM_EXPERIMENT=0    if ! flag(HASKELL98_FRAGMENT)      if flag(USE_PAR_PATNODE)

@@ -108,14 +108,10 @@ #endif #endif -     , module Control.DeepSeq.Bounded.Flags-   )   where  ---------------------------------------------------------------------------------  import Control.DeepSeq.Bounded.Flags  #if PROVIDE_DATA_FAMILY   -- Remarkable, this is not already in scope by re-export!

@@ -3,8 +3,52 @@    {-  LANGUAGE CPP #-} +#define DO_TRACE 0++#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 && ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+#error Please set at most one of the flags ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 and ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 to True.+#endif+++#define WARN_IGNORED_SUBPATTERNS 1+#define NEVER_IGNORE_SUBPATTERNS 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 0  -- now a .cabal flag++#define DO_DERIVE_DATA_AND_TYPEABLE 0+#define DO_DERIVE_ONLY_TYPEABLE 1+#if DO_DERIVE_ONLY_TYPEABLE && DO_DERIVE_DATA_AND_TYPEABLE+#undef DO_DERIVE_ONLY_TYPEABLE+#warning DO_DERIVE_ONLY_TYPEABLE forced 0, due to DO_DERIVE_DATA_AND_TYPEABLE being 1.+#define DO_DERIVE_ONLY_TYPEABLE 0+#endif++-- Now specified via --flag=[-]USE_WWW_DEEPSEQ+--- #define USE_WW_DEEPSEQ 1+ ------------------------------------------------------------------------------- +#if DO_DERIVE_DATA_AND_TYPEABLE+  {-# LANGUAGE DeriveDataTypeable #-}+#endif+-- XXX Only needed for something in Blah.hs.+-- Check into it, and see if can't get rid of the need+-- for Typeable instances in here!+#if DO_DERIVE_ONLY_TYPEABLE+  {-# LANGUAGE DeriveDataTypeable #-}+#endif+#if NFDATA_INSTANCE_PATTERN+  -- For testing only (controlling trace interleaving):+  {-# LANGUAGE DeriveGeneric #-}+#endif+  {-  LANGUAGE DeriveFunctor #-}++-------------------------------------------------------------------------------+ -- | -- Module      :  Control.DeepSeq.Bounded.Compile -- Copyright   :  Andrew G. Seniuk 2014-2015@@ -12,7 +56,7 @@ -- -- Maintainer  :  Andrew Seniuk <rasfar@gmail.com> -- Stability   :  provisional--- Portability :  portable+-- Portability :  portable (H98) -- -- This is normally part of <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html Pattern>, -- but is broken out for the transitional version 0.6.*.@@ -25,12 +69,489 @@       compilePat     , showPat +---   compilePat'  ,+   )   where  ------------------------------------------------------------------------------- -  import Control.DeepSeq.Bounded.Compile_shared_utils2 ( compilePat, showPat )+  import Control.DeepSeq.Bounded.Pattern+  import Control.DeepSeq.Bounded.PatUtil ( liftPats )++  import Data.Char ( isSpace )+  import Data.Char ( isLower )+  import Data.Char ( ord )+  import Data.Char ( isDigit )+  import Data.List ( intercalate )+  import Data.List ( sort )+  import Data.Maybe ( isNothing, fromJust )+  import Data.Maybe ( isJust )++#if 0++#if DO_DERIVE_DATA_AND_TYPEABLE+  import Data.Data ( Data )+  import Data.Typeable ( Typeable )+#elif DO_DERIVE_ONLY_TYPEABLE+  import Data.Typeable ( Typeable )+#endif++#if USE_WW_DEEPSEQ+  import Control.DeepSeq ( NFData )+#endif++#endif++  import Debug.Trace ( trace )++  -- The only uses of force in this module are for debugging purposes+  -- (including trying to get messages to be displayed in a timely+  -- manner, although that problem has not been completely solved).+  import Control.DeepSeq ( force )+#if 0+#if NFDATA_INSTANCE_PATTERN+  -- for helping trace debugging+  import qualified Control.DeepSeq.Generics as DSG+  import qualified GHC.Generics as GHC ( Generic )+#endif+#endif++-------------------------------------------------------------------------------++#if DO_TRACE+  mytrace = trace+#else+  mytrace _ = id+#endif++  -- XXX This is still lacks support for the two condensed grammars:+  -- ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19+  -- ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9++  compilePat' :: String -> Pattern+  compilePat' s+   | not $ null s'  = error $ "\ncompilePat: input rejected: "+                       ++ s+                       ++ if isNothing mmsg then "" else "\nParser message: "+                       ++ fromJust mmsg+                       ++ "\nPatterns parsed so far: ["+                       ++ intercalate ", " (map show pats)+                       ++ "]"+   | otherwise      = case pats of+       [] -> error $ "\ncompilePat: "+              ++ if null s then "empty input" else "vacuous input"+       [pat] -> setPatternPatNodeUniqueIDs 0 pat+       pats -> setPatternPatNodeUniqueIDs 0 $ liftPats pats+   where (pats, mmsg, s') = compilePats s []++  -- String in last component of result is unconsumed input.++  compilePats :: String -> [Pattern] -> ([Pattern], Maybe String, String)+  compilePats s acc+   | null s_ltrim  = (reverse acc, Nothing, s_ltrim)+   | otherwise     = case cpat s of+      (Left "", s') -> (reverse acc, Nothing, s')+--    (Left "", s') -> compilePats s' acc+      (Left msg, s') -> (reverse acc, Just msg, s')+      (Right pat, s') -> compilePats s' (pat:acc)+   where s_ltrim = dropWhile isSpace s++-- XXX Don't forget to do a post-pass to change W* nodes+-- to corresponding T* nodes, when : modifier was present!+-- Oops, guess I did it here; but the original idea would+-- be less cloning...++  cpat :: String -> (Either String Pattern, String)+--cpat _ | trace "J-1: " $ False  = undefined+  cpat [] = (Left "unexpected end of input", [])+--cpat s | trace ("J-2: "++show s) $ False  = undefined+  cpat s+   | null s''   = error "\ncompilePat: type constraint must precede a pattern node"+   | isW        = case c of+      '.' -> (Right $ Node (WI as) [], cs)+      '!' -> (Right $ Node (WS as) [], cs)+      '*' -> case parseInt cs [] of+               (Nothing, cs'') -> (Right $ Node (WW   as    ) [], cs'')+               (Just is, cs'') -> (Right $ Node (WN $ asn is) [], cs'')+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+      '{' ->+#else+      '(' ->+#endif+             if isNothing mmsg_subpats+             then (Right $ Node (WR as) subpats, cs_subpats)+             else (Left $ fromJust mmsg_subpats, cs_subpats)+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+      '}' ->+#else+      ')' ->+#endif+             (Left "", cs)+      c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"+   | otherwise  = case c of+      '.' -> (Right $ Node (TI as) [], cs)+--    '!' -> (Right $ Node (TS as) [], cs)+      '*' -> case parseInt cs [] of+               (Nothing, cs'') -> (Right $ Node (TW   as    ) [], cs'')+               (Just is, cs'') -> (Right $ Node (TN $ asn is) [], cs'')+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+      '{' ->+#else+      '(' ->+#endif+             if isNothing mmsg_subpats+             then (Right $ Node (TR as) subpats, cs_subpats)+             else (Left $ fromJust mmsg_subpats, cs_subpats)+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+      '}' ->+#else+      ')' ->+#endif+             (Left "", cs)+      c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"+   where+    s' = dropWhile isSpace s+    (c:cs) = s''+    (as_mods, mmsg_mods, s'') = cmods s'  -- collect any prefix modifiers+    as = case mmsg_mods of+           Nothing -> as_mods+           Just msg -> error $ "\ncompilePat: " ++ msg+    asn is = as { depth = read is :: Int }+    isW = not $ doConstrainType as+    (subpats, mmsg_subpats, cs_subpats) = compilePats cs []++  -- Accumulate any prefix modifiers into an empty PatNodeAttrs structure.+  cmods :: String -> (PatNodeAttrs, Maybe String, String)+  cmods s = cmods' s emptyPatNodeAttrs+  cmods' :: String -> PatNodeAttrs -> (PatNodeAttrs, Maybe String, String)+  cmods' [] as = (as, Nothing, [])+--cmods' [] as = (as, Just "cmods': unexpected end of input", [])+  cmods' s as = case c of+    ':' -> cmods' cs_types  as_types+    '@' -> cmods' cs_delay  as_delay+#if USE_PAR_PATNODE+    '=' -> cmods' cs_par    as_par+#endif+#if USE_PSEQ_PATNODE+    '>' -> cmods' cs_pseq   as_pseq+#endif+#if USE_TRACE_PATNODE+    '+' -> cmods' cs_trace  as_trace+#endif+#if USE_PING_PATNODE+    '^' -> cmods' cs_ping   as_ping+#endif+#if USE_DIE_PATNODE+    '/' -> cmods' cs_die    as_die+#endif+#if USE_TIMING_PATNODE+    '%' -> cmods' cs_timing as_timing+#endif+    _ -> (as, Nothing, s)+   where+    s'@(c:cs) = dropWhile isSpace s+    ( cs_types  , as_types  ) = parse_type_constraints          cs as+    ( cs_delay  , as_delay  ) = parse_delay                     cs as+#if USE_PAR_PATNODE+    ( cs_par    , as_par    ) = ( cs, as { doSpark  = True } )+#endif+#if USE_PSEQ_PATNODE+    ( cs_pseq   , as_pseq   ) = parse_pseq                      cs as+#endif+#if USE_TRACE_PATNODE+    ( cs_trace  , as_trace  ) = ( cs, as { doTrace  = True } )+#endif+#if USE_PING_PATNODE+    ( cs_ping   , as_ping   ) = ( cs, as { doPing   = True } )+#endif+#if USE_DIE_PATNODE+    ( cs_die    , as_die    ) = ( cs, as { doDie    = True } )+#endif+#if USE_TIMING_PATNODE+    ( cs_timing , as_timing ) = ( cs, as { doTiming = True } )+#endif++  parse_type_constraints :: String -> PatNodeAttrs -> (String, PatNodeAttrs)+  parse_type_constraints s'' as+--- | doConstrainType as  = trace "\nwarning: type constraints (:...:) mod given multiple times to a single node, so aggregating type lists." $ (s', as')+   | otherwise           = (s', as')+   where+    s = dropWhile isSpace s''+    as' = as { doConstrainType = True+             , typeConstraints = typeConstraints as ++ tys }+    (tys, s') = f s "" []+    -- Take up to the next ';', ':', or '\\' and deal.+    f :: String -> String -> [String] -> ([String],String)+    f s'' tyacc tysacc+     | null s'    = error "\ncompilePat: type constraint list not ':'-terminated"+     | '\\' == c  = if null cs+                    then f cs (c:tyacc) tysacc+                    else if ':' == head cs    -- note ty is already reversed+                         then f (tail cs) ((':':'\\':ty) ++ tyacc) tysacc+                         else f cs (('\\':ty) ++ tyacc) tysacc+     | ':' == c   = ( reverse $ (reverse $ tyacc ++ ty) : tysacc , dropWhile isSpace cs )+    -- otherwise ';' == c+     | otherwise  = f cs "" $ (reverse $ tyacc ++ ty) : tysacc+     where+      s = dropWhile isSpace s''+      (c:cs) = s'+      (ty',s') = span (\c->c/=';'&&c/=':'&&c/='\\') s+      ty = dropWhile isSpace $ reverse ty'  -- yeah yeah++  parse_delay :: String -> PatNodeAttrs -> (String, PatNodeAttrs)+  parse_delay [] as = error "\nparse_delay: unexpected end of input"+  parse_delay s'' as+--- | doDelay as     = error "\ncompilePat: delay (@) modifier given multiple times to a single node"+--- | doDelay as  = trace "\nwarning: delay (@) mod given multiple times to a single node, so summing." $ (s', as')+   | isNothing mis  = error $ "\nparse_delay: expected a digit 1-9 (not '" ++ [head s] ++ "')"+   | otherwise      = (s', as')+   where+    s = dropWhile isSpace s''+    as' = as { doDelay = True  -- (convenient to set both here)+             , delayus = delayus as + i }+    (mis, s') = parseInt s []+    is = fromJust mis+    i = read is :: Int++#if USE_PSEQ_PATNODE+  parse_pseq :: String -> PatNodeAttrs -> (String, PatNodeAttrs)+  parse_pseq s'' as+   | doPseq as  = error "\ncompilePat: pseq (>) modifier given multiple times to a single node"+   | not ok     = error "\ncompilePat: pseq permutation must cover an initial segment of abc..yz"+-- No harm in allowing it; as for testing arity mismatch, that is not+-- in the parser's purview (at least at this time).  It is easily done+-- as a post-parsing check.+--- | null perm  = error "\ncompilePat: empty pseq permutation"+   | otherwise  = (s', as')+   where+    s = dropWhile isSpace s''+    as' = as { doPseq = True  -- (convenient to set both here)+             , pseqPerm = Just $ map (\c -> ord c - ord 'a') perm }+    (perm, s') = span isLower s+    ok = sort perm == take (length perm) ['a'..'z']+#endif++-------------------------------------------------------------------------------++  -- XXX Doing this to ensure issuance of all warning messages+  -- pertaining to the pattern to be compiled!+  -- Which isn't quite working?!?.... [Never did resolve this.]+  compilePat :: String -> Pattern+#if NFDATA_INSTANCE_PATTERN+  compilePat s = force $ compilePat_ s+--compilePat s = let pat = force $! compilePat_ s in trace (show pat) $! pat+--compilePat s = let pat = force $ compilePat_ s in trace (show pat) $! pat+--compilePat s = let !pat = force $ compilePat_ s in trace (show pat) $ pat+--compilePat s = let pat = force $ compilePat_ s in trace (show pat) $ pat+#else+  compilePat = compilePat_+#endif++  compilePat_ :: String -> Pattern+  compilePat_ str = compilePat' str++-------------------------------------------------------------------------------++  -- | Inverse of 'compilePat'.+  --+  -- @showPat . compilePat patstring  =  patstring@+  --+  -- (up to optional whitespace, and canonical ordering of any attributes),+  -- provided that @compilePat patstring@ succeeds.+{--}+  -- /(And, only up to subpatterns elided from # ('WI' or 'TI') or from * ('WW', 'WN', 'TW', or 'TN') nodes, in case these are still accepted by the parser!)/++  showPat :: Pattern -> String+  showPat (Node pas chs)++    | doDelay  as  = "@" ++ show (delayus as)+                         ++ let as' = as { doDelay = False }+                            in showPat (Node (setPatNodeAttrs pas as') chs)+#if USE_PAR_PATNODE+    | doSpark  as  = "=" ++ let as' = as { doSpark = False }+                            in showPat (Node (setPatNodeAttrs pas as') chs)+#endif+#if USE_PSEQ_PATNODE+    | doPseq   as  = ">" ++ showPerm (pseqPerm as)+                         ++ let as' = as { doPseq  = False }+                            in showPat (Node (setPatNodeAttrs pas as') chs)+#endif+#if USE_TRACE_PATNODE+    | doTrace  as  = "+" ++ let as' = as { doTrace = False }+                            in showPat (Node (setPatNodeAttrs pas as') chs)+#endif+#if USE_PING_PATNODE+    | doPing   as  = "^" ++ let as' = as { doPing  = False }+                            in showPat (Node (setPatNodeAttrs pas as') chs)+#endif+#if USE_DIE_PATNODE+    | doDie    as  = "/" ++ let as' = as { doDie   = False }+                            in showPat (Node (setPatNodeAttrs pas as') chs)+#endif+#if USE_TIMING_PATNODE+    | doTiming as  = "%" ++ let as' = as { doTiming   = False }+                            in showPat (Node (setPatNodeAttrs pas as') chs)+#endif+    | doConstrainType as+       =+--       trace "showPat-doConstraintType HERE!" $+         ":" ++ treps_str+             ++ let as' = as { doConstrainType = False }+                in showPat (Node (setPatNodeAttrs pas as') chs)++#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+    | WI{} <- pas  = "0"   ++ descend chs+#else+    | WI{} <- pas  = "."   ++ descend chs+#endif+    | WR{} <- pas  = ""    ++ descend chs ++ perhapsEmptySubpatterns+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+    | WS{} <- pas  = "1"   ++ descend chs+#else+    | WS{} <- pas  = "!"   ++ descend chs+#endif+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 || ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+    | WN{} <- pas  =          show n ++ descend chs+#else+    | WN{} <- pas  = "*"   ++ show n ++ descend chs+#endif+#if USE_WW_DEEPSEQ+    | WW{} <- pas  = "*"   ++ descend chs+#endif++#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+    | TI{} <- pas  = "0"   ++ descend chs+#else+    | TI{} <- pas  = "."   ++ descend chs+#endif+    | TR{} <- pas  = ""    ++ descend chs ++ perhapsEmptySubpatterns+--- #if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+---     | TS{} <- pas  = "1"   ++ descend chs+--- #else+---     | TS{} <- pas  = "!"   ++ descend chs+--- #endif+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 || ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+    | TN{} <- pas  =          show n ++ descend chs+#else+    | TN{} <- pas  = "*"   ++ show n ++ descend chs+#endif+#if USE_WW_DEEPSEQ+    | TW{} <- pas  = "*"   ++ descend chs+#endif++   where+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+    emptySubpatterns = "{}"+#else+    emptySubpatterns = "()"+#endif+    perhapsEmptySubpatterns = if null chs then emptySubpatterns else ""+    as = getPatNodeAttrs pas+    n = depth as+    treps = typeConstraints as+    treps_str = intercalate ";" treps ++ ":"++  descend :: [Pattern] -> String+  descend chs+   | null chs = ""+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+   | otherwise = "{" ++ concatMap showPat chs ++ "}"+#else+   | otherwise = "(" ++ concatMap showPat chs ++ ")"+#endif++-------------------------------------------------------------------------------++  parseInt :: String -> String -> ( Maybe String, String )+  parseInt [] acc = ( if null acc then Nothing else Just acc , "" )+  parseInt s@(c:cs) acc+-- These should be safe cutoffs without having to worry about exact figures.+--- DEPTH_USES_INT64 isn't implemented yet, this is just a note+--- for future consideration. (Should be in NFDataN if anywhere...).+--- I'm not ready to make this sweeping change yet.+--- #if DEPTH_USES_INT64+---    | length acc > 19  = error $ "compilePat: * followed by too many (>19) digits"+--- #else+   | length acc > 9  = error $ "compilePat: * followed by too many (>9) digits"+--- #endif+   | isDigit c        = parseInt cs (acc++[c])+   | otherwise        = ( if null acc then Nothing else Just acc , s )++-------------------------------------------------------------------------------++  -- | Using String instead of TypeRep since I wasn't sure+  -- how to avoid mandatory recursion to complete the latter.+  -- (Probably it can be done -- ':~:' perhaps -- but I was+  -- unsure and this is working for the moment.)+  compileTypeReps :: String -> ([String], String)+--compileTypeReps :: String -> ([TypeRep], String)+  compileTypeReps cs = (treps,cs')+   where+    (tnames, cs') = parseTyNames cs+    parseTyNames :: String -> ([String], String)+    parseTyNames s = (sps', s')+     where+      sps' = map (dropWhile pstop) sps+--    !_ = trace ("(sps,s') = " ++ show (sps,s')) ()+      (sps,s') = splitPred psplit pstop s+--    (sps,s') = splitPred p s+      pstop x = x == '{' || x == '}'+--    pstop x = x == '{'+      psplit x = x == ' ' || pstop x+--    p x = x == ' ' || x == '{'+--    p x = not $ isAlphaNum x || x == '_' || x == '\''+#if 1+-- XXX In consideration of the recursion problem with mkTyConApp below,+-- try to use typeOf instead -- but, this won't work! Because we are+-- starting with a String encoding the ...+-- ... or will it? We have to compare two strings; one comes from+-- the user-supplied pattern string we're parsing; the other? We+-- are not "comparing equality" here, it will be done later; we're+-- only compiling a pattern...  So if the treps remain strings+-- in a Pattern, until we're ready to make comparisons; it's+-- inefficient unfortunately, but I feel this will work.+--   More detail: B/c when it comes time to match the pattern,+-- you DO have a concrete value (of some type); it is THEN that+-- you apply (show . typeRepTyCon . typeOf) to it, and then+-- make your Eq String comparison. [This can be optimised later;+-- I'm concerned now with a proof-of-concept, without TH.]+    treps = tnames+#else+    treps = map mktrep tnames+-- XXX You need the recursion for (==) to work; that may not mean+-- we can't use it, but will need some form of pattern-matching,+-- as full equality is going to be disfunctional. (B/c user would+-- have to specify the fully-recursive pattern [when they want to+-- use wildcards or stop nodes down there] -- totally ridiculous.)+--   This could be what :~: is for? (It's recursive, but you perhaps+-- can use in patterns without going full depth?)+-- mkTyConApp (mkTyCon3 "base" "Data.Either" "Either") [typeRep (Proxy::Proxy Bool), typeRep (Proxy::Proxy Int)] == typeRep (Proxy :: Proxy (Either Bool Int))+    mktrep :: String -> TypeRep+    mktrep tname = trep+     where+      tcon = mkTyCon3 "" "" tname+      trep = mkTyConApp tcon []+--mkTyCon3 :: 3xString -> TypeCon+--mkTyConApp :: TyCon -> [TypeRep] -> TypeRep+#endif++-------------------------------------------------------------------------------++  -- Split on the psplit predicate, stop consuming the list+  -- on the pstop predicate.+  splitPred :: (a -> Bool) -> (a -> Bool) -> [a] -> ([[a]], [a])+  splitPred psplit pstop list = splitPred' psplit pstop list []+  splitPred' :: (a -> Bool) -> (a -> Bool) -> [a] -> [[a]] -> ([[a]], [a])+  splitPred' psplit pstop list acc+   | null first  = {-trace "-1-" $-} (acc, rest)+   | null rest   = {-trace "-2-" $-} (acc', [])  -- or (acc, rest), obv.+   | pstop h     = {-trace "-3-" $-} (acc', rest)+   | otherwise   = {-trace "-4-" $-} splitPred' psplit pstop t acc'+   where+    (first,rest) = break psplit list+    (h:t) = rest+    acc' = acc ++ [first]  ------------------------------------------------------------------------------- 

@@ -1,249 +0,0 @@-----------------------------------------------------------------------------------  {-  LANGUAGE CPP #-}--#define DO_TRACE 0--#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 && ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9-#error Please set at most one of the flags ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 and ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 to True.-#endif------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Compile_new_grammar--- Copyright   :  Andrew G. Seniuk 2014-2015--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  portable (H98)--------------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Compile_new_grammar-  (--      compilePat'  ,--  )-  where-----------------------------------------------------------------------------------  import Control.DeepSeq.Bounded.Pattern--  import Control.DeepSeq.Bounded.Compile_shared_utils--  import Data.Maybe ( isNothing, fromJust )--  import Data.List ( intercalate )--  import Debug.Trace ( trace )--  import Control.DeepSeq.Bounded.PatUtil ( liftPats )-  import Data.Char ( isSpace )-  import Data.Char ( isLower )-  import Data.List ( sort )-  import Data.Char ( ord )-  import Data.Maybe ( isJust )-----------------------------------------------------------------------------------#if DO_TRACE-  mytrace = trace-#else-  mytrace _ = id-#endif--  -- XXX This is still lacks support for the two condensed grammars:-  -- ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19-  -- ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9--  compilePat' :: String -> Pattern-  compilePat' s-   | not $ null s'  = error $ "\ncompilePat: input rejected: "-                       ++ s-                       ++ if isNothing mmsg then "" else "\nParser message: "-                       ++ fromJust mmsg-                       ++ "\nPatterns parsed so far: ["-                       ++ intercalate ", " (map show pats)-                       ++ "]"-   | otherwise      = case pats of-       [] -> error $ "\ncompilePat: "-              ++ if null s then "empty input" else "vacuous input"-       [pat] -> setPatternPatNodeUniqueIDs 0 pat-       pats -> setPatternPatNodeUniqueIDs 0 $ liftPats pats-   where (pats, mmsg, s') = compilePats s []--  -- String in last component of result is unconsumed input.--  compilePats :: String -> [Pattern] -> ([Pattern], Maybe String, String)-  compilePats s acc-   | null s_ltrim  = (reverse acc, Nothing, s_ltrim)-   | otherwise     = case cpat s of-      (Left "", s') -> (reverse acc, Nothing, s')---    (Left "", s') -> compilePats s' acc-      (Left msg, s') -> (reverse acc, Just msg, s')-      (Right pat, s') -> compilePats s' (pat:acc)-   where s_ltrim = dropWhile isSpace s---- XXX Don't forget to do a post-pass to change W* nodes--- to corresponding T* nodes, when : modifier was present!--- Oops, guess I did it here; but the original idea would--- be less cloning...--  cpat :: String -> (Either String Pattern, String)---cpat _ | trace "J-1: " $ False  = undefined-  cpat [] = (Left "unexpected end of input", [])---cpat s | trace ("J-2: "++show s) $ False  = undefined-  cpat s-   | null s''   = error "\ncompilePat: type constraint must precede a pattern node"-   | isW        = case c of-      '.' -> (Right $ Node (WI as) [], cs)-      '!' -> (Right $ Node (WS as) [], cs)-      '*' -> case parseInt cs [] of-               (Nothing, cs'') -> (Right $ Node (WW   as    ) [], cs'')-               (Just is, cs'') -> (Right $ Node (WN $ asn is) [], cs'')-      '(' -> if isNothing mmsg_subpats-             then (Right $ Node (WR as) subpats, cs_subpats)-             else (Left $ fromJust mmsg_subpats, cs_subpats)-      ')' -> (Left "", cs)-      c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"-   | otherwise  = case c of-      '.' -> (Right $ Node (TI as) [], cs)---    '!' -> (Right $ Node (TS as) [], cs)-      '*' -> case parseInt cs [] of-               (Nothing, cs'') -> (Right $ Node (TW   as    ) [], cs'')-               (Just is, cs'') -> (Right $ Node (TN $ asn is) [], cs'')-      '(' -> if isNothing mmsg_subpats-             then (Right $ Node (TR as) subpats, cs_subpats)-             else (Left $ fromJust mmsg_subpats, cs_subpats)-      ')' -> (Left "", cs)-      c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"-   where-    s' = dropWhile isSpace s-    (c:cs) = s''-    (as_mods, mmsg_mods, s'') = cmods s'  -- collect any prefix modifiers-    as = case mmsg_mods of-           Nothing -> as_mods-           Just msg -> error $ "\ncompilePat: " ++ msg-    asn is = as { depth = read is :: Int }-    isW = not $ doConstrainType as-    (subpats, mmsg_subpats, cs_subpats) = compilePats cs []--  -- Accumulate any prefix modifiers into an empty PatNodeAttrs structure.-  cmods :: String -> (PatNodeAttrs, Maybe String, String)-  cmods s = cmods' s emptyPatNodeAttrs-  cmods' :: String -> PatNodeAttrs -> (PatNodeAttrs, Maybe String, String)-  cmods' [] as = (as, Nothing, [])---cmods' [] as = (as, Just "cmods': unexpected end of input", [])-  cmods' s as = case c of-    ':' -> cmods' cs_types  as_types-    '@' -> cmods' cs_delay  as_delay-#if USE_PAR_PATNODE-    '=' -> cmods' cs_par    as_par-#endif-#if USE_PSEQ_PATNODE-    '>' -> cmods' cs_pseq   as_pseq-#endif-#if USE_TRACE_PATNODE-    '+' -> cmods' cs_trace  as_trace-#endif-#if USE_PING_PATNODE-    '^' -> cmods' cs_ping   as_ping-#endif-#if USE_DIE_PATNODE-    '/' -> cmods' cs_die    as_die-#endif-#if USE_TIMING_PATNODE-    '%' -> cmods' cs_timing as_timing-#endif-    _ -> (as, Nothing, s)-   where-    s'@(c:cs) = dropWhile isSpace s-    ( cs_types  , as_types  ) = parse_type_constraints          cs as-    ( cs_delay  , as_delay  ) = parse_delay                     cs as-#if USE_PAR_PATNODE-    ( cs_par    , as_par    ) = ( cs, as { doSpark  = True } )-#endif-#if USE_PSEQ_PATNODE-    ( cs_pseq   , as_pseq   ) = parse_pseq                      cs as-#endif-#if USE_TRACE_PATNODE-    ( cs_trace  , as_trace  ) = ( cs, as { doTrace  = True } )-#endif-#if USE_PING_PATNODE-    ( cs_ping   , as_ping   ) = ( cs, as { doPing   = True } )-#endif-#if USE_DIE_PATNODE-    ( cs_die    , as_die    ) = ( cs, as { doDie    = True } )-#endif-#if USE_TIMING_PATNODE-    ( cs_timing , as_timing ) = ( cs, as { doTiming = True } )-#endif--  parse_type_constraints :: String -> PatNodeAttrs -> (String, PatNodeAttrs)-  parse_type_constraints s'' as---- | doConstrainType as  = trace "\nwarning: type constraints (:...:) mod given multiple times to a single node, so aggregating type lists." $ (s', as')-   | otherwise           = (s', as')-   where-    s = dropWhile isSpace s''-    as' = as { doConstrainType = True-             , typeConstraints = typeConstraints as ++ tys }-    (tys, s') = f s "" []-    -- Take up to the next ';', ':', or '\\' and deal.-    f :: String -> String -> [String] -> ([String],String)-    f s'' tyacc tysacc-     | null s'    = error "\ncompilePat: type constraint list not ':'-terminated"-     | '\\' == c  = if null cs-                    then f cs (c:tyacc) tysacc-                    else if ':' == head cs    -- note ty is already reversed-                         then f (tail cs) ((':':'\\':ty) ++ tyacc) tysacc-                         else f cs (('\\':ty) ++ tyacc) tysacc-     | ':' == c   = ( reverse $ (reverse $ tyacc ++ ty) : tysacc , dropWhile isSpace cs )-    -- otherwise ';' == c-     | otherwise  = f cs "" $ (reverse $ tyacc ++ ty) : tysacc-     where-      s = dropWhile isSpace s''-      (c:cs) = s'-      (ty',s') = span (\c->c/=';'&&c/=':'&&c/='\\') s-      ty = dropWhile isSpace $ reverse ty'  -- yeah yeah--  parse_delay :: String -> PatNodeAttrs -> (String, PatNodeAttrs)-  parse_delay [] as = error "\nparse_delay: unexpected end of input"-  parse_delay s'' as---- | doDelay as     = error "\ncompilePat: delay (@) modifier given multiple times to a single node"---- | doDelay as  = trace "\nwarning: delay (@) mod given multiple times to a single node, so summing." $ (s', as')-   | isNothing mis  = error $ "\nparse_delay: expected a digit 1-9 (not '" ++ [head s] ++ "')"-   | otherwise      = (s', as')-   where-    s = dropWhile isSpace s''-    as' = as { doDelay = True  -- (convenient to set both here)-             , delayus = delayus as + i }-    (mis, s') = parseInt s []-    is = fromJust mis-    i = read is :: Int--#if USE_PSEQ_PATNODE-  parse_pseq :: String -> PatNodeAttrs -> (String, PatNodeAttrs)-  parse_pseq s'' as-   | doPseq as  = error "\ncompilePat: pseq (>) modifier given multiple times to a single node"-   | not ok     = error "\ncompilePat: pseq permutation must cover an initial segment of abc..yz"--- No harm in allowing it; as for testing arity mismatch, that is not--- in the parser's purview (at least at this time).  It is easily done--- as a post-parsing check.---- | null perm  = error "\ncompilePat: empty pseq permutation"-   | otherwise  = (s', as')-   where-    s = dropWhile isSpace s''-    as' = as { doPseq = True  -- (convenient to set both here)-             , pseqPerm = Just $ map (\c -> ord c - ord 'a') perm }-    (perm, s') = span isLower s-    ok = sort perm == take (length perm) ['a'..'z']-#endif----------------------------------------------------------------------------------

@@ -1,260 +0,0 @@-----------------------------------------------------------------------------------  {-  LANGUAGE CPP #-}--#define DO_TRACE 0--#define WARN_IGNORED_SUBPATTERNS 1-#define NEVER_IGNORE_SUBPATTERNS 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 0  -- now a .cabal flag--#define DO_DERIVE_DATA_AND_TYPEABLE 0-#define DO_DERIVE_ONLY_TYPEABLE 1-#if DO_DERIVE_ONLY_TYPEABLE && DO_DERIVE_DATA_AND_TYPEABLE-#undef DO_DERIVE_ONLY_TYPEABLE-#warning DO_DERIVE_ONLY_TYPEABLE forced 0, due to DO_DERIVE_DATA_AND_TYPEABLE being 1.-#define DO_DERIVE_ONLY_TYPEABLE 0-#endif---- Now specified via --flag=[-]USE_WWW_DEEPSEQ---- #define USE_WW_DEEPSEQ 1-----------------------------------------------------------------------------------#if DO_DERIVE_DATA_AND_TYPEABLE-  {-# LANGUAGE DeriveDataTypeable #-}-#endif--- XXX Only needed for something in Blah.hs.--- Check into it, and see if can't get rid of the need--- for Typeable instances in here!-#if DO_DERIVE_ONLY_TYPEABLE-  {-# LANGUAGE DeriveDataTypeable #-}-#endif-#if NFDATA_INSTANCE_PATTERN-  -- For testing only (controlling trace interleaving):-  {-# LANGUAGE DeriveGeneric #-}-#endif-  {-  LANGUAGE DeriveFunctor #-}------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Compile_old_grammar--- Copyright   :  Andrew G. Seniuk 2014-2015--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  experimental, deprecated--- Portability :  portable--------------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Compile_old_grammar---- {-# DEPRECATED "Use Wobble instead" #-}-  (--      compilePat'--  )-  where-----------------------------------------------------------------------------------  import Control.DeepSeq.Bounded.Pattern-  import Control.DeepSeq.Bounded.Compile_shared_utils--  import Data.Maybe ( isNothing, fromJust )-  import Data.Maybe ( isJust )--  import Debug.Trace ( trace )-----------------------------------------------------------------------------------#if DO_TRACE-  mytrace = trace-#else-  mytrace _ = id-#endif-----------------------------------------------------------------------------------  -- compilePat' parameters:-  --  spark    - the next node parsed will, when matched, spark parallel-  --             evaluation of its subpatterns-  --  mpn      - says what the last PatNode parsed was (list args are empty)-  --           - what do I mean "list args are empty"?-  --              - oh: T* nodes have a list arg-  --           - I see that mpn is never used (except in some dead code)...-  --  mn       - says what n is for rnfn (eg. 3 for "*3")-  --           - note that, when Just, this signals to parser that * is for-  --             a WN/TN node rather than a WW/TW node-  --  (t:ts)   - the list of type constraints (currently, constructor names)-  --           - list must be empty iff node is a T* node-  --  mptc     - Just pre-constraint character (Nothing is not possible)-  --  (c:cs)   - is what's left of the input string we're parsing-  --  acc      - is an accumulator parameter, collecting patterns parsed-  compilePat' :: Bool -> Maybe PatNode -> Maybe Int -> [String] -> Maybe Char -> String -> [Pattern] -> ([Pattern], String)-  -- This first binding in the compilePat' group is only for-  -- some error trapping (only matches in case of parse errors).-  compilePat' spark mpn mn (t:ts) (Just c) cs _--- XXX Now we need to allow there to be /no/ pre-treps char...-#if 1-   | not $ c `elem` ".*#"  = error $ "compilePat: parse error: pre-treps pattern char " ++ show c ++ " not one of .*#"-#else-   -- ?? it /seems/ okay without the '{'; not sure why it was included...---- | not $ c `elem` "{"  = error $ "compilePat: parse error: pre-treps pattern char " ++ show c ++ " not '{'"-   | not $ c `elem` "{.*#"  = error $ "compilePat: parse error: pre-treps pattern char " ++ show c ++ " not one of {.*#"-#endif-  compilePat' spark mpn mn _  mptc [] acc = mytrace "EMPTY" $ (acc, [])---compilePat' spark mpn mn [] mptc [] acc = mytrace "EMPTY" $ (acc, [])-  compilePat' spark mpn mn [] mptc (' ':cs) acc = mytrace "space" $ compilePat' spark mpn mn [] mptc cs acc-  compilePat' spark mpn mn [] mptc ('}':'{':cs) acc = error $ "compilePat: opening brace cannot follow closing brace"-  compilePat' spark mpn mn [] mptc ('}':cs) acc-#if 0-        -- Lenient parser tolerates subpatterns of these.-        -- (The semantics is that any such subpatterns are ignored ---        -- discarded with a warning.)-#if USE_WW_DEEPSEQ-   | isJust mpn, Just WW <- mpn  = trace "compilePat-\"}\": warning: * with subpattern" $ mytrace "}" $ (acc, cs)-#endif-   | isJust mpn, Just WI <- mpn  = trace "compilePat-\"}\": warning: # with subpattern" $ mytrace "}" $ (acc, cs)-#endif-   | otherwise  = mytrace "}" $ (acc, cs)-  compilePat' spark mpn mn [] mptc (c:':':cs) acc-   | null treps  = error $ "compilePat: colon must be followed by at least one type name"-   | otherwise   = compilePat' spark mpn mn treps (Just c) cs' acc-   where---  !_ = trace ("Boo: " ++ show (treps, cs')) ()-    (treps, cs') = compileTypeReps cs-  compilePat' spark mpn Nothing [] mptc ('@':cs) acc-   | isNothing mn  = error $ "compilePat: internal error @2 (please report this bug!)"-   | otherwise     = compilePat' spark mpn mn [] mptc ('@':cs') acc  -- mn is Just n-   where---  !_ = trace ("Boo: " ++ show (mn, cs')) ()-    (mn_, cs') = parseInt cs ""-    mn | isNothing mn_  = Nothing-       | otherwise      = Just ( read (fromJust mn_) :: Int )-  compilePat' spark mpn (Just n) [] mptc ('@':cs) acc-   = compilePat' False mpn Nothing [] mptc cs (acc++[node])-#if PARALLELISM_EXPERIMENT-    where node | spark      = Node (PN n) []-               | otherwise  = Node (WN n) []-#else-    where node = Node (WN n) []-#endif-  compilePat' spark mpn (Just n) [] mptc (c:cs) acc-   = error $ "compilePat: internal error @1(" ++ [c] ++ ") (please report this bug!)"-  compilePat' spark mpn mn [] mptc (c:'{':cs) acc = compilePat' spark mpn mn [] mptc cs' (acc++[node])-   where-    (chs, cs') = mytrace (".{-cs="++cs) $ compilePat' spark mpn mn [] mptc cs []-    node = case c of-        '.' -> mytrace (".{-recurs: "++show chs) $ Node WR chs-        -- Lenient parser tolerates subpatterns of these.-        -- (The semantics is that any such subpatterns are ignored ---        -- discarded with a warning.)--- It's more convenient to keep the subpatterns, if want to issue--- a warning when they don't match for type-constrained patterns.--- True the semantics is the same except for the warning message,--- but, well, I want to see it at the moment!-#if NEVER_IGNORE_SUBPATTERNS-#if ! WARN_IGNORED_SUBPATTERNS-#if USE_WW_DEEPSEQ-        '*' -> Node WW chs-#endif-        '#' -> Node WI chs-#else-#if USE_WW_DEEPSEQ-        '*' -> trace "compilePat-\"{\": warning: * with subpattern" $ Node WW chs-#endif-        '#' -> trace "compilePat-\"{\": warning: # with subpattern" $ Node WI chs-#endif-#else-#if ! WARN_IGNORED_SUBPATTERNS-#if USE_WW_DEEPSEQ-        '*' -> Node WW []-#endif-        '#' -> Node WI []-#else-#if USE_WW_DEEPSEQ-        '*' -> trace "compilePat-\"{\": warning: * with subpattern" $ Node WW []-#endif-        -- Yes, we do see the error for each test we expect a warning from!---      '#' -> error "compilePat-\"{\": warning: # with subpattern"---      '#' -> force $! trace "compilePat-\"{\": warning: # with subpattern" $! Node WI []-        '#' -> trace "compilePat-\"{\": warning: # with subpattern" $ Node WI []-#endif-#endif-        _ -> error $ "compilePat-\"{\": unexpected " ++ show c ++ " (cs'=" ++ cs'-  compilePat' spark mpn mn treps mptc ('{':cs) acc = compilePat' spark mpn mn [] mptc cs' (acc++[node])-   where-    (chs, cs') = mytrace ("T-{-cs="++cs) $ compilePat' spark mpn mn [] mptc cs []-    node-     | isJust mptc  = let c = fromJust mptc in case c of-        '.' -> mytrace ("T-{-recurs: "++show chs) $ Node (TR treps) chs-#if NEVER_IGNORE_SUBPATTERNS-#if ! WARN_IGNORED_SUBPATTERNS-#if USE_WW_DEEPSEQ-        '*' -> Node (TW treps) chs-#endif-        '#' -> Node (TI treps) chs-#else-#if USE_WW_DEEPSEQ-        '*' -> trace "compilePat-T-\"{\": warning: * with subpattern" $ Node (TW treps) chs-#endif-        '#' -> trace "compilePat-T-\"{\": warning: # with subpattern" $ Node (TI treps) chs-#endif-#else-#if ! WARN_IGNORED_SUBPATTERNS-#if USE_WW_DEEPSEQ-        '*' -> Node (TW treps) []-#endif-        '#' -> Node (TI treps) []-#else-#if USE_WW_DEEPSEQ-        '*' -> trace "compilePat-T-\"{\": warning: * with subpattern" $ Node (TW treps) []-#endif-        '#' -> trace "compilePat-T-\"{\": warning: # with subpattern" $ Node (TI treps) []-#endif-#endif-        _ -> error $ "compilePat-T-\"{\": unexpected " ++ show c ++ " (cs'=" ++ cs'-     | otherwise = error $ "T-{-recurs-OLDGRAM: "++show chs-#if PARALLELISM_EXPERIMENT-  compilePat' spark mpn mn treps mptc ('=':cs) acc = compilePat' True mpn mn treps mptc cs acc-#endif-  compilePat' spark mpn mn treps mptc (c:cs) acc = compilePat' False mpn mn [] mptc cs (acc++[node])---compilePat' spark mpn mn treps mptc (c:cs) acc = compilePat' False mpn mn [] mptc cs $ force (acc++[node])-   where-    node-#if PARALLELISM_EXPERIMENT-     | spark = case c of-        '.' -> mytrace ".:cs" $ Node PR []-#if USE_WW_DEEPSEQ-        '*' -> mytrace "*:cs" $ Node PW []-#endif-        _ -> error $ "compilePat-\"c:cs\"-spark: unexpected " ++ show c ++ " (cs=" ++ cs-#endif-     | null treps = case c of-        '.' -> mytrace ".:cs" $ Node WS []  -- sic!-#if USE_WW_DEEPSEQ-        '*' -> mytrace "*:cs" $ Node WW []-#endif-        '#' -> mytrace "#:cs" $ Node WI []-        _ -> error $ "compilePat-\"c:cs\": unexpected " ++ show c ++ " (cs=" ++ cs-     | otherwise = case c of-        '.' -> mytrace ".:cs" $ Node (TR treps) []---      '.' -> mytrace ".:cs" $ Node (TS treps) []-#if USE_WW_DEEPSEQ-        '*' -> mytrace "*:cs" $ Node (TW treps) []-#endif-        '#' -> mytrace "#:cs" $ Node (TI treps) []-        _ -> error $ "compilePat-T-\"c:cs\": unexpected " ++ show c ++ " (cs=" ++ cs----------------------------------------------------------------------------------

@@ -1,174 +0,0 @@-----------------------------------------------------------------------------------  {-  LANGUAGE CPP #-}--#define DO_TRACE 0--#define WARN_IGNORED_SUBPATTERNS 1-#define NEVER_IGNORE_SUBPATTERNS 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 0  -- now a .cabal flag--#define DO_DERIVE_DATA_AND_TYPEABLE 0-#define DO_DERIVE_ONLY_TYPEABLE 1-#if DO_DERIVE_ONLY_TYPEABLE && DO_DERIVE_DATA_AND_TYPEABLE-#undef DO_DERIVE_ONLY_TYPEABLE-#warning DO_DERIVE_ONLY_TYPEABLE forced 0, due to DO_DERIVE_DATA_AND_TYPEABLE being 1.-#define DO_DERIVE_ONLY_TYPEABLE 0-#endif---- Now specified via --flag=[-]USE_WWW_DEEPSEQ---- #define USE_WW_DEEPSEQ 1-----------------------------------------------------------------------------------#if DO_DERIVE_DATA_AND_TYPEABLE-  {-# LANGUAGE DeriveDataTypeable #-}-#endif--- XXX Only needed for something in Blah.hs.--- Check into it, and see if can't get rid of the need--- for Typeable instances in here!-#if DO_DERIVE_ONLY_TYPEABLE-  {-# LANGUAGE DeriveDataTypeable #-}-#endif-#if NFDATA_INSTANCE_PATTERN-  -- For testing only (controlling trace interleaving):-  {-# LANGUAGE DeriveGeneric #-}-#endif-  {-  LANGUAGE DeriveFunctor #-}------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Compile_shared_utils--- Copyright   :  Andrew G. Seniuk 2014-2015--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  portable--------------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Compile_shared_utils---- {-# DEPRECATED "Use Wobble instead" #-}-  (--    compileTypeReps  ,-    parseInt  ,--  )-  where-----------------------------------------------------------------------------------  import Data.Char ( isDigit )-----------------------------------------------------------------------------------#if DO_TRACE-  mytrace = trace-#else-  mytrace _ = id-#endif-----------------------------------------------------------------------------------  parseInt :: String -> String -> ( Maybe String, String )-  parseInt [] acc = ( if null acc then Nothing else Just acc , "" )-  parseInt s@(c:cs) acc--- These should be safe cutoffs without having to worry about exact figures.---- DEPTH_USES_INT64 isn't implemented yet, this is just a note---- for future consideration. (Should be in NFDataN if anywhere...).---- I'm not ready to make this sweeping change yet.---- #if DEPTH_USES_INT64----    | length acc > 19  = error $ "compilePat: * followed by too many (>19) digits"---- #else-   | length acc > 9  = error $ "compilePat: * followed by too many (>9) digits"---- #endif-   | isDigit c        = parseInt cs (acc++[c])-   | otherwise        = ( if null acc then Nothing else Just acc , s )-----------------------------------------------------------------------------------  -- | Using String instead of TypeRep since I wasn't sure-  -- how to avoid mandatory recursion to complete the latter.-  -- (Probably it can be done -- ':~:' perhaps -- but I was-  -- unsure and this is working for the moment.)-  compileTypeReps :: String -> ([String], String)---compileTypeReps :: String -> ([TypeRep], String)-  compileTypeReps cs = (treps,cs')-   where-    (tnames, cs') = parseTyNames cs-    parseTyNames :: String -> ([String], String)-    parseTyNames s = (sps', s')-     where-      sps' = map (dropWhile pstop) sps---    !_ = trace ("(sps,s') = " ++ show (sps,s')) ()-      (sps,s') = splitPred psplit pstop s---    (sps,s') = splitPred p s-      pstop x = x == '{' || x == '}'---    pstop x = x == '{'-      psplit x = x == ' ' || pstop x---    p x = x == ' ' || x == '{'---    p x = not $ isAlphaNum x || x == '_' || x == '\''-#if 1--- XXX In consideration of the recursion problem with mkTyConApp below,--- try to use typeOf instead -- but, this won't work! Because we are--- starting with a String encoding the ...--- ... or will it? We have to compare two strings; one comes from--- the user-supplied pattern string we're parsing; the other? We--- are not "comparing equality" here, it will be done later; we're--- only compiling a pattern...  So if the treps remain strings--- in a Pattern, until we're ready to make comparisons; it's--- inefficient unfortunately, but I feel this will work.---   More detail: B/c when it comes time to match the pattern,--- you DO have a concrete value (of some type); it is THEN that--- you apply (show . typeRepTyCon . typeOf) to it, and then--- make your Eq String comparison. [This can be optimised later;--- I'm concerned now with a proof-of-concept, without TH.]-    treps = tnames-#else-    treps = map mktrep tnames--- XXX You need the recursion for (==) to work; that may not mean--- we can't use it, but will need some form of pattern-matching,--- as full equality is going to be disfunctional. (B/c user would--- have to specify the fully-recursive pattern [when they want to--- use wildcards or stop nodes down there] -- totally ridiculous.)---   This could be what :~: is for? (It's recursive, but you perhaps--- can use in patterns without going full depth?)--- mkTyConApp (mkTyCon3 "base" "Data.Either" "Either") [typeRep (Proxy::Proxy Bool), typeRep (Proxy::Proxy Int)] == typeRep (Proxy :: Proxy (Either Bool Int))-    mktrep :: String -> TypeRep-    mktrep tname = trep-     where-      tcon = mkTyCon3 "" "" tname-      trep = mkTyConApp tcon []---mkTyCon3 :: 3xString -> TypeCon---mkTyConApp :: TyCon -> [TypeRep] -> TypeRep-#endif-----------------------------------------------------------------------------------  -- Split on the psplit predicate, stop consuming the list-  -- on the pstop predicate.-  splitPred :: (a -> Bool) -> (a -> Bool) -> [a] -> ([[a]], [a])-  splitPred psplit pstop list = splitPred' psplit pstop list []-  splitPred' :: (a -> Bool) -> (a -> Bool) -> [a] -> [[a]] -> ([[a]], [a])-  splitPred' psplit pstop list acc-   | null first  = {-trace "-1-" $-} (acc, rest)-   | null rest   = {-trace "-2-" $-} (acc', [])  -- or (acc, rest), obv.-   | pstop h     = {-trace "-3-" $-} (acc', rest)-   | otherwise   = {-trace "-4-" $-} splitPred' psplit pstop t acc'-   where-    (first,rest) = break psplit list-    (h:t) = rest-    acc' = acc ++ [first]----------------------------------------------------------------------------------

@@ -1,344 +0,0 @@-----------------------------------------------------------------------------------  {-  LANGUAGE CPP #-}--#define DO_TRACE 0--#define WARN_IGNORED_SUBPATTERNS 1-#define NEVER_IGNORE_SUBPATTERNS 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 0  -- now a .cabal flag--#define DO_DERIVE_DATA_AND_TYPEABLE 0-#define DO_DERIVE_ONLY_TYPEABLE 1-#if DO_DERIVE_ONLY_TYPEABLE && DO_DERIVE_DATA_AND_TYPEABLE-#undef DO_DERIVE_ONLY_TYPEABLE-#warning DO_DERIVE_ONLY_TYPEABLE forced 0, due to DO_DERIVE_DATA_AND_TYPEABLE being 1.-#define DO_DERIVE_ONLY_TYPEABLE 0-#endif---- Now specified via --flag=[-]USE_WWW_DEEPSEQ---- #define USE_WW_DEEPSEQ 1-----------------------------------------------------------------------------------#if DO_DERIVE_DATA_AND_TYPEABLE-  {-# LANGUAGE DeriveDataTypeable #-}-#endif--- XXX Only needed for something in Blah.hs.--- Check into it, and see if can't get rid of the need--- for Typeable instances in here!-#if DO_DERIVE_ONLY_TYPEABLE-  {-# LANGUAGE DeriveDataTypeable #-}-#endif-#if NFDATA_INSTANCE_PATTERN-  -- For testing only (controlling trace interleaving):-  {-# LANGUAGE DeriveGeneric #-}-#endif-  {-  LANGUAGE DeriveFunctor #-}------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Compile_shared_utils2--- Copyright   :  Andrew G. Seniuk 2014-2015--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  portable--------------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Compile_shared_utils2---- {-# DEPRECATED "Use Wobble instead" #-}-  (--    compilePat  ,-    showPat  ,--  )-  where-----------------------------------------------------------------------------------  import Control.DeepSeq.Bounded.Pattern-  import Control.DeepSeq.Bounded.PatUtil ( liftPats )-  import Control.DeepSeq.Bounded.Compile_shared_utils ( parseInt )--#if 0--#if DO_DERIVE_DATA_AND_TYPEABLE-  import Data.Data ( Data )-  import Data.Typeable ( Typeable )-#elif DO_DERIVE_ONLY_TYPEABLE-  import Data.Typeable ( Typeable )-#endif--#if USE_WW_DEEPSEQ-  import Control.DeepSeq ( NFData )-#endif--#endif-  import Data.List ( intercalate )-#if 0-  import Data.Char ( isDigit )-  import Data.Maybe ( isNothing, fromJust )-  import Data.Maybe ( isJust )--#endif-  import Debug.Trace ( trace )-  -- The only uses of force in this module are for debugging purposes-  -- (including trying to get messages to be displayed in a timely-  -- manner, although that problem has not been completely solved).-  import Control.DeepSeq ( force )-#if 0-#if NFDATA_INSTANCE_PATTERN-  -- for helping trace debugging-  import qualified Control.DeepSeq.Generics as DSG-  import qualified GHC.Generics as GHC ( Generic )-#endif-#endif---- Temporary until commit to new grammar exclusively (or decide to--- really continue supporting both)...-#if NEW_IMPROVED_PATTERN_GRAMMAR-  import Control.DeepSeq.Bounded.Compile_new_grammar ( compilePat' )-#else-  import Control.DeepSeq.Bounded.Compile_old_grammar ( compilePat' )-#endif-----------------------------------------------------------------------------------#if DO_TRACE-  mytrace = trace-#else-  mytrace _ = id-#endif-----------------------------------------------------------------------------------  -- XXX Doing this to ensure issuance of all warning messages-  -- pertaining to the pattern to be compiled!-  -- Which isn't quite working?!?.... [Never did resolve this.]-  compilePat :: String -> Pattern-#if NFDATA_INSTANCE_PATTERN-  compilePat s = force $ compilePat_ s---compilePat s = let pat = force $! compilePat_ s in trace (show pat) $! pat---compilePat s = let pat = force $ compilePat_ s in trace (show pat) $! pat---compilePat s = let !pat = force $ compilePat_ s in trace (show pat) $ pat---compilePat s = let pat = force $ compilePat_ s in trace (show pat) $ pat-#else-  compilePat = compilePat_-#endif--#if NEW_IMPROVED_PATTERN_GRAMMAR--  compilePat_ :: String -> Pattern-  compilePat_ str = compilePat' str--#else--  compilePat_ :: String -> Pattern---compilePat_ :: String -> (Pattern, String)---compilePat_ s = Node WW []-  compilePat_ s-   | null plst         = error "compilePat: empty pattern (syntax error)"-   | length plst > 1   = error "compilePat: disconnected pattern (not rooted)\nPerhaps you used parentheses instead of braces?"-   | not $ null s'     = error $ "compilePat: parse error: not all input consumed\nRemaining: " ++ s'-#if 1-   | otherwise   = head plst-   where-#else--- When find the time, should add a CPP switch to enable emitting--- a warning message in these cases; but it's too common/useful to--- brutally disallow like this!...-   | WI <- p      = error "compilePat: top pattern node cannot be #"-   | TR _ <- p    = error "compilePat: top pattern node cannot be .:<qual>"-   | TN _ _ <- p  = error "compilePat: top pattern node cannot be *:<qual>"-   | TW _ <- p    = error "compilePat: top pattern node cannot be *:<qual>"-   | TI _ <- p    = error "compilePat: top pattern node cannot be #:<qual>"-   | otherwise    = hplst-   where-    hplst@(Node p _) = head plst-#endif-    (plst, s') = compilePat' False Nothing Nothing [] Nothing s_ []  -- XXX ??-    s_ = translateStarN s--  translateStarN [] = []-  translateStarN ('@':cs) = error $ "compilePat: parse error: unexpected '@'"-  translateStarN ('*':cs)-   | isNothing mn  = '*' : translateStarN cs'  -- or cs-   | otherwise     = '@' : ( fromJust mn ++ translateStarN cs' )-   where---  !_ = trace ("Boo: " ++ show (mn, cs')) ()-    (mn, cs') = parseInt cs ""-  translateStarN (c:cs) = c : translateStarN cs--#endif-----------------------------------------------------------------------------------  -- | Inverse of 'compilePat'.-  ---  -- @showPat . compilePat patstring  =  patstring@-  ---  -- (up to optional whitespace, and canonical ordering of any attributes),-  -- provided that @compilePat patstring@ succeeds.-  -- /(And, only up to subpatterns elided from # ('WI' or 'TI') or from * ('WW', 'WN', 'TW', or 'TN') nodes, in case these are still accepted by the parser!)/--#if NEW_IMPROVED_PATTERN_GRAMMAR--  showPat :: Pattern -> String-  showPat (Node pas chs)--    | doDelay  as  = "@" ++ show (delayus as)-                         ++ let as' = as { doDelay = False }-                            in showPat (Node (setPatNodeAttrs pas as') chs)-#if USE_PAR_PATNODE-    | doSpark  as  = "=" ++ let as' = as { doSpark = False }-                            in showPat (Node (setPatNodeAttrs pas as') chs)-#endif-#if USE_PSEQ_PATNODE-    | doPseq   as  = ">" ++ showPerm (pseqPerm as)-                         ++ let as' = as { doPseq  = False }-                            in showPat (Node (setPatNodeAttrs pas as') chs)-#endif-#if USE_TRACE_PATNODE-    | doTrace  as  = "+" ++ let as' = as { doTrace = False }-                            in showPat (Node (setPatNodeAttrs pas as') chs)-#endif-#if USE_PING_PATNODE-    | doPing   as  = "^" ++ let as' = as { doPing  = False }-                            in showPat (Node (setPatNodeAttrs pas as') chs)-#endif-#if USE_DIE_PATNODE-    | doDie    as  = "/" ++ let as' = as { doDie   = False }-                            in showPat (Node (setPatNodeAttrs pas as') chs)-#endif-#if USE_TIMING_PATNODE-    | doTiming as  = "%" ++ let as' = as { doTiming   = False }-                            in showPat (Node (setPatNodeAttrs pas as') chs)-#endif-    | doConstrainType as-       =---       trace "showPat-doConstraintType HERE!" $-         ":" ++ treps_str-             ++ let as' = as { doConstrainType = False }-                in showPat (Node (setPatNodeAttrs pas as') chs)--#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9-    | WI{} <- pas  = "0"   ++ descend chs-#else-    | WI{} <- pas  = "."   ++ descend chs-#endif-    | WR{} <- pas  = ""    ++ descend chs ++ perhapsEmptySubpatterns-#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9-    | WS{} <- pas  = "1"   ++ descend chs-#else-    | WS{} <- pas  = "!"   ++ descend chs-#endif-#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 || ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9-    | WN{} <- pas  =          show n ++ descend chs-#else-    | WN{} <- pas  = "*"   ++ show n ++ descend chs-#endif-#if USE_WW_DEEPSEQ-    | WW{} <- pas  = "*"   ++ descend chs-#endif--#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9-    | TI{} <- pas  = "0"   ++ descend chs-#else-    | TI{} <- pas  = "."   ++ descend chs-#endif-    | TR{} <- pas  = ""    ++ descend chs ++ perhapsEmptySubpatterns---- #if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9----     | TS{} <- pas  = "1"   ++ descend chs---- #else----     | TS{} <- pas  = "!"   ++ descend chs---- #endif-#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 || ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9-    | TN{} <- pas  =          show n ++ descend chs-#else-    | TN{} <- pas  = "*"   ++ show n ++ descend chs-#endif-#if USE_WW_DEEPSEQ-    | TW{} <- pas  = "*"   ++ descend chs-#endif--   where-#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS-    emptySubpatterns = "{}"-#else-    emptySubpatterns = "()"-#endif-    perhapsEmptySubpatterns = if null chs then emptySubpatterns else ""-    as = getPatNodeAttrs pas-    n = depth as-    treps = typeConstraints as-    treps_str = intercalate ";" treps ++ ":"--#else---- XXX This looks to be wrong in several ways, but I'm going--- to leave it alone (it's as per 0.5.5), and focus on the--- new grammar case above.--  showPat :: Pattern -> String-  showPat (Node p chs)--    | WR         <- p  = "."  ++ descend chs ++ perhapsEmptySubpatterns-    | WS         <- p  = "."  ++ descend chs-    | WN n       <- p  = "*"  ++ show n-    | WI         <- p  = "#"  ++ descend chs-#if USE_WW_DEEPSEQ-    | WW         <- p  = "*"  ++ descend chs-#endif--#if PARALLELISM_EXPERIMENT-    | PR         <- p  = "=." ++ descend chs ++ perhapsEmptySubpatterns-    | PN n       <- p  = "=*" ++ show n ++ ":" ++ descend chs-#if USE_WW_DEEPSEQ-    | PW         <- p  = "=*"  ++ descend chs-#endif-#endif--    | TR treps   <- p  = ".:" ++ descendT treps chs ++ perhapsEmptySubpatterns-    | TI treps   <- p  = "#:" ++ descendT treps chs---- | TS treps   <- p  = ".:" ++ descendT treps chs-    | TN n treps <- p  = "*"  ++ show n ++ ":" ++ descendT treps chs-#if USE_WW_DEEPSEQ-    | TW treps   <- p  = "*:" ++ descendT treps chs-#endif-   where-#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS-    emptySubpatterns = "{}"-#else-    emptySubpatterns = "()"-#endif-    perhapsEmptySubpatterns = if null chs then emptySubpatterns else ""--  descendT :: [String] -> [Pattern] -> String-  descendT treps chs = treps_ ++ descend chs-   where treps_ = intercalate " " treps--#endif--  descend :: [Pattern] -> String-  descend chs-   | null chs = ""-#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS-   | otherwise = "{" ++ concatMap showPat chs ++ "}"-#else-   | otherwise = "(" ++ concatMap showPat chs ++ ")"-#endif----------------------------------------------------------------------------------

@@ -1,116 +0,0 @@-----------------------------------------------------------------------------------  {-  LANGUAGE CPP #-}  -- specified in .cabal default-extensions-----------------------------------------------------------------------------------  {-  LANGUAGE BangPatterns #-}-  {-  OPTIONS_GHC -fno-warn-name-shadowing #-}------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Flags--- Copyright   :  Andrew G. Seniuk 2014-2015--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  unstable--- Portability :  portable (CPP)------ This module exposes some of the deepseq-bounded Cabal flags,--- so reverse dependencies can check their status.-----------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Flags-  (--    -- * Transient flag while old grammar is phased out--    deepseq_bounded_flag__new_improved_pattern_grammar  ,--#if 0--    -- * Optional NFDataP features--    deepseq_bounded_flag__use_par_patnode  ,-    deepseq_bounded_flag__use_pseq_patnode  ,-    deepseq_bounded_flag__use_trace_patnode  ,-    deepseq_bounded_flag__use_ping_patnode  ,-    deepseq_bounded_flag__use_die_patnode  ,--#endif--#if 0--    -- * Quick and dirty way to get ahold of the ThreadId-    -- of the main thread, when seqaid is being used-    -- on the other side to instrument the executable-    -- we're testing, studying, optimising, whatever...--    deepseq_bounded_ioref__main_thread_id  ,--#endif--  )-  where--  import Data.IORef ( IORef, newIORef )-  import Control.Concurrent ( ThreadId )-  import System.IO.Unsafe ( unsafePerformIO )-----------------------------------------------------------------------------------#if 0--  deepseq_bounded_ioref__main_thread_id-   = unsafePerformIO $ newIORef (undefined::ThreadId)--#endif----------------------------------------------------------------------#if NEW_IMPROVED_PATTERN_GRAMMAR-  deepseq_bounded_flag__new_improved_pattern_grammar = True-#else-  deepseq_bounded_flag__new_improved_pattern_grammar = False-#endif----------------------------------------------------------------------#if 0--#if USE_PAR_PATNODE-  deepseq_bounded_flag__use_par_patnode = True-#else-  deepseq_bounded_flag__use_par_patnode = False-#endif-#if USE_PSEQ_PATNODE-  deepseq_bounded_flag__use_pseq_patnode = True-#else-  deepseq_bounded_flag__use_pseq_patnode = False-#endif-#if USE_TRACE_PATNODE-  deepseq_bounded_flag__use_trace_patnode = True-#else-  deepseq_bounded_flag__use_trace_patnode = False-#endif-#if USE_PING_PATNODE-  deepseq_bounded_flag__use_ping_patnode = True-#else-  deepseq_bounded_flag__use_ping_patnode = False-#endif-#if USE_DIE_PATNODE-  deepseq_bounded_flag__use_die_patnode = True-#else-  deepseq_bounded_flag__use_die_patnode = False-#endif--#endif------------------------------------------------------------------------------------------------------------------------------------------------------

@@ -3,8 +3,65 @@  {-  LANGUAGE CPP #-} +-- (Tracing code has mostly been removed for distribution.)+#define DO_TRACE 0+#define INCLUDE_SHOW_INSTANCES 0+ ------------------------------------------------------------------------------- +-- SOP cheat-sheet.+--+-- class SingI (Code a) => Generic a where+-- Associated Types:+--   type Code a :: [[*]]+-- Methods:+--   from :: a -> Rep a+--   to :: Rep a -> a+--+-- type Rep a = SOP I (Code a)+--+-- newtype SOP f xss = SOP (NS (NP f) xss)+--+-- data NS :: (k -> *) -> [k] -> * where+-- Constructors:+--   Z :: f x -> NS f (x : xs)	 +--   S :: NS f xs -> NS f (x : xs)	 +-- Examples:+--   Z         :: f x -> NS f (x ': xs)+--   S . Z     :: f y -> NS f (x ': y ': xs)+--   S . S . Z :: f z -> NS f (x ': y ': z ': xs)+--+-- data NP :: (k -> *) -> [k] -> * where+-- Constructors:+--   Nil :: NP f []	 +--   (:*) :: f x -> NP f xs -> NP f (x : xs) infixr 5	 +-- Examples (sic! they are correct):+--   I 'x'    :* I True  :* Nil  ::  NP I       '[ Char, Bool ]+--   K 0      :* K 1     :* Nil  ::  NP (K Int) '[ Char, Bool ]+--   Just 'x' :* Nothing :* Nil  ::  NP Maybe   '[ Char, Bool ]+--+--   > :m +Generics.SOP+--   > :m +Foo+--   > Generics.SOP.from $ G2 1 2 3+--   SOP (S (Z (I 1 :* (I 2 :* (I 3 :* Nil)))))+--   > Generics.SOP.to $ Generics.SOP.from $ G2 1 2 3 :: TG+--   G2 1 2 3++-------------------------------------------------------------------------------++  {-# LANGUAGE ScopedTypeVariables #-}+  {-# LANGUAGE DataKinds #-}+  {-# LANGUAGE TypeFamilies #-}+  {-# LANGUAGE ConstraintKinds #-}+#if __GLASGOW_HASKELL__ < 708+  {-# LANGUAGE GADTs #-}+#endif+  {-# LANGUAGE TemplateHaskell #-}++  {-# LANGUAGE BangPatterns #-}  -- only for tracing++-------------------------------------------------------------------------------+ -- | -- Module      :  Control.DeepSeq.Bounded.Generic.GNFDataP -- Copyright   :  Andrew G. Seniuk 2014-2015@@ -59,10 +116,14 @@   module Control.DeepSeq.Bounded.Generic.GNFDataP   ( -#if NEW_IMPROVED_PATTERN_GRAMMAR-    module Control.DeepSeq.Bounded.Generic.GNFDataP_new_grammar  ,-#else-    module Control.DeepSeq.Bounded.Generic.GNFDataP_old_grammar  ,+      grnfp++#if 0+      -- * "Control.DeepSeq" re-exports+    , deepseq+    , force+    , NFData ( rnf )+    , ($!!) #endif    )@@ -71,15 +132,322 @@ -------------------------------------------------------------------------------    -- for Haddock!-  import Control.DeepSeq.Bounded.NFDataP ( NFDataP )+--import Control.DeepSeq.Bounded.NFDataP ( NFDataP )    import Control.DeepSeq.Bounded.NFDataN ( NFDataN )   import Control.DeepSeq ( NFData )   import Data.Typeable ( Typeable ) -#if NEW_IMPROVED_PATTERN_GRAMMAR-  import Control.DeepSeq.Bounded.Generic.GNFDataP_new_grammar+  import Control.DeepSeq.Bounded.NFDataP ( NFDataP, rnfp )+  import Control.DeepSeq.Bounded.NFDataN (          rnfn )+  import Control.DeepSeq                 (          rnf  )++  import Control.DeepSeq.Bounded.NFDataP ( handleAttrs )++  import Control.DeepSeq.Bounded.Pattern ( Rose(..), Pattern(..) )+  import Control.DeepSeq.Bounded.Pattern ( PatNode(..), PatNodeAttrs(..) )+  import Control.DeepSeq.Bounded.Pattern ( getPatNodeAttrs )++  import Generics.SOP++#if USE_PAR_PATNODE+  import Control.Parallel ( par )+#endif+--- #warning GNFDataP USE_PSEQ_PATNODE still to do!...+#if USE_PSEQ_PATNODE+  import Control.Parallel ( pseq )+#endif++  import Data.Maybe+  import Debug.Trace ( trace )+--import System.IO.Unsafe ( unsafePerformIO )  -- for console output only++-------------------------------------------------------------------------------++#if DO_TRACE+  mytrace = trace+  mytrace' = trace #else-  import Control.DeepSeq.Bounded.Generic.GNFDataP_old_grammar+  mytrace x y = y+  mytrace' x y = y+#endif++-------------------------------------------------------------------------------++  grnfp :: forall a.+           (+             Generic a+           , HasDatatypeInfo a+--         , All Show (Map ConstructorInfo (Code a))+           , All2 NFDataP (Code a)+#if INCLUDE_SHOW_INSTANCES+           , All2 Show (Code a)+#endif+           , NFDataP a  -- NFData, NFDataN superclasses+           ) => Pattern -> a -> ()+  grnfp pat x = grnfp' dti proxy_a pat x xrep+   where+    dti = datatypeInfo proxy_a+    proxy_a = Proxy :: Proxy a+    xrep = from x++-------------------------------------------------------------------------------++  -- Show constraint is needed, but not NFData nor NFDataN.+  -- Not quite sure why, but whatever...+  grnfp' :: forall a.+            (+              Generic a+            , HasDatatypeInfo a+            , All2 NFDataP (Code a)+#if INCLUDE_SHOW_INSTANCES+            , All2 Show (Code a)+#endif+            , NFDataP a  -- NFData, NFDataN superclasses+            ) =>+                    DatatypeInfo (Code a)+                 -> Proxy a+                 -> Pattern+                 -> a+                 -> Rep a+                 -> ()+  grnfp' (ADT     _ _ cs) proxy_a pat x xrep+   = grnfpS cs         proxy_a pat x xrep+  grnfp' (Newtype _ _ c ) proxy_a pat x xrep+   = grnfpS (c :* Nil) proxy_a pat x xrep++-------------------------------------------------------------------------------++-- SOP works (here) by hitting the Z (meta)constructor for the+-- particular datatype constructor which is [inhabited].+-- i.e. This simply dials in the correct constructor.+-- Later: Looks like it does a bit more than that, now.+  grnfpS :: forall a xss.+            (+              All2 NFDataP xss+#if INCLUDE_SHOW_INSTANCES+            , All2 Show xss+#endif+            , NFDataP a  -- NFData, NFDataN superclasses+            ) =>+                    NP ConstructorInfo xss+                 -> Proxy a+                 -> Pattern+                 -> a+                 -> SOP I xss+                 -> ()++  grnfpS _ _ (Node WI{} _) _ _ = ()  -- needed!!+--grnfpS _ _ (Node WI{} _) _ (SOP (Z xs)) = ()  -- mustn't do!!+--grnfpS (m :* _) _ (Node WI{} _) _ _ = ()  -- seems not to spring the bottom++  grnfpS (m :* _) proxy_a pat@(Node pas pcs) x (SOP (Z xs))+--- | WI{} <- pas  = ()  -- too late! (SOP (Z xs)) has already forced+   | not status     = patMatchFail'' msg `seq` ()+--- | WI{} <- pas  = ()+   | handleAttrs pat x `seq` pat == Node XX []  = undefined+#if USE_PAR_PATNODE+   | doSpark as  = case pas of+       WW{} -> rnf x `par` ()+       WN{} -> rnfn n x `par` ()+       otherwise -> dorecurs+#endif+-- XXX So these TR and TI (and TW?... TN?...) also need to be up+-- in a top-level case before this one!+   | TR{} <- pas  = if elem tx treps then dorecurs else ()+#if USE_WW_DEEPSEQ+   | TI{} <- pas  = if elem tx treps then () else rnf x+   | TW{} <- pas  = if elem tx treps then rnf x else ()+#else+   | TI{} <- pas  = if elem tx treps then () else rnfn 999999 x  -- XXX thack!+#endif+--- | TI{} <- pas  = if elem tx treps then () else dorecurs+#if USE_WW_DEEPSEQ+   | WW{} <- pas  = rnf x+#endif+   | WN{} <- pas  = rnfn n x+#if USE_WW_DEEPSEQ+   | TW{} <- pas  = if elem tx treps then rnf x else ()  -- no better!+#endif+   | otherwise    = dorecurs+   where+    as = getPatNodeAttrs pas+    treps = typeConstraints as+    n = depth as+    (status,mmsg)  = grnfpP_validate True pas pcs tx xs+    !_ = mytrace ("*** "++tx) $ ()+    tx | (Constructor n) <- m  = n+       | (Infix n _ _) <- m    = n+       | (Record n _) <- m     = n+    !_ = mytrace ("VVV "++show status) $ ()+    msg = fromJust mmsg+#if USE_PAR_PATNODE+#if DO_TRACE+    dorecurs | doSpark as  = grnfpP_ m () True pas pcs xs `par` ()+             | otherwise   = grnfpP_ m () True pas pcs xs `seq` ()+#else+    dorecurs | doSpark as  = grnfpP m () True pas pcs xs `par` ()+             | otherwise   = grnfpP m () True pas pcs xs `seq` ()+#endif+#else+#if DO_TRACE+    dorecurs = grnfpP_ m () True p pcs xs `seq` ()+#else+    dorecurs = grnfpP m () True p pcs xs `seq` ()+#endif+#endif++  grnfpS (m :* ms) proxy_a pat x (SOP (S xss))+   = grnfpS ms proxy_a pat x (SOP xss)++  grnfpS _ _ _ _ _ = error "grnfpS: unexpected case!!"++-------------------------------------------------------------------------------++  grnfpP :: forall cs xs.+            (+              All NFDataP xs+#if INCLUDE_SHOW_INSTANCES+            , All Show xs+#endif+            ) =>+                    ConstructorInfo cs+                 -> ()+                 -> Bool+                 -> PatNode+                 -> [Pattern]+                 -> NP I xs+                 -> ()+  grnfpP ci acc b pp [] Nil = acc+  grnfpP ci acc True pp [] (I x :* xs)+   = grnfpP ci acc True pp [] xs+  grnfpP ci acc b pp (p@(Node pas pgcs):pcs) (I x :* xs)+   = grnfpP ci (acc `seq` step) False pp pcs xs+   where+    step | WI{} <- pas  = ()+         | TR{} <- pas  = if elem tx treps then thestep else ()+#if USE_WW_DEEPSEQ+         | TI{} <- pas  = if elem tx treps then () else rnf x+         | TW{} <- pas  = if elem tx treps then rnf x else ()+#else+         | TI{} <- pas  = if elem tx treps then () else rnfn 999999 x  -- XXX thack!+#endif+---      | TI{} <- pas  = if elem tx treps then () else thestep+         | otherwise    = thestep+     where+      as = getPatNodeAttrs pas+      treps = typeConstraints as+      thestep = rnfp p x+      tx | (Constructor n) <- ci  = n+         | (Infix n _ _) <- ci    = n+         | (Record n _) <- ci     = n+  grnfpP ci acc b pp ps xs+   = error $ "*6* "++show b++" "++show pp++" "++show ps++" "++show (lenxs xs)++-------------------------------------------------------------------------------++  -- Preliminary check for arity mismatch or constructor name mismatch.+  -- Note: I don't presently know of a way to obtain the arity of a ctor+  -- from it's name as a String. Arity checking is done between the+  -- pattern and the value, but the arity of a ctor named in a pattern+  -- constraints is not available.+  grnfpP_validate :: forall xs.+            (+              All NFDataP xs+#if INCLUDE_SHOW_INSTANCES+            , All Show xs+#endif+            ) =>+                    Bool+                 -> PatNode+                 -> [Pattern]+                 -> String+                 -> NP I xs+                 -> (Bool, Maybe String)+  grnfpP_validate True  pp@(TR as) ps tx xss+   | b          = grnfpP_validate' True pp ps tx xss+   | otherwise  = (False,Just $ "<generic> TR ctor name constraint mismatch (not "++tx++")")+   where b = head cnames == tx+         cnames = typeConstraints as+#if USE_WW_DEEPSEQ+  grnfpP_validate True  pp@(TW as) ps tx xss+   | b          = grnfpP_validate' True pp ps tx xss+   | otherwise  = (False,Just $ "<generic> TW ctor [should be type!] name constraint mismatch (not "++tx++")")+   where b = head cnames == tx+         cnames = typeConstraints as+#endif+  grnfpP_validate True  pp@(TI as) ps tx xss+   | b          = grnfpP_validate' True pp ps tx xss+   | otherwise  = (False,Just $ "<generic> TI ctor [should be type!] name constraint mismatch (not "++tx++")")+   where b = head cnames == tx+         cnames = typeConstraints as+  grnfpP_validate b     pp             ps tx xss+   = grnfpP_validate' b pp ps tx xss++  grnfpP_validate' :: forall xs.+            (+              All NFDataP xs+#if INCLUDE_SHOW_INSTANCES+            , All Show xs+#endif+            ) =>+                    Bool+                 -> PatNode+                 -> [Pattern]+                 -> String+                 -> NP I xs+                 -> (Bool, Maybe String)+  grnfpP_validate' True  (WI as) []  tx xss = (True,Nothing)+  grnfpP_validate' True  (WS as) []  tx xss = (True,Nothing)+  grnfpP_validate' True  (WN as) []  tx xss = (True,Nothing)+  grnfpP_validate' True  (WW as) []  tx xss = (True,Nothing)+  grnfpP_validate' True   pp     ps  tx xss+   | WS{} <- pp  = if lenps > 0 then (False,Nothing) else (True,Nothing)+   | b           = (True,Nothing)+   | otherwise   = (False,Just "<generic> arity mismatch #1")+   where+-- oops+--  as = getPatNodeAttrs pp+--  n = depth as+    b = lenps == lenxs xss+    lenps = length ps+  grnfpP_validate' False pp []      tx Nil+   = (True,Nothing)+  grnfpP_validate' False pp (p:pcs) tx (I x :* xs)+   = grnfpP_validate False pp pcs tx xs+  grnfpP_validate' b pp ps tx xs+   = error $ " &&& " ++ show b ++ " " ++ show pp ++ " " ++ show ps+-- = error $ show b ++ " " ++ show pp ++ " " ++ show ps ++ " " ++ show (hcliftA (Proxy :: Proxy Show) (K . show . unI) xs)++-------------------------------------------------------------------------------++  lenxs :: NP I xs' -> Int+  lenxs Nil = 0+  lenxs (I x' :* xs') = 1 + lenxs xs'+  lenxs _ = error "lenxs: unexpected"++-------------------------------------------------------------------------------++#if 0+-- Works so far as it goes, but is not currently used.+-- Also, this is exactly Data.Generics.Schemes.glength+  arity :: Data a => a -> Int+  arity = length . gmapQ (const ())+#endif++-------------------------------------------------------------------------------++  patMatchFail'' :: String -> ()+  patMatchFail'' msg+#if 0+     -- With this, the expected match failures are seen.+     = error "BOO!!!!"+#else+#if WARN_PATTERN_MATCH_FAILURE+     = trace ("GNFDataP: warning: pattern match failure (" ++ msg ++ ")") $ ()+--   = unsafePerformIO $! putStrLn $! "GNFDataP: warning: pattern match failure (" ++ msg ++ ")"+#else+     = ()+#endif #endif  -------------------------------------------------------------------------------

@@ -1,454 +0,0 @@-----------------------------------------------------------------------------------{-  LANGUAGE CPP #-}---- (Tracing code has mostly been removed for distribution.)-#define DO_TRACE 0-#define INCLUDE_SHOW_INSTANCES 0------------------------------------------------------------------------------------- SOP cheat-sheet.------ class SingI (Code a) => Generic a where--- Associated Types:---   type Code a :: [[*]]--- Methods:---   from :: a -> Rep a---   to :: Rep a -> a------ type Rep a = SOP I (Code a)------ newtype SOP f xss = SOP (NS (NP f) xss)------ data NS :: (k -> *) -> [k] -> * where--- Constructors:---   Z :: f x -> NS f (x : xs)	 ---   S :: NS f xs -> NS f (x : xs)	 --- Examples:---   Z         :: f x -> NS f (x ': xs)---   S . Z     :: f y -> NS f (x ': y ': xs)---   S . S . Z :: f z -> NS f (x ': y ': z ': xs)------ data NP :: (k -> *) -> [k] -> * where--- Constructors:---   Nil :: NP f []	 ---   (:*) :: f x -> NP f xs -> NP f (x : xs) infixr 5	 --- Examples (sic! they are correct):---   I 'x'    :* I True  :* Nil  ::  NP I       '[ Char, Bool ]---   K 0      :* K 1     :* Nil  ::  NP (K Int) '[ Char, Bool ]---   Just 'x' :* Nothing :* Nil  ::  NP Maybe   '[ Char, Bool ]------   > :m +Generics.SOP---   > :m +Foo---   > Generics.SOP.from $ G2 1 2 3---   SOP (S (Z (I 1 :* (I 2 :* (I 3 :* Nil)))))---   > Generics.SOP.to $ Generics.SOP.from $ G2 1 2 3 :: TG---   G2 1 2 3-----------------------------------------------------------------------------------  {-# LANGUAGE ScopedTypeVariables #-}-  {-# LANGUAGE DataKinds #-}-  {-# LANGUAGE TypeFamilies #-}-  {-# LANGUAGE ConstraintKinds #-}-#if __GLASGOW_HASKELL__ < 708-  {-# LANGUAGE GADTs #-}-#endif-  {-# LANGUAGE TemplateHaskell #-}--  {-# LANGUAGE BangPatterns #-}  -- only for tracing------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Generic.GNFDataP_new_grammar--- Copyright   :  Andrew G. Seniuk 2014-2015--- License     :  BSD-style (see the LICENSE file)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  GHC (uses SOP)------ Support for generic deriving (via <http://hackage.haskell.org/package/generics-sop/docs/Generics-SOP.html Generics.SOP>) of 'NFDataP' instances.------ Note that 'NFDataP' has superclasses 'NFDataN', 'NFData' and 'Typeable'.------ This metaboilerplate is standard for using the generic deriving--- facilities of "GHC.Generics" and <http://hackage.haskell.org/package/generics-sop/docs/Generics-SOP.html Generics.SOP>.--- Consider <http://hackage.haskell.org/package/seqaid seqaid> for--- a turnkey solution.------ > {-# LANGUAGE TemplateHaskell #-}--- > {-# LANGUAGE DataKinds #-}--- > {-# LANGUAGE TypeFamilies #-}--- > {-# LANGUAGE DeriveGeneric #-}--- > {-# LANGUAGE DeriveDataTypeable #-}--- > {-# LANGUAGE GADTs #-}  -- for GHC < 7.8 (== 7.6.3)--- > --- > import Generics.SOP.TH--- > import Control.DeepSeq.Bounded ( NFDataP(..), grnfp )--- > import Control.DeepSeq.Bounded ( NFDataN(..), grnfn )--- > import Control.DeepSeq.Generics ( NFData(..), genericRnf )--- > import GHC.Generics ( Generic )    -- for deriving NFData--- > import Data.Typeable ( Typeable )  -- for name-constrained pattern nodes--- >--- > import Control.DeepSeq.Bounded ( forcep )--- > --- > data TA = A1 TB TA | A2  deriving ( Generic, Typeable )--- > instance NFData  TA where rnf  = genericRnf--- > instance NFDataN TA where rnfn = grnfn--- > instance NFDataP TA where rnfp = grnfp--- > --- > data TB = B1 Int | B2 TA  deriving ( Generic, Typeable )--- > instance NFData  TB where rnf  = genericRnf--- > instance NFDataN TB where rnfn = grnfn--- > instance NFDataP TB where rnfp = grnfp--- > --- > deriveGeneric ''TA--- > deriveGeneric ''TB--- >--- > main = return $! forcep "((!).)" (A1 (B2 undefined) A2)-----------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Generic.GNFDataP_new_grammar-  (--      grnfp--#if 0-      -- * "Control.DeepSeq" re-exports-    , deepseq-    , force-    , NFData ( rnf )-    , ($!!)-#endif--  )-  where-----------------------------------------------------------------------------------  -- for Haddock!---import Control.DeepSeq.Bounded.NFDataP ( NFDataP ) -  import Control.DeepSeq.Bounded.NFDataN ( NFDataN )-  import Control.DeepSeq ( NFData )-  import Data.Typeable ( Typeable )--  import Control.DeepSeq.Bounded.NFDataP ( NFDataP, rnfp )-  import Control.DeepSeq.Bounded.NFDataN (          rnfn )-  import Control.DeepSeq                 (          rnf  )--  import Control.DeepSeq.Bounded.NFDataP ( handleAttrs )--  import Control.DeepSeq.Bounded.Pattern ( Rose(..), Pattern(..) )-  import Control.DeepSeq.Bounded.Pattern ( PatNode(..), PatNodeAttrs(..) )-  import Control.DeepSeq.Bounded.Pattern ( getPatNodeAttrs )--  import Generics.SOP--#if USE_PAR_PATNODE-  import Control.Parallel ( par )-#endif---- #warning GNFDataP USE_PSEQ_PATNODE still to do!...-#if USE_PSEQ_PATNODE-  import Control.Parallel ( pseq )-#endif--  import Data.Maybe-  import Debug.Trace ( trace )---import System.IO.Unsafe ( unsafePerformIO )  -- for console output only-----------------------------------------------------------------------------------#if DO_TRACE-  mytrace = trace-  mytrace' = trace-#else-  mytrace x y = y-  mytrace' x y = y-#endif-----------------------------------------------------------------------------------  grnfp :: forall a.-           (-             Generic a-           , HasDatatypeInfo a---         , All Show (Map ConstructorInfo (Code a))-           , All2 NFDataP (Code a)-#if INCLUDE_SHOW_INSTANCES-           , All2 Show (Code a)-#endif-           , NFDataP a  -- NFData, NFDataN superclasses-           ) => Pattern -> a -> ()-  grnfp pat x = grnfp' dti proxy_a pat x xrep-   where-    dti = datatypeInfo proxy_a-    proxy_a = Proxy :: Proxy a-    xrep = from x-----------------------------------------------------------------------------------  -- Show constraint is needed, but not NFData nor NFDataN.-  -- Not quite sure why, but whatever...-  grnfp' :: forall a.-            (-              Generic a-            , HasDatatypeInfo a-            , All2 NFDataP (Code a)-#if INCLUDE_SHOW_INSTANCES-            , All2 Show (Code a)-#endif-            , NFDataP a  -- NFData, NFDataN superclasses-            ) =>-                    DatatypeInfo (Code a)-                 -> Proxy a-                 -> Pattern-                 -> a-                 -> Rep a-                 -> ()-  grnfp' (ADT     _ _ cs) proxy_a pat x xrep-   = grnfpS cs         proxy_a pat x xrep-  grnfp' (Newtype _ _ c ) proxy_a pat x xrep-   = grnfpS (c :* Nil) proxy_a pat x xrep------------------------------------------------------------------------------------- SOP works (here) by hitting the Z (meta)constructor for the--- particular datatype constructor which is [inhabited].--- i.e. This simply dials in the correct constructor.--- Later: Looks like it does a bit more than that, now.-  grnfpS :: forall a xss.-            (-              All2 NFDataP xss-#if INCLUDE_SHOW_INSTANCES-            , All2 Show xss-#endif-            , NFDataP a  -- NFData, NFDataN superclasses-            ) =>-                    NP ConstructorInfo xss-                 -> Proxy a-                 -> Pattern-                 -> a-                 -> SOP I xss-                 -> ()--  grnfpS _ _ (Node WI{} _) _ _ = ()  -- needed!!---grnfpS _ _ (Node WI{} _) _ (SOP (Z xs)) = ()  -- mustn't do!!---grnfpS (m :* _) _ (Node WI{} _) _ _ = ()  -- seems not to spring the bottom--  grnfpS (m :* _) proxy_a pat@(Node pas pcs) x (SOP (Z xs))---- | WI{} <- pas  = ()  -- too late! (SOP (Z xs)) has already forced-   | not status     = patMatchFail'' msg `seq` ()---- | WI{} <- pas  = ()-   | handleAttrs pat x `seq` pat == Node XX []  = undefined-#if USE_PAR_PATNODE-   | doSpark as  = case pas of-       WW{} -> rnf x `par` ()-       WN{} -> rnfn n x `par` ()-       otherwise -> dorecurs-#endif--- XXX So these TR and TI (and TW?... TN?...) also need to be up--- in a top-level case before this one!-   | TR{} <- pas  = if elem tx treps then dorecurs else ()-#if USE_WW_DEEPSEQ-   | TI{} <- pas  = if elem tx treps then () else rnf x-   | TW{} <- pas  = if elem tx treps then rnf x else ()-#else-   | TI{} <- pas  = if elem tx treps then () else rnfn 999999 x  -- XXX thack!-#endif---- | TI{} <- pas  = if elem tx treps then () else dorecurs-#if USE_WW_DEEPSEQ-   | WW{} <- pas  = rnf x-#endif-   | WN{} <- pas  = rnfn n x-#if USE_WW_DEEPSEQ-   | TW{} <- pas  = if elem tx treps then rnf x else ()  -- no better!-#endif-   | otherwise    = dorecurs-   where-    as = getPatNodeAttrs pas-    treps = typeConstraints as-    n = depth as-    (status,mmsg)  = grnfpP_validate True pas pcs tx xs-    !_ = mytrace ("*** "++tx) $ ()-    tx | (Constructor n) <- m  = n-       | (Infix n _ _) <- m    = n-       | (Record n _) <- m     = n-    !_ = mytrace ("VVV "++show status) $ ()-    msg = fromJust mmsg-#if USE_PAR_PATNODE-#if DO_TRACE-    dorecurs | doSpark as  = grnfpP_ m () True pas pcs xs `par` ()-             | otherwise   = grnfpP_ m () True pas pcs xs `seq` ()-#else-    dorecurs | doSpark as  = grnfpP m () True pas pcs xs `par` ()-             | otherwise   = grnfpP m () True pas pcs xs `seq` ()-#endif-#else-#if DO_TRACE-    dorecurs = grnfpP_ m () True p pcs xs `seq` ()-#else-    dorecurs = grnfpP m () True p pcs xs `seq` ()-#endif-#endif--  grnfpS (m :* ms) proxy_a pat x (SOP (S xss))-   = grnfpS ms proxy_a pat x (SOP xss)--  grnfpS _ _ _ _ _ = error "grnfpS: unexpected case!!"-----------------------------------------------------------------------------------  grnfpP :: forall cs xs.-            (-              All NFDataP xs-#if INCLUDE_SHOW_INSTANCES-            , All Show xs-#endif-            ) =>-                    ConstructorInfo cs-                 -> ()-                 -> Bool-                 -> PatNode-                 -> [Pattern]-                 -> NP I xs-                 -> ()-  grnfpP ci acc b pp [] Nil = acc-  grnfpP ci acc True pp [] (I x :* xs)-   = grnfpP ci acc True pp [] xs-  grnfpP ci acc b pp (p@(Node pas pgcs):pcs) (I x :* xs)-   = grnfpP ci (acc `seq` step) False pp pcs xs-   where-    step | WI{} <- pas  = ()-         | TR{} <- pas  = if elem tx treps then thestep else ()-#if USE_WW_DEEPSEQ-         | TI{} <- pas  = if elem tx treps then () else rnf x-         | TW{} <- pas  = if elem tx treps then rnf x else ()-#else-         | TI{} <- pas  = if elem tx treps then () else rnfn 999999 x  -- XXX thack!-#endif----      | TI{} <- pas  = if elem tx treps then () else thestep-         | otherwise    = thestep-     where-      as = getPatNodeAttrs pas-      treps = typeConstraints as-      thestep = rnfp p x-      tx | (Constructor n) <- ci  = n-         | (Infix n _ _) <- ci    = n-         | (Record n _) <- ci     = n-  grnfpP ci acc b pp ps xs-   = error $ "*6* "++show b++" "++show pp++" "++show ps++" "++show (lenxs xs)-----------------------------------------------------------------------------------  -- Preliminary check for arity mismatch or constructor name mismatch.-  -- Note: I don't presently know of a way to obtain the arity of a ctor-  -- from it's name as a String. Arity checking is done between the-  -- pattern and the value, but the arity of a ctor named in a pattern-  -- constraints is not available.-  grnfpP_validate :: forall xs.-            (-              All NFDataP xs-#if INCLUDE_SHOW_INSTANCES-            , All Show xs-#endif-            ) =>-                    Bool-                 -> PatNode-                 -> [Pattern]-                 -> String-                 -> NP I xs-                 -> (Bool, Maybe String)-  grnfpP_validate True  pp@(TR as) ps tx xss-   | b          = grnfpP_validate' True pp ps tx xss-   | otherwise  = (False,Just $ "<generic> TR ctor name constraint mismatch (not "++tx++")")-   where b = head cnames == tx-         cnames = typeConstraints as-#if USE_WW_DEEPSEQ-  grnfpP_validate True  pp@(TW as) ps tx xss-   | b          = grnfpP_validate' True pp ps tx xss-   | otherwise  = (False,Just $ "<generic> TW ctor [should be type!] name constraint mismatch (not "++tx++")")-   where b = head cnames == tx-         cnames = typeConstraints as-#endif-  grnfpP_validate True  pp@(TI as) ps tx xss-   | b          = grnfpP_validate' True pp ps tx xss-   | otherwise  = (False,Just $ "<generic> TI ctor [should be type!] name constraint mismatch (not "++tx++")")-   where b = head cnames == tx-         cnames = typeConstraints as-  grnfpP_validate b     pp             ps tx xss-   = grnfpP_validate' b pp ps tx xss--  grnfpP_validate' :: forall xs.-            (-              All NFDataP xs-#if INCLUDE_SHOW_INSTANCES-            , All Show xs-#endif-            ) =>-                    Bool-                 -> PatNode-                 -> [Pattern]-                 -> String-                 -> NP I xs-                 -> (Bool, Maybe String)-  grnfpP_validate' True  (WI as) []  tx xss = (True,Nothing)-  grnfpP_validate' True  (WS as) []  tx xss = (True,Nothing)-  grnfpP_validate' True  (WN as) []  tx xss = (True,Nothing)-  grnfpP_validate' True  (WW as) []  tx xss = (True,Nothing)-  grnfpP_validate' True   pp     ps  tx xss-   | WS{} <- pp  = if lenps > 0 then (False,Nothing) else (True,Nothing)-   | b           = (True,Nothing)-   | otherwise   = (False,Just "<generic> arity mismatch #1")-   where--- oops---  as = getPatNodeAttrs pp---  n = depth as-    b = lenps == lenxs xss-    lenps = length ps-  grnfpP_validate' False pp []      tx Nil-   = (True,Nothing)-  grnfpP_validate' False pp (p:pcs) tx (I x :* xs)-   = grnfpP_validate False pp pcs tx xs-  grnfpP_validate' b pp ps tx xs-   = error $ " &&& " ++ show b ++ " " ++ show pp ++ " " ++ show ps--- = error $ show b ++ " " ++ show pp ++ " " ++ show ps ++ " " ++ show (hcliftA (Proxy :: Proxy Show) (K . show . unI) xs)-----------------------------------------------------------------------------------  lenxs :: NP I xs' -> Int-  lenxs Nil = 0-  lenxs (I x' :* xs') = 1 + lenxs xs'-  lenxs _ = error "lenxs: unexpected"-----------------------------------------------------------------------------------#if 0--- Works so far as it goes, but is not currently used.--- Also, this is exactly Data.Generics.Schemes.glength-  arity :: Data a => a -> Int-  arity = length . gmapQ (const ())-#endif-----------------------------------------------------------------------------------  patMatchFail'' :: String -> ()-  patMatchFail'' msg-#if 0-     -- With this, the expected match failures are seen.-     = error "BOO!!!!"-#else-#if WARN_PATTERN_MATCH_FAILURE-     = trace ("GNFDataP: warning: pattern match failure (" ++ msg ++ ")") $ ()---   = unsafePerformIO $! putStrLn $! "GNFDataP: warning: pattern match failure (" ++ msg ++ ")"-#else-     = ()-#endif-#endif----------------------------------------------------------------------------------

@@ -1,411 +0,0 @@-----------------------------------------------------------------------------------{-  LANGUAGE CPP #-}---- (Tracing code has mostly been removed for distribution.)-#define DO_TRACE 0-#define INCLUDE_SHOW_INSTANCES 0------------------------------------------------------------------------------------- SOP cheat-sheet.------ class SingI (Code a) => Generic a where--- Associated Types:---   type Code a :: [[*]]--- Methods:---   from :: a -> Rep a---   to :: Rep a -> a------ type Rep a = SOP I (Code a)------ newtype SOP f xss = SOP (NS (NP f) xss)------ data NS :: (k -> *) -> [k] -> * where--- Constructors:---   Z :: f x -> NS f (x : xs)	 ---   S :: NS f xs -> NS f (x : xs)	 --- Examples:---   Z         :: f x -> NS f (x ': xs)---   S . Z     :: f y -> NS f (x ': y ': xs)---   S . S . Z :: f z -> NS f (x ': y ': z ': xs)------ data NP :: (k -> *) -> [k] -> * where--- Constructors:---   Nil :: NP f []	 ---   (:*) :: f x -> NP f xs -> NP f (x : xs) infixr 5	 --- Examples (sic! they are correct):---   I 'x'    :* I True  :* Nil  ::  NP I       '[ Char, Bool ]---   K 0      :* K 1     :* Nil  ::  NP (K Int) '[ Char, Bool ]---   Just 'x' :* Nothing :* Nil  ::  NP Maybe   '[ Char, Bool ]------   > :m +Generics.SOP---   > :m +Foo---   > Generics.SOP.from $ G2 1 2 3---   SOP (S (Z (I 1 :* (I 2 :* (I 3 :* Nil)))))---   > Generics.SOP.to $ Generics.SOP.from $ G2 1 2 3 :: TG---   G2 1 2 3-----------------------------------------------------------------------------------  {-# LANGUAGE ScopedTypeVariables #-}-  {-# LANGUAGE DataKinds #-}-  {-# LANGUAGE TypeFamilies #-}-  {-# LANGUAGE ConstraintKinds #-}-#if __GLASGOW_HASKELL__ < 708-  {-# LANGUAGE GADTs #-}-#endif-  {-# LANGUAGE TemplateHaskell #-}--  {-# LANGUAGE BangPatterns #-}  -- only for tracing------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Generic.GNFDataP_old_grammar--- Copyright   :  Andrew G. Seniuk 2014-2015--- License     :  BSD-style (see the LICENSE file)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  GHC (uses SOP)------ Support for generic deriving (via <http://hackage.haskell.org/package/generics-sop/docs/Generics-SOP.html Generics.SOP>) of 'NFDataP' instances.------ Note that 'NFDataP' has superclasses 'NFDataN', 'NFData' and 'Typeable'.------ This metaboilerplate is standard for using the generic deriving--- facilities of "GHC.Generics" and <http://hackage.haskell.org/package/generics-sop/docs/Generics-SOP.html Generics.SOP>.--- Consider <http://hackage.haskell.org/package/seqaid seqaid> for--- a turnkey solution.------ > {-# LANGUAGE TemplateHaskell #-}--- > {-# LANGUAGE DataKinds #-}--- > {-# LANGUAGE TypeFamilies #-}--- > {-# LANGUAGE DeriveGeneric #-}--- > {-# LANGUAGE DeriveDataTypeable #-}--- > {-# LANGUAGE GADTs #-}  -- for GHC < 7.8 (== 7.6.3)--- > --- > import Generics.SOP.TH--- > import Control.DeepSeq.Bounded ( NFDataP(..), grnfp )--- > import Control.DeepSeq.Bounded ( NFDataN(..), grnfn )--- > import Control.DeepSeq.Generics ( NFData(..), genericRnf )--- > import GHC.Generics ( Generic )    -- for deriving NFData--- > import Data.Typeable ( Typeable )  -- for name-constrained pattern nodes--- >--- > import Control.DeepSeq.Bounded ( forcep )--- > --- > data TA = A1 TB TA | A2  deriving ( Generic, Typeable )--- > instance NFData  TA where rnf  = genericRnf--- > instance NFDataN TA where rnfn = grnfn--- > instance NFDataP TA where rnfp = grnfp--- > --- > data TB = B1 Int | B2 TA  deriving ( Generic, Typeable )--- > instance NFData  TB where rnf  = genericRnf--- > instance NFDataN TB where rnfn = grnfn--- > instance NFDataP TB where rnfp = grnfp--- > --- > deriveGeneric ''TA--- > deriveGeneric ''TB--- >--- > main = return $! forcep ".{.{.}.}" (A1 (B2 undefined) A2)-----------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Generic.GNFDataP_old_grammar-  (--      grnfp--#if 0-      -- * "Control.DeepSeq" re-exports-    , deepseq-    , force-    , NFData ( rnf )-    , ($!!)-#endif--  )-  where-----------------------------------------------------------------------------------  import Control.DeepSeq.Bounded.NFDataP ( NFDataP, rnfp )-  import Control.DeepSeq.Bounded.NFDataN (          rnfn )-  import Control.DeepSeq                 (          rnf  )--  import Control.DeepSeq.Bounded.Pattern ( Pattern(..), PatNode(..), Rose(..) )--  import Generics.SOP--#if PARALLELISM_EXPERIMENT-  import Control.Parallel ( par )-#endif--  import Data.Maybe-  import Debug.Trace ( trace )---import System.IO.Unsafe ( unsafePerformIO )  -- for console output only-----------------------------------------------------------------------------------#if DO_TRACE-  mytrace = trace-  mytrace' = trace-#else-  mytrace x y = y-  mytrace' x y = y-#endif-----------------------------------------------------------------------------------  grnfp :: forall a.-           (-             Generic a-           , HasDatatypeInfo a---         , All Show (Map ConstructorInfo (Code a))-           , All2 NFDataP (Code a)-#if INCLUDE_SHOW_INSTANCES-           , All2 Show (Code a)-#endif-           , NFDataP a  -- NFData, NFDataN superclasses-           ) => Pattern -> a -> ()-  grnfp pat x = grnfp' dti proxy_a pat x xrep-   where-    dti = datatypeInfo proxy_a-    proxy_a = Proxy :: Proxy a-    xrep = from x-----------------------------------------------------------------------------------  -- Show constraint is needed, but not NFData nor NFDataN.-  -- Not quite sure why, but whatever...-  grnfp' :: forall a.-            (-              Generic a-            , HasDatatypeInfo a-            , All2 NFDataP (Code a)-#if INCLUDE_SHOW_INSTANCES-            , All2 Show (Code a)-#endif-            , NFDataP a  -- NFData, NFDataN superclasses-            ) =>-                    DatatypeInfo (Code a)-                 -> Proxy a-                 -> Pattern-                 -> a-                 -> Rep a-                 -> ()-  grnfp' (ADT     _ _ cs) proxy_a pat x xrep-   = grnfpS cs         proxy_a pat x xrep-  grnfp' (Newtype _ _ c ) proxy_a pat x xrep-   = grnfpS (c :* Nil) proxy_a pat x xrep------------------------------------------------------------------------------------- SOP works (here) by hitting the Z (meta)constructor for the--- particular datatype constructor which is [inhabited].--- i.e. This simply dials in the correct constructor.--- Later: Looks like it does a bit more than that, now.-  grnfpS :: forall a xss.-            (-              All2 NFDataP xss-#if INCLUDE_SHOW_INSTANCES-            , All2 Show xss-#endif-            , NFDataP a  -- NFData, NFDataN superclasses-            ) =>-                    NP ConstructorInfo xss-                 -> Proxy a-                 -> Pattern-                 -> a-                 -> SOP I xss-                 -> ()--  grnfpS _ _ (Node WI _) _ _ = ()  -- needed!!---grnfpS _ _ (Node WI _) _ (SOP (Z xs)) = ()  -- mustn't do!!---grnfpS (m :* _) _ (Node WI _) _ _ = ()  -- seems not to spring the bottom--  grnfpS (m :* _) proxy_a (Node p pcs) x (SOP (Z xs))---- | WI       <- p  = ()  -- too late! (SOP (Z xs)) has already forced-   | not status     = patMatchFail'' msg `seq` ()---- | WI       <- p  = ()--- XXX So these TR and TI (and TW?... TN?...) also need to be up--- in a top-level case before this one!-   | TR treps <- p  = if elem tx treps then dorecurs else ()-   | TI treps <- p  = if elem tx treps then () else dorecurs-   | WW       <- p  = rnf x-   | WN n     <- p  = rnfn n x-#if PARALLELISM_EXPERIMENT-   | PW       <- p  = rnf x `par` ()-   | PN n     <- p  = rnfn n x `par` ()-#endif-   | TW treps <- p  = if elem tx treps then rnf x else ()  -- no better!-   | otherwise      = dorecurs-   where-    (status,mmsg)  = grnfpP_validate True p pcs tx xs-    !_ = mytrace ("*** "++tx) $ ()-    tx | (Constructor n) <- m  = n-       | (Infix n _ _) <- m    = n-       | (Record n _) <- m     = n-    !_ = mytrace ("VVV "++show status) $ ()-    msg = fromJust mmsg-#if PARALLELISM_EXPERIMENT-#if DO_TRACE-    dorecurs | PR <- p    = grnfpP_ m () True p pcs xs `par` ()-             | otherwise  = grnfpP_ m () True p pcs xs `seq` ()-#else-    dorecurs | PR <- p    = grnfpP m () True p pcs xs `par` ()-             | otherwise  = grnfpP m () True p pcs xs `seq` ()-#endif-#else-#if DO_TRACE-    dorecurs = grnfpP_ m () True p pcs xs `seq` ()-#else-    dorecurs = grnfpP m () True p pcs xs `seq` ()-#endif-#endif--  grnfpS (m :* ms) proxy_a pat x (SOP (S xss))-   = grnfpS ms proxy_a pat x (SOP xss)--  grnfpS _ _ _ _ _ = error "grnfpS: unexpected case!!"-----------------------------------------------------------------------------------  grnfpP :: forall cs xs.-            (-              All NFDataP xs-#if INCLUDE_SHOW_INSTANCES-            , All Show xs-#endif-            ) =>-                    ConstructorInfo cs-                 -> ()-                 -> Bool-                 -> PatNode-                 -> [Pattern]-                 -> NP I xs-                 -> ()-  grnfpP ci acc b pp [] Nil = acc-  grnfpP ci acc True pp [] (I x :* xs)-   = grnfpP ci acc True pp [] xs-  grnfpP ci acc b pp (p@(Node pn pgcs):pcs) (I x :* xs)-   = grnfpP ci (acc `seq` step) False pp pcs xs-   where-    step | WI <- pn        = ()-         | TR treps <- pn  = if elem tx treps then thestep else ()-         | TI treps <- pn  = if elem tx treps then () else thestep-         | otherwise       = thestep-     where-      thestep = rnfp p x-      tx | (Constructor n) <- ci  = n-         | (Infix n _ _) <- ci    = n-         | (Record n _) <- ci     = n-  grnfpP ci acc b pp ps xs-   = error $ "*6* "++show b++" "++show pp++" "++show ps++" "++show (lenxs xs)-----------------------------------------------------------------------------------  -- Preliminary check for arity mismatch or constructor name mismatch.-  -- Note: I don't presently know of a way to obtain the arity of a ctor-  -- from it's name as a String. Arity checking is done between the-  -- pattern and the value, but the arity of a ctor named in a pattern-  -- constraints is not available.-  grnfpP_validate :: forall xs.-            (-              All NFDataP xs-#if INCLUDE_SHOW_INSTANCES-            , All Show xs-#endif-            ) =>-                    Bool-                 -> PatNode-                 -> [Pattern]-                 -> String-                 -> NP I xs-                 -> (Bool, Maybe String)-  grnfpP_validate True  pp@(TR cnames) ps tx xss-   | b          = grnfpP_validate' True pp ps tx xss-   | otherwise  = (False,Just $ "<generic> TR ctor name constraint mismatch (not "++tx++")")-   where b = head cnames == tx-  grnfpP_validate True  pp@(TW cnames) ps tx xss-   | b          = grnfpP_validate' True pp ps tx xss-   | otherwise  = (False,Just $ "<generic> TW ctor name constraint mismatch (not "++tx++")")-   where b = head cnames == tx-  grnfpP_validate True  pp@(TI cnames) ps tx xss-   | b          = grnfpP_validate' True pp ps tx xss-   | otherwise  = (False,Just $ "<generic> TI ctor name constraint mismatch (not "++tx++")")-   where b = head cnames == tx-  grnfpP_validate b     pp             ps tx xss-   = grnfpP_validate' b pp ps tx xss--  grnfpP_validate' :: forall xs.-            (-              All NFDataP xs-#if INCLUDE_SHOW_INSTANCES-            , All Show xs-#endif-            ) =>-                    Bool-                 -> PatNode-                 -> [Pattern]-                 -> String-                 -> NP I xs-                 -> (Bool, Maybe String)-  grnfpP_validate' True   WS    []  tx xss = (True,Nothing)-  grnfpP_validate' True   WI    []  tx xss = (True,Nothing)-  grnfpP_validate' True  (WN n) []  tx xss = (True,Nothing)-  grnfpP_validate' True   WW    []  tx xss = (True,Nothing)-#if PARALLELISM_EXPERIMENT-  grnfpP_validate' True  (PN n) []  tx xss = (True,Nothing)-  grnfpP_validate' True   PW    []  tx xss = (True,Nothing)-#endif-  grnfpP_validate' True   pp    ps  tx xss-   | WS <- pp   = if lenps > 0 then (False,Nothing) else (True,Nothing)-   | b          = (True,Nothing)-   | otherwise  = (False,Just "<generic> arity mismatch #1")-   where-    b = lenps == lenxs xss-    lenps = length ps-  grnfpP_validate' False  pp    []  tx Nil = (True,Nothing)-  grnfpP_validate' False pp (p:pcs) tx (I x :* xs)-   = grnfpP_validate False pp pcs tx xs-  grnfpP_validate' b pp ps tx xs-   = error $ " &&& " ++ show b ++ " " ++ show pp ++ " " ++ show ps--- = error $ show b ++ " " ++ show pp ++ " " ++ show ps ++ " " ++ show (hcliftA (Proxy :: Proxy Show) (K . show . unI) xs)-----------------------------------------------------------------------------------  lenxs :: NP I xs' -> Int-  lenxs Nil = 0-  lenxs (I x' :* xs') = 1 + lenxs xs'-  lenxs _ = error "lenxs: unexpected"-----------------------------------------------------------------------------------#if 0--- Works so far as it goes, but is not currently used.--- Also, this is exactly Data.Generics.Schemes.glength-  arity :: Data a => a -> Int-  arity = length . gmapQ (const ())-#endif-----------------------------------------------------------------------------------  patMatchFail'' :: String -> ()-  patMatchFail'' msg-#if 0-     -- With this, the expected match failures are seen.-     = error "BOO!!!!"-#else-#if WARN_PATTERN_MATCH_FAILURE-     = trace ("GNFDataP: warning: pattern match failure (" ++ msg ++ ")") $ ()---   = unsafePerformIO $! putStrLn $! "GNFDataP: warning: pattern match failure (" ++ msg ++ ")"-#else-     = ()-#endif-#endif----------------------------------------------------------------------------------

@@ -3,254 +3,1680 @@    {-  LANGUAGE CPP #-} ----------------------------------------------------------------------------------#if NEW_IMPROVED_PATTERN_GRAMMAR--- |--- 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.6.0.0/docs/Control-DeepSeq-Bounded-NFDataPDyn.html NFDataPDyn> for another approach, which dynamically--- generates forcing patterns, and can depend on value info--- (in addition to type info).--- / (These dynamic aspects never received the attention I intended to give them, I got so caught up in seqaid, which offers similar features. Hopefully actual use of these tools in the near future will give me some perspective on whether/--- <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataPDyn.html NFDataPDyn> /should get attention.) /----#else--- |--- 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.------ __Motivation__------ A typical use is to ensure any exceptions hidden within lazy--- fields of a data structure do not leak outside the scope of the--- exception handler; another is to force evaluation of a data structure in--- one thread, before passing it to another thread (preventing work moving--- to the wrong threads). Unlike "DeepSeq", potentially infinite 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.--- Note that patterns may extend beyond the values they match against,--- without incurring any mismatch. This semantics is not the only--- possible, but bear in mind that order of evaluation is nondeterministic,--- barring further measures.------ See also "NFDataPDyn" for another approach, which dynamically--- generates forcing patterns, and can depend on value info--- (in addition to type info).----#endif-----------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.NFDataP-  (--#if NEW_IMPROVED_PATTERN_GRAMMAR--     -- * 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--#else--     -- * Pattern-bounded analogues of 'deepseq' and 'force'--       deepseqp, forcep    -- take String arg (pattern DSL)--     -- * Avoid DSL compilation overhead-     ---     -- However, we don't anticipate that this overhead would be-     -- significant in most applications, because using <deepseq-bounded>-     -- in a tight loop would only be done for diagnostic purposes.--     , deepseqp_, forcep_  -- take Pattern structure arg--#if 0-       -- Don't bother, really.-     , deepseqpM, forcepM  -- return lifted argument so can cope with bottom-     , deepseqpM_, forcepM_-#endif--     -- * Related modules re-exported--     , module Control.DeepSeq.Bounded.Pattern-     , module Control.DeepSeq.Bounded.PatUtil  -- actually exports former--     -- * Class of things that can be evaluated over an arbitrary finite pattern--     , NFDataP(..)--#endif----- #if NEW_IMPROVED_PATTERN_GRAMMAR----     module Control.DeepSeq.Bounded.NFDataP_new_grammar  ,---- #else----     module Control.DeepSeq.Bounded.NFDataP_old_grammar  ,---- #endif--  )-  where-----------------------------------------------------------------------------------#if NEW_IMPROVED_PATTERN_GRAMMAR-  import Control.DeepSeq.Bounded.NFDataP_new_grammar-#else-  import Control.DeepSeq.Bounded.NFDataP_old_grammar-#endif--  -- Necessity seems like a Haddock bug, as it is both imported-  -- and exported by PatUtil_{old,new}_*.hs.-  import Control.DeepSeq.Bounded.Pattern-  import Control.DeepSeq.Bounded.PatUtil+#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.6.0.0/docs/Control-DeepSeq-Bounded-NFDataPDyn.html NFDataPDyn> for another approach, which dynamically+-- generates forcing patterns, and can depend on value info+-- (in addition to type info).+-- / (These dynamic aspects never received the attention I intended to give them, I got so caught up in seqaid, which offers similar features. Hopefully actual use of these tools in the near future will give me some perspective on whether/+-- <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/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  ------------------------------------------------------------------------------- 

@@ -1,1580 +0,0 @@-----------------------------------------------------------------------------------  {-  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_new_grammar--- Copyright   :  Andrew G. Seniuk 2014-2015--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  portable----{--}--- (Restore comment from NFDataP.hs when shed old grammar support.)-----------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.NFDataP_new_grammar--- (Restore exports & comments from NFDataP.hs when shed old grammar support.)-  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----------------------------------------------------------------------------------

@@ -1,926 +0,0 @@-----------------------------------------------------------------------------------  {-  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----------------------------------------------------------------------------------

@@ -3,135 +3,1236 @@    {-  LANGUAGE CPP #-} ------------------------------------------------------------------------------------ |--- Module      :  Control.DeepSeq.Bounded.PatUtil--- Copyright   :  Andrew G. Seniuk 2014-2015--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  portable--------------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.PatUtil-  (--#if NEW_IMPROVED_PATTERN_GRAMMAR--     -- * Basic operations on Patterns--       unionPats-     , intersectPats-     , subPat---   , unionPatsStr--#if ! HASKELL98_FRAGMENT-     -- * Operations for obtaining and modifying Patterns based on a term--     , mkPat-     , mkPatN-     , growPat-#endif--     -- * Operations for obtaining subpatterns (in the 'subPat' sense)--     , truncatePat-     , shrinkPat-#if PROVIDE_OLD_SHRINK_PAT-     , shrinkPat_old-#endif--     -- * Operations for the direct construction and perturbation of Patterns--     , emptyPat-     , liftPats--     , splicePats-     , elidePats--     , erodePat--     -- * Re-exported for convenience--     , module Control.DeepSeq.Bounded.Pattern--     -- * Debugging convenience--#if ! HASKELL98_FRAGMENT-     , Shape-     , shapeOf-     , ghom-#endif-     , probDensRose-     , weightedRose-     , unzipRose-     , showRose--#else--     -- * Basic operations on Patterns--       unionPats-     , intersectPats-     , subPat---   , unionPatsStr--#if ! HASKELL98_FRAGMENT-     -- * Operations for obtaining and modifying Patterns based on a term--     , mkPat-     , mkPatN-     , growPat-#endif--     -- * Operations for obtaining subpatterns (in the 'subPat' sense)--     , truncatePat-     , shrinkPat-#if PROVIDE_OLD_SHRINK_PAT-     , shrinkPat_old-#endif--     -- * Operations for the direct construction and perturbation of Patterns--     , emptyPat-     , liftPats--     , splicePats-     , elidePats--     , erodePat--     -- * Re-exported for convenience--     , module Control.DeepSeq.Bounded.Pattern--#endif----- #if NEW_IMPROVED_PATTERN_GRAMMAR----      module Control.DeepSeq.Bounded.PatUtil_new_grammar  ,---- #else----      module Control.DeepSeq.Bounded.PatUtil_old_grammar  ,---- #endif--  )-  where-----------------------------------------------------------------------------------#if NEW_IMPROVED_PATTERN_GRAMMAR-  import Control.DeepSeq.Bounded.PatUtil_new_grammar-#else-  import Control.DeepSeq.Bounded.PatUtil_old_grammar-#endif--  -- Necessity seems like a Haddock bug, as it is both imported-  -- and exported by PatUtil_{old,new}_*.hs.-  import Control.DeepSeq.Bounded.Pattern+-- XXX This is not correct! Use elidePats if you want something+-- arity-changing.  The only time it would be valid for shrinkPat+-- to produce a (Node WR []) is from some attribute-enriched+-- (Node WR []) or (Node TR []).+#define SHRINK_TO_EMPTY_WR 0++-- As for intersection, if the arities differ, the node+-- effectively becomes non-recursive.  (Whether this is+-- theoretically the best choice is still uncertain.)+-- What is certain is, unless support richer Pattern's,+-- a union of two recursive Pattern nodes with differing+-- arities is not well-definable.+--   The reason this switch exists at all is, it can+-- be expensive to compute this predicate, especially+-- considering that recursive nodes are very common,+-- with WR being ("in the average case") the single most+-- abundant node type in a pattern, probably followed+-- in order by WI, WS, WW, WN (or parallel counterparts).+#define ENFORCE_SAME_ARITY_UNION 1++#define DO_TRACE 0++-- Now specified via --flag=[-]USE_WWW_DEEPSEQ+--- #define USE_WW_DEEPSEQ 1++-------------------------------------------------------------------------------++  -- XXX For debugging only!+  {-# LANGUAGE BangPatterns #-}++  {-# LANGUAGE Rank2Types #-}+  {-  LANGUAGE ScopedTypeVariables #-}++-------------------------------------------------------------------------------++-- |+-- Module      :  Control.DeepSeq.Bounded.PatUtil+-- Copyright   :  Andrew G. Seniuk 2014-2015+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--++-------------------------------------------------------------------------------++  module Control.DeepSeq.Bounded.PatUtil+  (++     -- * Basic operations on Patterns++       unionPats+     , intersectPats+     , subPat+--   , unionPatsStr++#if ! HASKELL98_FRAGMENT+     -- * Operations for obtaining and modifying Patterns based on a term++     , mkPat+     , mkPatN+     , growPat+#endif++     -- * Operations for obtaining subpatterns (in the 'subPat' sense)++     , truncatePat+     , shrinkPat++     -- * Operations for the direct construction and perturbation of Patterns++     , emptyPat+     , liftPats++     , splicePats+     , elidePats++     , erodePat++     -- * Re-exported for convenience++     , module Control.DeepSeq.Bounded.Pattern++     -- * Debugging convenience++#if ! HASKELL98_FRAGMENT+     , Shape+     , shapeOf+     , ghom+#endif+     , probDensRose+     , weightedRose+     , unzipRose+     , showRose++  )+  where++-------------------------------------------------------------------------------++  import Control.DeepSeq.Bounded.Pattern++  import Data.Maybe ( isNothing, fromJust )+  import Data.Maybe ( isJust )++#if ! HASKELL98_FRAGMENT+  import Data.Data ( Data )+  import Data.Generics ( GenericQ )+  import Data.Generics ( gmapQ )+#endif++  import Data.List ( findIndex )+--import Data.List ( elemIndex )+  import Data.List ( sortBy )+--import Data.List ( nub )+  import Data.List ( foldl' )+  import Data.List ( group )+  import Data.List ( sort )+  import Data.List ( intersect )++  import System.Random++  import Control.Concurrent ( ThreadId )++--import Control.Applicative ( (<$) )++  import Debug.Trace ( trace )+  import Control.DeepSeq ( force )++  -- For global Bool state, to indicate that a warning has already been issued.+  import Data.IORef+  import System.IO.Unsafe ( unsafePerformIO )++-------------------------------------------------------------------------------++#if DO_TRACE+  mytrace = trace+#else+  mytrace _ = id+#endif++-------------------------------------------------------------------------------++  firstWarningPassed :: IORef Bool+  firstWarningPassed = unsafePerformIO $ newIORef False++-------------------------------------------------------------------------------++  -- | Compute the union of a list of 'Pattern's.+  --+  -- Note that unionPats is undefined when homologous nodes+  -- specify incompatible arities (only possible when+  -- 'WR' or 'TR' are involved).+  --+  -- /__XXX__ Support for the various attributes is work in progress. It may be impossible to arrive at a consistent treatment for all attributes under unions. At the last moment, 0.6.0.0 will __not__ be supporting type constraints under union, intersection or testing subpattern predicate. This is work in progress, but the five un-modified @W*@ node types should be safe./+  unionPats :: [ Pattern ] -> Pattern+  unionPats [] = emptyPat+  -- Using force here, to try to prevent the regular output being+  -- interleaved with the trace message. it works, except for the+  -- opening " (if you're in ghci, anyways).+  unionPats ps = foldr1 (union' False) $ force $ map (clearTypeConstraints "unionPats") ps+--unionPats ps = foldr1 (union' False) ps+--unionPats ps = foldr1 union' $ trace (">> " ++ show ps) $ ps++  union' :: Bool -> Pattern -> Pattern -> Pattern++  -- We hit this coming in every time [modulo compiler/runtime+  -- optimisations], so performance counts.+  union' b (Node pas1 cs1) (Node pas2 cs2)+   | WI{} <- pas1               = Node pas2' cs2+   |               WI{} <- pas2 = Node pas1' cs1+   where+    pas1' = setPatNodeAttrs pas1 union_as+    pas2' = setPatNodeAttrs pas2 union_as+    union_as = unionAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)++  -- Symmetric cases:+  union' _ nod1@(Node pas1 cs1) nod2@(Node pas2 cs2)+   -- XXX Those cases using zipWith are not correct,+   -- unless length cs1 == length cs2.  But one hates to+   -- have to compute that. Caveat Emptor! This will behave+   -- as a true union operator only if the child pattern lists+   -- are compatibly-sized!+   --   In seqaid (and in "correct" manual usage?), this problem+   -- will never arise.+#if 0+   -- XXX Don't do it! -- (==) on PatNode might be more expensive+   -- than I think, some attributes have list parameters...+   | p1 == p2           = Node p1 $ zipWith (union' b) cs1 cs2+#endif+#if ENFORCE_SAME_ARITY_UNION+   | WR{} <- pas1, WR{} <- pas2 = {-trace "WRWR" $-}+      if csokay then Node (WR union_as) $ zipWith (union' False) cs1 cs2+      else error "unionPat: WRWR: encountered arity disparity!"+#else+   | WR{} <- pas1, WR{} <- pas2 = {-trace "WRWR" $-} Node (WR union_as) $ zipWith (union' False) cs1 cs2+#endif+   | WS{} <- pas1, WS{} <- pas2 = {-trace "WSWS" $-} Node (WS union_as) []+   | WN{} <- pas1, WN{} <- pas2 = {-trace "WNWN" $-} Node (WN union_as) []+#if USE_WW_DEEPSEQ+   | WW{} <- pas1, WW{} <- pas2 = {-trace "WWWW" $-} Node (WW union_as) []+#endif+#if 0+#if ENFORCE_SAME_ARITY_UNION+   | TR{} <- pas1, TR{} <- pas2 = {-trace "TRTR" $-}+      if csokay then Node (TR union_as) $ zipWith (union' False) cs1 cs2+      else error "unionPat: TRTR: encountered arity disparity!"+#else+   | TR{} <- pas1, TR{} <- pas2+      = {-trace "TRTR" $-} Node (TR union_as) $ zipWith (union' False) cs1 cs2+#endif+   | TI{} <- pas1, TI{} <- pas2+      = {-trace "TITI" $-} Node (TI union_as) []+---   = {-trace "TITI" $-} Node (TI union_as) $ zipWith (union' False) cs1 cs2+----  = {-trace "TITI" $-} Node (TI union_as (intersectTys tys1 tys2)) $ zipWith (union' False) cs1 cs2+--- | TR{} cls1 tys1 cns1 <- p1, TR{} cls2 tys2 cns2 <- p2+----  = {-trace "TRWR" $-} Node (TR union_as (cls1++cls2) (tys1++tys2) (cns1++cns2)) $ zipWith union' cs1 cs2+#endif+   | otherwise  = union'asym_1 False (Node pas1 cs1) (Node pas2 cs2)+   where+    pas1' = setPatNodeAttrs pas1 union_as+    pas2' = setPatNodeAttrs pas2 union_as+    union_as = unionAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)+#if ENFORCE_SAME_ARITY_UNION+    csokay = equilength cs1 cs2+#endif++  -- Now the asymmetric cases:+  -- XXX This probably has numerous bugs and oversights!+   -- XXX Those cases using zipWith are not correct,+   -- unless length cs1 == length cs2.  But one hates to+   -- have to compute that. Caveat Emptor! This will behave+   -- as a true union operator only if the child pattern lists+   -- are compatibly-sized!+   --   Actually, if zipWith (which is acting on two [Pattern];+   -- you could supply union-unit pattern for missing children+   -- in shorter list, but then which children exactly were missing?+   -- So rather than play such a game without a racket, we just+   -- require the lists to be the same length or all bets are off.+   --   In seqaid, this problem will never arise.+   -- And in "correct" manual usage?...++#if USE_WW_DEEPSEQ+  union'asym_1 b nod1@(Node pas1 cs1) nod2@(Node pas2 cs2)+   | WW{} <- pas1+      =+--      trace (if b then "**WW" else "WW**") $+        Node (WW union_as) []+   | not b      = union'asym_1 True nod2 nod1+   | otherwise  = union'asym_2 False nod1 nod2+   where+    union_as = unionAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)+#endif++  union'asym_2 b nod1@(Node pas1 cs1) nod2@(Node pas2 cs2)+   | WN{} <- pas1+      =+--      trace (if b then "**WN" else "WN**") $+        union'asym_2_aux dep+   | not b      = union'asym_2 True nod2 nod1+   | otherwise  = union'asym_3 False nod1 nod2+   where+    union'asym_2_aux 0 = Node (WI union_as) []+    union'asym_2_aux 1 = Node (WS union_as) []+    union'asym_2_aux _ = Node (WN union_as) []+    union_as = unionAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)+    dep = depth as1++-- XXX XXX+-- I think it is not possible to reconcile, say, WR with TW.+-- TW says rnf if in type; WR says recurse regardless of type+-- according to the subpatterns.  Ah! But the union is, a priori,+-- only well-defined if the WR shape is "elected" from the wild+-- shape of TW, so in fact the correct answer is TR!  Very interesting!!!+-----+-- But what of WR with TN?...  If WR pattern depth (levels of tree)+-- is less than the n of TN, then answer is again TR.  But if n is+-- deeper than the WR pattern shape?... Perhaps only in SOME places...+--   You can still perhaps reconcile it, but now some fairly serious+-- pattern surgery is required! "We have the technology"....+-------+  -- We have now to deal only with asymmetric combos+  -- of WR, TR, WS, and TI nodes.  Six cases (plus six+  -- automatically when re-call with flip).+  --   Oops, there are still also TW and TN nodes...+-------------+  --        WR   WS   TI   TR   TN   TW+  --+  --   WR   Sym  WRWS WRTI WRTR WRTN WRTW+  --+  --   WS   flip Sym  WSTI WSTR WSTN WSTW+  --+  --   TI   flip flip Sym  TITR TITN TITW+  --+  --   TR   flip flip flip Sym  TRTN TRTW+  --+  --   TN   flip flip flip flip Sym  TNTW+  --+  --   TW   flip flip flip flip flip Sym +-----------------+  -- Fifteen cases to consider in all. Can they all be logically reconciled?...+------------------------+  -- WRWS : WR wins (not quite trivial however)+  -- ... if we just let T* be broken for 0.6.0.0, we're done there!+  -- By "broken" meaning, better give an error -- could just erase+  -- the type constraints silently, but what use is that?+  union'asym_3 b nod1@(Node pas1 cs1) nod2@(Node pas2 cs2)+   | WR{} <- pas1, WS{} <- pas2 = {-trace "WRWS" $-} nod1'+#if 0+#if ENFORCE_SAME_ARITY_UNION+   | TR{} <- pas1, WR{} <- pas2 = {-trace "TRWR" $-}+      if csokay then nod1'+      else error $ "unionPat: " ++ if b then "WRTR" else "TRWR" ++ ": encountered arity disparity!"+#else+   | TR{} <- pas1, WR{} <- pas2 = {-trace "TRWR" $-} nod1'+#endif+   | TR{} <- pas1, WS{} <- pas2 = {-trace "TRWS" $-} nod1'+   | TI{} <- pas1, WR{} <- pas2 = {-trace "TIWR" $-} nod2'+   | TI{} <- pas1, WS{} <- pas2 = {-trace "TIWS" $-} nod2'+#if USE_WW_DEEPSEQ+   | TW{} <- pas1, WR{} <- pas2 = {-trace "TWWR" $-} nod1'+   | TW{} <- pas1, WS{} <- pas2 = {-trace "TWWS" $-} nod1'+   | TW{} <- pas1, WW{} <- pas2 = {-trace "TWWW" $-} nod2'+#endif+   | TI{} <- pas1, TR{} <- pas2+      = {-trace "TITR" $-} Node (TR union_as) $ zipWith (union'asym_3 False) cs1 cs2+#endif+   | not b = union'asym_3 True nod2 nod1+   | otherwise = error "unionPats: unexpected failure to (Haskell) pattern-match arguments!"+   where+--  cs1' = map (const emptyPat) cs1+    nod1' = Node pas1' cs1+    pas1' = setPatNodeAttrs pas1 union_as+    union_as = unionAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)+#if ENFORCE_SAME_ARITY_UNION+    csokay = equilength cs1 cs2+#endif++-------------------------------------------------------------------------------++  -- | Compute the intersection of a list of 'Pattern's.+  --+  -- Where two (or more) homologous 'WR' nodes disagree in arity,+  -- the intersection at that position becomes 'WI'.+  --+  -- /__XXX__ This doesn't yet handle type-constrained 'PatNode's ('TI', 'TR', 'TN' or 'TW'). Other attributes are handled in a haphazard fashion. This is work in progress, but the five un-modified @W*@ node types should be safe./++  intersectPats :: [ Pattern ] -> Pattern+  intersectPats [] = emptyPat+  intersectPats ps = foldr1 (intersect' False) $ force $ map (clearTypeConstraints "intersectPats") ps++  intersect' :: Bool -> Pattern -> Pattern -> Pattern++  -- We hit this coming in every time [modulo compiler/runtime+  -- optimisations], so performance counts.+  intersect' b (Node pas1 cs1) (Node pas2 cs2)+   | WI{} <- pas1               = Node (WI intersect_as) []+   |               WI{} <- pas2 = Node (WI intersect_as) []+   where+    intersect_as = intersectAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)++  -- Symmetric cases:+  intersect' _ nod1@(Node pas1 cs1) nod2@(Node pas2 cs2)+#if ENFORCE_SAME_ARITY_UNION+   | WR{} <- pas1, WR{} <- pas2 = {-trace "WRWR" $-}+      if csokay then Node (WR intersect_as) $ zipWith (intersect' False) cs1 cs2+      else error "intersectPat: WRWR: encountered arity disparity!"+#else+   | WR{} <- pas1, WR{} <- pas2 = {-trace "WRWR" $-} Node (WR intersect_as) $ zipWith (intersect' False) cs1 cs2+#endif+   | WS{} <- pas1, WS{} <- pas2 = {-trace "WSWS" $-} Node (WS intersect_as) []+   | WN{} <- pas1, WN{} <- pas2 = {-trace "WNWN" $-} Node (WN intersect_as) []+#if USE_WW_DEEPSEQ+   | WW{} <- pas1, WW{} <- pas2 = {-trace "WWWW" $-} Node (WW intersect_as) []+#endif+   -- XXX T* nodes not handled!+   | otherwise  = intersect'asym_1 False (Node pas1 cs1) (Node pas2 cs2)+   where+    pas1' = setPatNodeAttrs pas1 intersect_as+    pas2' = setPatNodeAttrs pas2 intersect_as+    intersect_as = intersectAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)+#if ENFORCE_SAME_ARITY_UNION+    csokay = equilength cs1 cs2+#endif++  -- Now the asymmetric cases:+#if USE_WW_DEEPSEQ+  intersect'asym_1 b nod1@(Node pas1 cs1) nod2@(Node pas2 cs2)+   | WW{} <- pas1+      =+--      trace (if b then "**WW" else "WW**") $+        Node pas2' cs2+   | not b      = intersect'asym_1 True nod2 nod1+   | otherwise  = intersect'asym_2 False nod1 nod2+   where+    pas2' = setPatNodeAttrs pas2 intersect_as+    intersect_as = intersectAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)+#endif++  intersect'asym_2 b nod1@(Node pas1 cs1) nod2@(Node pas2 cs2)+   | WN{} <- pas1+      =+--      trace (if b then "**WN" else "WN**") $+        truncatePat dep (Node (setPatNodeAttrs pas2 intersect_as) cs2)+--      intersect'asym_2_aux dep+   | not b      = intersect'asym_2 True nod2 nod1+   | otherwise  = intersect'asym_3 False nod1 nod2+   where+#if 0+    intersect'asym_2_aux 0 = Node (WI intersect_as) []+    intersect'asym_2_aux 1 = Node (WS intersect_as) []+    intersect'asym_2_aux _ = Node (WN intersect_as) []+#endif+    intersect_as = intersectAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)+    dep = depth as1++  intersect'asym_3 b nod1@(Node pas1 cs1) nod2@(Node pas2 cs2)+   | WR{} <- pas1, WS{} <- pas2 = {-trace "WRWS" $-} nod1'+   -- XXX T* nodes not handled!+   | not b = intersect'asym_3 True nod2 nod1+   | otherwise = error "intersectPats: unexpected failure to (Haskell) pattern-match arguments!"+   where+    cs1' = map (const emptyPat) cs1+    nod1' = Node (WR intersect_as) cs1'+    intersect_as = intersectAttrs [as1,as2]+    (as1, as2) = (getPatNodeAttrs pas1, getPatNodeAttrs pas2)+#if ENFORCE_SAME_ARITY_UNION+    csokay = equilength cs1 cs2+#endif++-------------------------------------------------------------------------------++  -- | Return 'True' if the first pattern matches the second (and 'False' otherwise).+  --+  -- Arities must correspond (or the second pattern's node must be wild) for the match to succeed at each __recursive__ 'PatNode' (/i.e./ 'WR' or 'TR').+  -- Matching does not imply spanning; @'flip' 'subPat'@ would work for that.+  --+  -- /__XXX__ This doesn't yet handle type-constrained 'PatNode's ('TI', 'TR', 'TN' or 'TW'), because 'intersectPats' doesn't. Generally speaking, it is difficult to arrive at a good policy for subpattern, union and intersection, when mixed types of nodes with various attribute values are considered!  Other attributes are handled in a haphazard fashion. This is work in progress, but the five un-modified @W*@ node types should be safe./+  --+  -- More formally, we have two \"Subpattern Axioms\":+  --+  -- * __Not More Specifc__ &#8195; A subpattern (of a pattern) is never more specific (/i.e./ less permissive), in terms of what values it will match.+  --+  -- * __Not More Forcing__ &#8195; A subpattern never has greater forcing potential.+  --+  -- And a /proper/ subpattern will always be strictly more permissive or+  -- less forcing (or both).+  subPat :: Pattern -> Pattern -> Bool+  subPat p pp = p == intersectPats [p, pp]  -- probably faster on avg.+--subPat p pp = pp == unionPats [p, pp]++-------------------------------------------------------------------------------++  -- I guess I don't really clear the typeConstraints list,+  -- only toggle doConstrainType to False.+  clearTypeConstraints :: String -> Pattern -> Pattern+  clearTypeConstraints s (Node pas cs)+   = Node pas' $ map (clearTypeConstraints s) cs+   where+    as = getPatNodeAttrs pas+    as' = if doConstrainType as+--        then error "unionPats: type constraints unsupported!"+--        then trace "unionPats: warning: type constraints unsupported (cleared!)" as+          then unsafePerformIO $ do+                 firstwarnpassed <- readIORef firstWarningPassed+                 modifyIORef' firstWarningPassed (const True)+                 if firstwarnpassed+                   then return as+                   else trace (s ++ ": warning: type constraints unsupported (cleared!)")+                        $! return as+          else as+    as'' = as' { doConstrainType = False }+    pas' = setPatNodeAttrs pas as''++-------------------------------------------------------------------------------++  -- XXX Note: Concerning the doSpark field, there is a deeper issue+  -- lurking here. Parallelisation and strictification are orthogonal+  -- concerns, so trying to treat them uniformly can be awkward...++  unionAttrs :: [PatNodeAttrs] -> PatNodeAttrs+  unionAttrs [] = error "unionAttrs: called with empty list.\nPlease determine which library has called this function erroneously,\nand file a bug report or contact the maintainer of that project."+  unionAttrs as = foldl1 unionAttrs' as+  unionAttrs' :: PatNodeAttrs -> PatNodeAttrs -> PatNodeAttrs+  unionAttrs'+    (PatNodeAttrs+      uniq1+      dep1+      dotys1+      tys1+      dly1 dlyus1+#if USE_PAR_PATNODE+      spk1+#endif+#if USE_PSEQ_PATNODE+      pseq1 pseqperm1+#endif+#if USE_TRACE_PATNODE+      tr1+#endif+#if USE_PING_PATNODE+      ping1 pingtid1+#endif+#if USE_DIE_PATNODE+      die1+#endif+#if USE_TIMING_PATNODE+      timing1 ts1 parent_ts1 delta_ts1+#endif+    )+    (PatNodeAttrs+      uniq2+      dep2+      dotys2+      tys2+      dly2 dlyus2+#if USE_PAR_PATNODE+      spk2+#endif+#if USE_PSEQ_PATNODE+      pseq2 pseqperm2+#endif+#if USE_TRACE_PATNODE+      tr2+#endif+#if USE_PING_PATNODE+      ping2 pingtid2+#endif+#if USE_DIE_PATNODE+      die2+#endif+#if USE_TIMING_PATNODE+      timing2 ts2 parent_ts2 delta_ts2+#endif+    )+     = PatNodeAttrs+         (combineUniqueIDs uniq1 uniq2)+         (max dep1 dep2)+         (dotys1||dotys2)  -- SAME as intersection [?]+         (unionTys tys1 tys2)+         (dly1||dly2)  -- SAME as intersection [?]+         (combineDelays True dly1 dly2 dlyus1 dlyus2)  -- DIFFERENT for union and intersection [?]+#if USE_PAR_PATNODE+         (spk1||spk2)  -- seems the best choice for parallelism union semantics+#endif+#if USE_PSEQ_PATNODE+         (pseq1&&pseq2)  -- DIFFERENT for union and intersection [??]+         (combinePseqPerms pseqperm1 pseqperm2)  -- XXX SAME as intersection...+#endif+#if USE_TRACE_PATNODE+         (combineTraces tr1 tr2)  -- same for union and intersection+#endif+#if USE_PING_PATNODE+         (combinePings ping1 ping2)  -- same for union and intersection+         (combinePingParentTIDs pingtid1 pingtid2)  -- same for union and intersection+#endif+#if USE_DIE_PATNODE+         (die1||die2)  -- same for union and intersection+#endif+#if USE_TIMING_PATNODE+         -- same for union and intersection [?]+         -- XXX This is bogus, so it would be nice if it would issue a warning.+         -- We'd want to issue the warning only once per run, I think...+         (False) (0) (0) (0)+#endif++  intersectAttrs :: [PatNodeAttrs] -> PatNodeAttrs+  intersectAttrs [] = error "intersectAttrs: called with empty list.\nPlease determine which library has called this function erroneously,\nand file a bug report or contact the maintainer of that project."+  intersectAttrs as = foldr1 intersectAttrs' as+  intersectAttrs' :: PatNodeAttrs -> PatNodeAttrs -> PatNodeAttrs+  intersectAttrs'+    (PatNodeAttrs+      uniq1+      dep1+      dotys1+      tys1+      dly1 dlyus1+#if USE_PAR_PATNODE+      spk1+#endif+#if USE_PSEQ_PATNODE+      pseq1 pseqperm1+#endif+#if USE_TRACE_PATNODE+      tr1+#endif+#if USE_PING_PATNODE+      ping1 pingtid1+#endif+#if USE_DIE_PATNODE+      die1+#endif+#if USE_TIMING_PATNODE+      timing1 ts1 parent_ts1 delta_ts1+#endif+    )+    (PatNodeAttrs+      uniq2+      dep2+      dotys2+      tys2+      dly2 dlyus2+#if USE_PAR_PATNODE+      spk2+#endif+#if USE_PSEQ_PATNODE+      pseq2 pseqperm2+#endif+#if USE_TRACE_PATNODE+      tr2+#endif+#if USE_PING_PATNODE+      ping2 pingtid2+#endif+#if USE_DIE_PATNODE+      die2+#endif+#if USE_TIMING_PATNODE+      timing2 ts2 parent_ts2 delta_ts2+#endif+    )+     = PatNodeAttrs+         (combineUniqueIDs uniq1 uniq2)+         (min dep1 dep2)+         (dotys1||dotys2)  -- SAME as union [?]+         (intersectTys tys1 tys2)+         (dly1||dly2)  -- SAME as union [?]+         (combineDelays False dly1 dly2 dlyus1 dlyus2)  -- DIFFERENT for union and intersection [?]+#if USE_PAR_PATNODE+         (spk1||spk2)  -- seems the better choice+--       (spk1&&spk2)  -- dubious parallelism intersection semantics+#endif+#if USE_PSEQ_PATNODE+         (pseq1||pseq2)  -- DIFFERENT for union and intersection [??]+         (combinePseqPerms pseqperm1 pseqperm2)  -- XXX SAME as union...+#endif+#if USE_TRACE_PATNODE+         (combineTraces tr1 tr2)  -- same for union and intersection+#endif+#if USE_PING_PATNODE+         (combinePings ping1 ping2)  -- same for union and intersection+         (combinePingParentTIDs pingtid1 pingtid2)  -- same for union and intersection+#endif+#if USE_DIE_PATNODE+         (die1||die2)  -- same for union and intersection+#endif+#if USE_TIMING_PATNODE+         -- same for union and intersection [?]+         -- XXX This is bogus, so it would be nice if it would issue a warning.+         -- We'd want to issue the warning only once per run, I think...+         (False) (0) (0) (0)+#endif++-------------------------------------------------------------------------------++  -- The idea here is that, PatNodeAttrs only carries a Bool for each+  -- of combineTraces and combinePings, and the actual content of the+  -- log string or Exception message is a matter to be determined in+  -- the context that the logging/exception is triggered (demanded).++#if USE_TRACE_PATNODE+  combineTraces :: Bool -> Bool -> Bool+  combineTraces = (||)  -- for now, at least+#endif++#if USE_PSEQ_PATNODE+  combinePseqPerms :: Maybe [Int] -> Maybe [Int] -> Maybe [Int]+  combinePseqPerms mpsp1 mpsp2+   | isNothing mpsp1  = mpsp2+   | isNothing mpsp2  = mpsp1+   | mpsp1 == mpsp2   = mpsp1+   | otherwise        = trace "WARNING: combinePseqPerms: Incompatible permutations discarded (using id)." Nothing+#endif++#if USE_PING_PATNODE+  combinePingParentTIDs :: Maybe ThreadId -> Maybe ThreadId -> Maybe ThreadId+  combinePingParentTIDs mt1 mt2+   = if isNothing mt1 && isNothing mt2+     then Nothing+     else if isJust mt1 && isJust mt2 && t1 == t2+          then Just t1+#if 1+          else+#if 1+               trace+                 (    "combinePings: TID's differ: "+                   ++ show mt1 ++ " " ++ show mt2+                   ++ "\nCombining by choosing " ++ show mt1 ++ "!" )+#endif+                 mt1+#else+          -- XXX This shouldn't be "error"!+          else error $    "combinePings: TID's differ: "+                       ++ show mt1 ++ " " ++ show mt2+#endif+--        else Nothing+   where (t1,t2) = (fromJust mt1,fromJust mt2)++  combinePings :: Bool -> Bool -> Bool+  combinePings = (||)  -- for now, at least+#endif++  combineUniqueIDs :: Int -> Int -> Int+  combineUniqueIDs u1 u2+   | u1 == u2   = u1+   | otherwise  =+#if 0+-- Seeing as this will happen 99% of the time, it's a bit much+-- to issue a warning to console!+                  trace+                    ( "combineUniqueIDs: uniqueID's differ: "+                       ++ show u1 ++ " " ++ show u2 )+#endif+                    0++  -- Rather dubious.+  combineDelays :: Bool -> Bool -> Bool -> Int -> Int -> Int+  combineDelays from_union dly1 dly2 dlyus1 dlyus2+   | not dly1 && not dly2  = 0+   | not dly1              = dlyus2+   | not dly2              = dlyus1+   | from_union            = min dlyus1 dlyus2+   | otherwise             = max dlyus1 dlyus2++-------------------------------------------------------------------------------++  -- Probably overkill for typical lengths.+  -- Would pay to special case for some short lists.+  -- Optimisations come later.++  unionTys :: [String] -> [String] -> [String]+  unionTys ss1 ss2 = nubsort $ ss1 ++ ss2++  nubsort :: Ord a => [a] -> [a]+  nubsort = map head . group . sort++  intersectTys :: [String] -> [String] -> [String]+  intersectTys ss1 ss2 = intersect (nubsort ss1) (nubsort ss2)++-------------------------------------------------------------------------------++#if ENFORCE_SAME_ARITY_UNION+  -- Try to determine whether then lengths of the lists are+  -- the same or not without being too inefficient...+  {-# INLINE equilength #-}+  equilength :: [a] -> [b] -> Bool+#if 0+-- XXX But ... I feel like best practise is to use "length cs1 == length cs2",+-- since who knows, the compiler could optimise it into some sort of quasi-+-- list internal structure with O(1) length function.  That is not too+-- far fetched at all.  (Complexities as reported in the standard libraries+-- need not be strictly observed -- actual evaluations may exhibit lower+-- complexity without violating any specification...)  And if this happens,+-- then we've blocked the optimisation, so we get a 0.5*O(n) average case+-- algorithm instead of an O(n), but missed out on O(1)...+--   The only really safe way is to implement using your choice of+-- container with O(1) length.  Or of course, you could attempt to+-- maintain the length as associated data (extra field)...+  equilength (x:xs) (y:ys) = equilength xs ys+  equilength [] [] = True+  equilength _ _ = False+#else+  equilength cs1 cs2 = length cs1 == length cs2  -- ouch(?)+#endif+#endif++  zipWith_ :: String -> (a -> b -> c) -> [a] -> [b] -> (Bool,[c])+  zipWith_ caller f xs ys+   | b          = (b,zs)+   | otherwise  = trace (caller ++ ": node arity disparity!") (b,zs)+   where+    (b,zs') = zipWith_' f xs ys []+    zs = reverse zs'+  zipWith_' :: (a -> b -> c) -> [a] -> [b] -> [c] -> (Bool,[c])+  zipWith_' f (x:xs) (y:ys) acc = zipWith_' f xs ys (f x y : acc)+  zipWith_' _ [] [] acc = (True,acc)+  zipWith_' _ _ _ acc = (False,acc)++-------------------------------------------------------------------------------++  -- | Given an integer depth and a pattern, truncate the pattern to+  -- extend to at most this requested depth.+  --+  -- Nodes in the truncated pattern which were 'WR' and are now leaves,+  -- are changed to 'WI'.+  -- (This is a change from 0.5, where they were+  -- changed to 'WS', which violates the Subpattern Axiom concerning+  -- forcing potential.+  -- It may be further changed to 'WR'-bearing-'WI'-children+  -- in 0.7, which preserves arity info, as is consistent with the new+  -- treatment of 'mkPatN' in 0.6.)+  --+  -- /__XXX__ Note that @*N@ and @*W@ nodes are retained, so if you are using those then \"extend to at most this depth\" does not mean the forcing potential of the pattern is at most that depth...  It would be quite possible to improve this, so @*N@ (and @*W@ nodes, obviously) are \"weakened\" (depth is reduced) so that they end at the truncation depth, regardless of how far up they reside.  In particular, any @*N@ or @*W@ node at truncation depth could be replaced by @WS@.  This works well as all these node types are arity-agnostic./+  truncatePat :: Int -> Pattern -> Pattern+  truncatePat n node@(Node pas chs)+   | n <= 0     = Node (WS $ getPatNodeAttrs pas) []+   | otherwise  = Node pas $ map (truncatePat (-1+n)) chs++-------------------------------------------------------------------------------++  -- | There is no @Nil@ in the @Pattern@ type, but a single 'WI' node as+  -- empty pattern is a dependable way to ensure that the empty pattern+  -- never forces anything. This sets 'PatNodeAttrs' to 'emptyPatNodeAttrs'.+  emptyPat :: Pattern+  emptyPat = Node (WI emptyPatNodeAttrs) []  -- this should do it!++-------------------------------------------------------------------------------++#if ! HASKELL98_FRAGMENT+  -- | Obtain a lazy, potentially infinite pattern, matching the shape+  -- of an arbitrary term (value expression).+  --+  -- There is only one kind of 'PatNode' employed here, 'WR'.+  -- (__Note__:+  -- /This is an API breaking change from 0.5, where 'WS' also occurred./)+  --+  -- The 'Pattern' is extended indefinitely on demand.  In case the+  -- term has leaves, these will be 'WR' nodes with empty child lists+  -- in the corresponding pattern.+  --+  -- __Caveat__: Note that @mkPat@ gives counter-intuitive results when used+  -- on rose trees, in particular on 'Pattern' itself.+  -- For example, a rose tree with a single node will have a 3-node /\\ shape.)+  -- Formally, 'mkPat' is not idempotent on 'Pattern's, but rather grows+  -- without bound when iterated. This shouldn't be an issue in practise.+  mkPat :: forall d. Data d => d -> Pattern+  mkPat = f . shapeOf+   where+    f (Node _ cs) = Node pn $ map f cs+     where+      pn = WR emptyPatNodeAttrs+---   pn = let as = emptyPatNodeAttrs in if null cs then WS as else WR as++  -- | Obtain a lazy, finite pattern, matching the shape of+  -- an arbitrary term, but only down to at most depth @n@.+  --+  -- Satisfies @'forcep' . 'mkPatN' n = 'forcen' n@. /(Later: I kinda doubt that is true in full generality?... Although it does convey the idea.)/+  --+  -- Unlike 'mkPat', three pattern node contexts arise here:+  --+  -- * those corresponding to actual leaf (nullary) nodes of the term+  --+  --     * these are &#8195; @Node WR []@+  --+  -- * interior nodes of the pattern corresponding to interior nodes of the term+  --+  --     * these are &#8195; @Node WR chs@ &#8195; where @chs@ are the child subpatterns of this interior pattern node+  --+  -- * leaf nodes of the pattern corresponding to interior nodes of the term, that is, non-leaf nodes of the term which are at a depth @n@ of nested constructor applications.+  --+  --     * these are &#8195; @Node WR chs'@ &#8195; where &#8195; @chs' = map (const $ Node WI []) chs@+  --     * this essentially says we're allowed to know the arity of the node, but aside from this cardinal number we know nothing whatsoever concerning the child subpatterns and are not even permitted to evaluate their heads+  --+  -- All interior nodes are 'WR', and all leaf nodes are 'WI'; 'WS' never arise (which is a change from version 0.5).+  --+  -- See caveat in the 'mkPat' documentation.+  mkPatN :: forall d. Data d => Int -> d -> Pattern+  mkPatN n = f n . shapeOf+   where+    f n (Node _ cs)+     | 0 == n     = if null cs+                    then Node pn []+                    else Node pn $ map (const emptyPat) cs+     | otherwise  = Node pn $ map (f (-1+n)) cs+     where+      pn = WR emptyPatNodeAttrs+#endif++-------------------------------------------------------------------------------++  -- | Elide all leaves which have no non-leaf sibling.+  -- We want the pattern to still match the same value, only less of it.+  -- Merely eliding all leaves would, in most cases, cause match failure,+  -- so we have to be a bit more subtle.  There are some arbitrary+  -- decisions about the relaxation route through the lattice.+  -- (Refer to the source for details.)+  --+  -- More formally, we have some \"Shrinkage Axioms\".  The first+  -- two are really just the \"Subpattern Axioms\" again, that is,+  -- shrinkage is always to a subpattern in our sense of the+  -- word (see also 'subPat'):+  --+  -- * __Not More Specifc__ &#8195; Shrinkage is never towards a more specific (/i.e./ less permissive) pattern.+  --+  -- * __Not More Forcing__ &#8195; Shrinkage is never towards a pattern with greater forcing potential.+  --+  -- And additionally, for finite patterns only:+  --+  -- * __Non-Constancy__ &#8195; A finite pattern is constant under shrinkage /iff/ the pattern is trivial (emptyPat, \".\", Node WI []). However, infinite patterns have other limits.  For instance, the infinite pattern @'concat' $ 'repeat' "(."@ (yes you can do that!) is already stationary under shrinkage.+  --+  -- * __Convergence__ &#8195; On iteration, shrinkage of finite patterns reaches the trivial pattern in a number of steps proportional to the size of the initial pattern argument.  (Actually, @*N@ and @*W@ nodes can make this larger.)  However, in the case of infinite patterns, all bets are off: Simple examples exist which converge immediately, or which continue shrinking indefinitely.)+{--}+  -- XXX This has a bug -- it introduces WR []'s when the original+  -- node arity was not zero! The progression should be (in the+  -- newest syntax) something like:+  --   (.(!.))+  --   (.(..))+  --   (.!)+  --   (..)+  --   !+  --   .+  shrinkPat :: Pattern -> Pattern+  shrinkPat (Node pas cs)+#if USE_PAR_PATNODE+   -- take de-parallelisation as shrinkage+   -- XXX So should we take pseq-isation as further shrinkage?+   | doSpark as  = let as' = as { doSpark = False } in+                   case pas of+                    WI{} -> Node (WI as') []+                    WS{} -> Node (WI as') []+                    WR{} -> Node (WR as') cs+                    WN{} -> Node (WN as') []+#if USE_WW_DEEPSEQ+                    WW{} -> Node (WW as') []+#endif+#endif+   | WI{} <- pas  = Node (WI as) []  -- can't shrink (evt'ly elided from parent)+   | WS{} <- pas  = Node (WI as) []  -- may as well+   | WN{} <- pas+      = let n = depth as+            n' = -1+n+        in if n' <= 0 then Node (WI as) []+           else if n' == 1 then Node (WS as) []+           else let as' = as { depth = n' } in Node (WN as') []+#if USE_WW_DEEPSEQ+   | WW{} <- pas  = Node (WN as { depth = 5 }) []  -- XXX arbitrary hardcode+#endif+   -- take un-type-constrained as shrinkage (pattern becomes less specific)+   -- XXX Later: This is wrong. It is less specific, but it HAS MORE FORCING+   -- POTENTIAL (except in TI case).+   | TI{} <- pas  = Node (WI as) []+   | TR{} <- pas  = Node (WR as) cs+   | TN{} <- pas  = Node (WN as) []+#if USE_WW_DEEPSEQ+   | TW{} <- pas  = Node (WW as) []+#endif+#if SHRINK_TO_EMPTY_WR+   | WR{} <- pas , null cs  = Node (WI as) []+#endif+   -- If this node has any grandchildren, recurse on the children.+   | not $ null $ filter (\ (Node q gcs) -> not $ null gcs) cs+      = Node pas $ map shrinkPat cs+   -- At this point we know this node has no grandchildren.+   -- Check if all children are insulator nodes.+   | null $ filter (\ (Node pas _) -> case pas of { WI{} -> False ; _ -> True }) cs+      = case pas of+         -- Must go to WI, since .{##} -> . is /not/ a lazification.+         -- Later: Yes it is, isn't it?? Dot is a less constrained pattern...+#if SHRINK_TO_EMPTY_WR+         WR{} -> Node (WR as) []+#else+         WR{} -> Node (WI as) []+#endif+         -- We cannot make this simple TR -> WR (drop type constraints),+         -- since, while less specific, it forces more, violating the+         -- "second axiom of shrinkage".+         TR{} -> let as' = as { typeConstraints = [] } in Node (WI as') []  -- better?+--       TR{} -> Node (WI as) []  -- sic+         _ -> error "shrinkPat: unexpected!"+   | otherwise+      = Node pas $ map shrinkPat cs  -- still contains shrinkable children+   where+    as = getPatNodeAttrs pas++-------------------------------------------------------------------------------++#if ! HASKELL98_FRAGMENT+  -- | Grow all leaves by one level within the shape of the provided value.+  -- This is intended to be used with \"plain\" patterns, /i.e./ those+  -- containing only 'WR' and 'WI' nodes. (There is no code enforcing this.)+  -- A new growth node always replaces a 'WI' (leaf) node with a 'WR' node+  -- bearing the suitable number of 'WI' children to encode arity (see+  -- 'mkPat' for general commentary about this).+  growPat :: forall d. Data d => Pattern -> d -> Pattern+  growPat pat x = growPat' pat $ shapeOf x+  growPat' :: Pattern -> Shape -> Pattern+  growPat' (Node pas cs) (Node q ds)+   | null cs    = let subleaf = Node (WI $ getPatNodeAttrs pas) []+                      pas' = WR $ getPatNodeAttrs pas+                  in Node pas' $ map (const subleaf) ds+   | otherwise  = Node pas $ zipWith growPat' cs ds+#endif++-------------------------------------------------------------------------------++  -- | This creates a new 'WR' node, the common root, with 'PatNodeAttrs' set+  -- to 'emptyPatNodeAttrs'.  The argument patterns become the children of+  -- the root (order is preserved).+  liftPats :: [ Pattern ] -> Pattern+  liftPats ps = Node (WR emptyPatNodeAttrs) ps++-------------------------------------------------------------------------------++  -- | Add children to a node (interior or leaf) of the target.+  -- The first argument is target pattern, the second is a path (0-based+  -- indexing) from the root of the target to any choice node,+  -- and the third is a list of subpatterns for insertion, along with the+  -- indices of the insertion slots.+  -- Indices range through @-1,0..n@, where @n@ is the number of+  -- existing children, and @-1@ is short for @n@ (so you don't need+  -- to count off the children to append!).+  -- Indices are always relative to the original target as it was received.+  splicePats :: Pattern -> [Int] -> [ (Int, Pattern) ] -> Pattern+  splicePats target path isibs'+--- | isibs /= isibs'    = error "splicePats: siblings to be inserted must be indexed in increasing order"+--- | not uniqueIdxs     = error "splicePats: siblings to be inserted must be uniquely indexed"+--- | not $ isPath path  = error "splicePats: path malformed"+   | otherwise          = splice' target path isibs+   where+--  uniqueIdxs = length isibs == ( length $ nub $ map fst isibs )+    isibs = sortBy comp isibs'  -- questionable solution+     where+      comp (x1,_) (x2,_) = compare x1 x2+    -- Now, what's the clever way to do this? it's ugly manual+    -- recursion if don't think of something nicer. (This is+    -- the ugly manual recursion!)+    splice' :: Pattern -> [Int] -> [(Int,Pattern)] -> Pattern+    splice' (Node pas cs) [] isibs  -- end of path chain+     | maximum (map fst isibs) > ncs  = error "splicePats: insertion indices (0-based) must be\nno greater than the number of children"+     | or $ map ( (<(-1)) . fst ) isibs  = error "splicePats: insertion indices must be non-negative, or -1"+---  | or $ map ( (<0) . fst ) isibs  = error "splicePats: insertion indices must be non-negative"+     | not ( isWR pas || isTR pas )  = error $ "splicePats: path ends in non-recursive node type " ++ show pas+     | otherwise  = {-trace "**1**" $-} Node pas $ f 0 cs isibs_+     where+      ncs = length cs+      -- XXX I'm trying to remember why had isibs of -1 as special.+      -- (They're now filtered upstream of here in any case.)+      isibs_ = let lst = takeWhile ((== -1) . fst) isibs in+               drop (length lst) isibs ++ map (\ (x,y) -> (ncs,y)) lst+      f n cs [] = cs+      f n [] isibs_remaining = map snd isibs_remaining+--    f n [] isibs_remaining = error $ "splicePats: (2) path escapes target: " ++ show isibs_remaining  -- shouldn't happen+      f n lst1@(c:cs) lst2@((i,s):iss)+---    | trace ("**3**"++show lst1++" "++show lst2) False  = undefined+       | ii == n    = map snd ss ++ (c : f (1+n) cs ss')+       | otherwise  =                c : f (1+n) cs lst2+       where (ss,ss') = span (\ (i,s) -> i == n) lst2+             ii = i+--           ii = if i < 0 then ncs-(-i) else i+    splice' (Node pas cs) (i:is) isibs+---  | trace ("**4** "++show i++" / "++show cs++" / "++show pathcs) False  = undefined+     | null cs  = error "splicePats: path escapes target (depth)"+     | length cs < 1+i  = error "splicePats: path escapes target (breadth)"+     | null ccsR  = error "splicePats: (2) path escapes target (depth)"+-- Shouldn't be possible?+---  | not ( isWR pas || isTR pas )  = error $ "splicePats: path contains non-recursive node type " ++ show pas+     | otherwise  = {-trace "**2**" $-} Node pas (csL ++ [splice' c is isibs] ++ csR)+     where+      (c:csR) = ccsR+      (csL,ccsR) = splitAt i cs++-------------------------------------------------------------------------------++  -- | Elide children of a node (interior or leaf) of the target.+  -- The first argument is target pattern, the second is a path (0-based+  -- indexing) from the root of the target to any choice node,+  -- and the third is a list of child indices for elision.+  -- Indices range through @-1,0..n-1@, where @n@ is the number of+  -- existing children, and @-1@ is short for @n-1@ (so you don't need+  -- to count off the children to elide the rightmost).+  -- Indices are always relative to the original target as it was received.+  elidePats :: Pattern -> [Int] -> [Int] -> Pattern+  elidePats target path isibs' = elide' target path isibs+   where+    isibs = sortBy comp isibs'  -- questionable solution+     where comp x1 x2 = compare x1 x2+    -- (See comment in splicePats.)+    elide' :: Pattern -> [Int] -> [Int] -> Pattern+    elide' (Node pas cs) [] isibs  -- end of path chain+     | maximum isibs >= ncs  = error "elidePats: elision indices (0-based) must be\nless than the number of children"+     | or $ map (<(-1)) isibs  = error "elidePats: elision indices must be non-negative or -1"+---  | or $ map (<0) isibs  = error "elidePats: elision indices must be non-negative"+     | otherwise  = {-trace "**1**" $-} Node pas $ f 0 cs isibs_+     where+      ncs = length cs+      -- XXX I'm trying to remember why had isibs of -1 as special.+      -- (They're now filtered upstream of here in any case.)+      isibs_ = let lst = takeWhile (== -1) isibs in+               drop (length lst) isibs ++ map (\ x -> (-1+ncs)) lst+      f n cs [] = cs+      f n [] isibs_remaining = error $ "elidePats: (3) path escapes target: " ++ show isibs_remaining  -- shouldn't happen+      f n lst1@(c:cs) lst2@(i:iss)+---    | trace ("**3**"++show lst1++" "++show lst2) False  = undefined+       | ii == n    =     f (1+n) cs ss'+       | otherwise  = c : f (1+n) cs lst2+       where (ss,ss') = span (\ i -> i == n) lst2+             ii = i+--           ii = if i < 0 then ncs-(-i) else i+    elide' (Node pas cs) (i:is) isibs+---  | trace ("**4** "++show i++" / "++show cs++" / "++show pathcs) False  = undefined+     | null cs  = error "elidePats: path escapes target (depth)"+     | length cs < 1+i  = error "elidePats: path escapes target (breadth)"+     | null ccsR  = error "elidePats: (2) path escapes target (depth)"+     | otherwise  = {-trace "**2**" $-} Node pas (csL ++ [elide' c is isibs] ++ csR)+     where+      (c:csR) = ccsR+      (csL,ccsR) = splitAt i cs++-------------------------------------------------------------------------------++  -- | Select a leaf at random, and elide it.+  -- In order to achieve fairness, the node probabilities are+  -- weighted by nodes in branch.+  -- The path arg can "focus" the stochastic erosion to only+  -- consider leaves beneath a given node.+{--}+-- XXX Later: I don't understand. When would you want to+-- allow the number of children at a node to change (except+-- possibly to zero)?... Question applies also to splicePats+-- and to elidePats.+-- XXX It would be better if the weighting could be done once,+-- then maintained, but will have to see how it performs...+-- XXX Hey! This doesn't even need to call elidePats.+-- XXX Later: It would be nice if this could call shrinkPat+-- (or equivalent) on the leaves finally selected, so they+-- decrease forcing at finer granularity, eg. *3 -> *2 (not *3 -> #+-- or rather outright elided ... this is a different process though;+-- need to decide whether you want to let that arity change or not...)+  erodePat :: StdGen -> [Int] -> Pattern -> (Pattern, StdGen)+  -- Just descend the path, reconstructing recursively (usual thing),+  -- and when get to the node addressed by path, then choose (fair) your+  -- leaf under that.+  erodePat g (h:t) (Node pas chs)+   = ( Node pas $ left ++ [ ch'' ] ++ right , g' )+   where+    ch'' = ch'+--  ch'' = (\ (Node (r,pas) chs) -> Node r chs) ch'+    (ch',g') = erodePat g t lucky+    (left,lucky:right) = splitAt h chs+  erodePat g [] pat = (pat', g')+--erodePat g [] pat = trace (showRose wpat ++ "\n" ++ showRose (weightedRose pat)) $ (pat', g')+   where+    pat' = fst $ unzipRose wpat'+    !_ = probDensRose pat+--  !_ = force $ probDensRose pat+    (wpat', g') = f g wpat+--  !wpat@(Node pas chs) = probDensRose pat+    wpat@(Node pas chs) = probDensRose pat+    f :: StdGen -> Rose (PatNode,Double) -> (Rose (PatNode,Double), StdGen)+    f g (Node pas chs)+     | isNothing mh  = ( Node pas chs, g )  -- ??+     | null chs   = ( Node pas [], g )+---  | null chs   = ( Node pas [], g'' )+     | null gchs  = ( Node pas $ left ++ [ Node (WI emptyPatNodeAttrs,1.0) [] ] ++ right , g'' )+---  | null gchs  = ( Node pas $ left ++ right , g'' )+     | otherwise  = ( Node pas $ left ++ [ ch' ] ++ right , g'' )+     where+-- XXX I see; I have a logic error.+-- Cyclical definition.+-- null gchs+-- but gchs depends on lucky+-- and lucky depends on ... [?]+      (Node _ gchs) = lucky+      (ch',g'') = f g' lucky+      chprobs = map (\ (Node (_,pas) _) -> pas) chs+      mh = lucky_child 0 0.0 chprobs+#if 1+      h = fromJust mh+#else+      h | isNothing mh  = error "UNEXPECTED!"  -- definitely get here+        | otherwise     = fromJust mh+#endif+      (left,lucky:right) = splitAt h chs+--    !_ = trace ("r=" ++ show r) $ ()+--    (r,g') = trace "HERE!" $ randomR (0,1) g+      (r,g') = randomR (0,1) g+      lucky_child :: Int -> Double -> [Double] -> Maybe Int+      lucky_child idx acc [] = Nothing+      lucky_child idx acc (cp:cps)+---    | trace (" >>> " ++ show acc ++ "  " ++ show acc') $ False = undefined+       | acc' >= r   = Just idx+       | otherwise  = lucky_child (1+idx) acc' cps+       where+        acc' = acc + cp++-------------------------------------------------------------------------------++  -- See the sai-shape-syb package for an API full of this sort of thing.++#if ! HASKELL98_FRAGMENT+  type Shape = Rose ()+  shapeOf :: forall d. Data d => d -> Shape+  shapeOf = ghom $ const ()+  ghom :: forall r d. Data d => GenericQ r -> d -> Rose r+  ghom f x = foldl k b (gmapQ (ghom f) x)+   where+     b = Node (f x) []+     k (Node r chs) nod = Node r (chs++[nod])+#endif++  probDensRose :: Rose r -> Rose (r, Double)+  probDensRose = probDensRose' 1.0 . weightedRose+  probDensRose' :: Double -> Rose (r, Int) -> Rose (r, Double)+--probDensRose' p (Node (r,w) []) = Node (r,p) []  -- (helps avoid div-by-zero)+  probDensRose' p (Node (r,w) chs)+   = Node (r,p) $ zipWith probDensRose' chprobs chs+   where+    chwts   = map (\ (Node (_,w) _) -> w) chs+    chwtsum = foldl' (+) 0 chwts+    normfac = 1 / fromIntegral chwtsum+--- !_ = trace (" *** " ++ show chprobs)+    chprobs = map (\ (Node (_,w) _) -> normfac * (fromIntegral w)) chs++  weightedRose :: Rose r -> Rose (r, Int)+  weightedRose (Node r chs) = foldl k' b (map weightedRose chs)+   where+     k = (\ (r,w) (r',w') -> (r,w+w'))+     b = Node (r,1) []+     k' (Node rw chs) nod@(Node rw' _) = Node (rw `k` rw') (chs++[nod])++  unzipRose :: Rose (r, s) -> (Rose r, Rose s)+  unzipRose (Node (x,y) ns) = (Node x xns, Node y yns)+   where+    (xns,yns) = unzip $ map unzipRose ns++  showRose :: Show r => Rose r -> String+  showRose = show' 0+   where show' n (Node r chs)+           = indent n ++ show r ++ "\n" ++ concatMap (show' (1+n)) chs+              where indent n = concat $ replicate n "| "  -------------------------------------------------------------------------------