packages feed

deepseq-bounded 0.5.5 → 0.6.0.0

raw patch · 64 files changed

+23378/−10612 lines, 64 filesdep +attoparsecdep +bytestringdep +cpphsdep ~deepseqdep ~sybdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, bytestring, cpphs, mtl, text

Dependency ranges changed: deepseq, syb, template-haskell

API changes (from Hackage documentation)

- Control.DeepSeq.Bounded.Generics: gforce_ :: Generic a => SeqNodeKind -> a -> a
- Control.DeepSeq.Bounded.Generics: grnf_ :: Generic a => SeqNodeKind -> a -> ()
- Control.DeepSeq.Bounded.Generics: grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()
- Control.DeepSeq.Bounded.Generics: grnfp :: (Generic a, HasDatatypeInfo a, All2 NFDataP (Code a), NFDataP a) => Pattern -> a -> ()
- Control.DeepSeq.Bounded.Generics: gseq_ :: Generic a => SeqNodeKind -> a -> b -> b
- Control.DeepSeq.Bounded.Generics.GNFDataN: grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()
- Control.DeepSeq.Bounded.Generics.GNFDataP: grnfp :: (Generic a, HasDatatypeInfo a, All2 NFDataP (Code a), NFDataP a) => Pattern -> a -> ()
- Control.DeepSeq.Bounded.Generics.GSeqable: gforce_ :: Generic a => SeqNodeKind -> a -> a
- Control.DeepSeq.Bounded.Generics.GSeqable: grnf_ :: Generic a => SeqNodeKind -> a -> ()
- Control.DeepSeq.Bounded.Generics.GSeqable: gseq_ :: Generic a => SeqNodeKind -> a -> b -> b
- Control.DeepSeq.Bounded.NFDataP: instance (Integral a, NFDataP a) => NFDataP (Ratio a)
- Control.DeepSeq.Bounded.NFDataP: instance (Ix a, NFDataP a, NFDataP b) => NFDataP (Array a b)
- Control.DeepSeq.Bounded.NFDataP: instance (NFDataP a, NFDataP b) => NFDataP (Either a b)
- Control.DeepSeq.Bounded.NFDataP: instance (RealFloat a, NFDataP a) => NFDataP (Complex a)
- Control.DeepSeq.Bounded.NFDataP: instance (Typeable a, NFDataP a, Typeable b, NFDataP b) => NFDataP (a, b)
- Control.DeepSeq.Bounded.NFDataP: instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c) => NFDataP (a, b, c)
- Control.DeepSeq.Bounded.NFDataP: instance (Typeable a, NFDataP a, Typeable b, NFDataP b, Typeable c, NFDataP c, Typeable d, NFDataP d) => NFDataP (a, b, c, d)
- Control.DeepSeq.Bounded.NFDataP: instance (Typeable a, Typeable b) => NFDataP (a -> b)
- Control.DeepSeq.Bounded.NFDataP: instance (Typeable a1, NFDataP a1, Typeable a2, NFDataP a2, Typeable a3, NFDataP a3, Typeable a4, NFDataP a4, Typeable a5, NFDataP a5) => NFDataP (a1, a2, a3, a4, a5)
- Control.DeepSeq.Bounded.NFDataP: 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) => NFDataP (a1, a2, a3, a4, a5, a6)
- Control.DeepSeq.Bounded.NFDataP: 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) => NFDataP (a1, a2, a3, a4, a5, a6, a7)
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP ()
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Bool
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Char
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Double
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Float
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Int
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Int16
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Int32
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Int64
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Int8
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Integer
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Version
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Word
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Word16
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Word32
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Word64
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP Word8
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP a => NFDataP (Maybe a)
- Control.DeepSeq.Bounded.NFDataP: instance NFDataP a => NFDataP [a]
- Control.DeepSeq.Bounded.NFDataP: instance Typeable a => NFDataP (Fixed a)
- Control.DeepSeq.Bounded.PatAlg: elidePats :: Pattern -> [Int] -> [Int] -> Pattern
- Control.DeepSeq.Bounded.PatAlg: emptyPat :: Pattern
- Control.DeepSeq.Bounded.PatAlg: erodePat :: StdGen -> [Int] -> Pattern -> (Pattern, StdGen)
- Control.DeepSeq.Bounded.PatAlg: growPat :: Data d => Pattern -> d -> Pattern
- Control.DeepSeq.Bounded.PatAlg: intersectPats :: [Pattern] -> Pattern
- Control.DeepSeq.Bounded.PatAlg: isSubPatOf :: Pattern -> Pattern -> Bool
- Control.DeepSeq.Bounded.PatAlg: liftPats :: [Pattern] -> Pattern
- Control.DeepSeq.Bounded.PatAlg: mkPat :: Data d => d -> Pattern
- Control.DeepSeq.Bounded.PatAlg: mkPatN :: Data d => Int -> d -> Pattern
- Control.DeepSeq.Bounded.PatAlg: shrinkPat :: Pattern -> Pattern
- Control.DeepSeq.Bounded.PatAlg: shrinkPat_old :: Pattern -> Pattern
- Control.DeepSeq.Bounded.PatAlg: splicePats :: Pattern -> [Int] -> [(Int, Pattern)] -> Pattern
- Control.DeepSeq.Bounded.PatAlg: truncatePat :: Int -> Pattern -> Pattern
- Control.DeepSeq.Bounded.PatAlg: unionPats :: [Pattern] -> Pattern
- Control.DeepSeq.Bounded.Pattern: PN :: Int -> PatNode
- Control.DeepSeq.Bounded.Pattern: PR :: PatNode
- Control.DeepSeq.Bounded.Pattern: PW :: PatNode
- Control.DeepSeq.Bounded.Pattern: compilePat :: String -> Pattern
- Control.DeepSeq.Bounded.Pattern: data SeqNodeKind
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_0PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_0Rose
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_10PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_11PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_1PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_2PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_3PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_4PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_5PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_6PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_7PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_8PatNode
- Control.DeepSeq.Bounded.Pattern: instance Constructor C1_9PatNode
- Control.DeepSeq.Bounded.Pattern: instance Datatype D1PatNode
- Control.DeepSeq.Bounded.Pattern: instance Datatype D1Rose
- Control.DeepSeq.Bounded.Pattern: instance Eq PatNode
- Control.DeepSeq.Bounded.Pattern: instance Eq SeqNodeKind
- Control.DeepSeq.Bounded.Pattern: instance Eq a => Eq (Rose a)
- Control.DeepSeq.Bounded.Pattern: instance Functor Rose
- Control.DeepSeq.Bounded.Pattern: instance Generic (Rose a)
- Control.DeepSeq.Bounded.Pattern: instance Generic PatNode
- Control.DeepSeq.Bounded.Pattern: instance NFData PatNode
- Control.DeepSeq.Bounded.Pattern: instance NFData a => NFData (Rose a)
- Control.DeepSeq.Bounded.Pattern: instance Ord SeqNodeKind
- Control.DeepSeq.Bounded.Pattern: instance Show PatNode
- Control.DeepSeq.Bounded.Pattern: instance Show a => Show (Rose a)
- Control.DeepSeq.Bounded.Pattern: instance Typeable PatNode
- Control.DeepSeq.Bounded.Pattern: instance Typeable Rose
- Control.DeepSeq.Bounded.Pattern: showPat :: Pattern -> String
- Control.DeepSeq.Bounded.Seqable: data SeqNodeKind
+ Control.DeepSeq.Bounded: class FF k where data family F k :: * -> *
+ Control.DeepSeq.Bounded: deepseq_bounded_flag__new_improved_pattern_grammar :: Bool
+ Control.DeepSeq.Bounded: instance FF Int
+ Control.DeepSeq.Bounded: instance FF Pattern
+ Control.DeepSeq.Bounded: instance FF SeqNode
+ Control.DeepSeq.Bounded: phi :: (FF k, Generic v, NFDataN v, NFDataP v) => k -> F k v -> v
+ Control.DeepSeq.Bounded.Compile: compilePat :: String -> Pattern
+ Control.DeepSeq.Bounded.Compile: showPat :: Pattern -> String
+ Control.DeepSeq.Bounded.Generic: gforce_ :: Generic a => SeqNode -> a -> a
+ Control.DeepSeq.Bounded.Generic: grnf_ :: Generic a => SeqNode -> a -> ()
+ Control.DeepSeq.Bounded.Generic: grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()
+ Control.DeepSeq.Bounded.Generic: grnfp :: (Generic a, HasDatatypeInfo a, All2 NFDataP (Code a), NFDataP a) => Pattern -> a -> ()
+ Control.DeepSeq.Bounded.Generic: gseq_ :: Generic a => SeqNode -> a -> b -> b
+ Control.DeepSeq.Bounded.Generic.GNFDataN: grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()
+ Control.DeepSeq.Bounded.Generic.GNFDataP: grnfp :: (Generic a, HasDatatypeInfo a, All2 NFDataP (Code a), NFDataP a) => Pattern -> a -> ()
+ Control.DeepSeq.Bounded.Generic.GSeqable: gforce_ :: Generic a => SeqNode -> a -> a
+ Control.DeepSeq.Bounded.Generic.GSeqable: grnf_ :: Generic a => SeqNode -> a -> ()
+ Control.DeepSeq.Bounded.Generic.GSeqable: gseq_ :: Generic a => SeqNode -> a -> b -> b
+ Control.DeepSeq.Bounded.Generic.GSeqable: seqharn :: Generic a => a -> a
+ Control.DeepSeq.Bounded.NFDataP: DeepSeqBounded_PingException :: String -> DeepSeqBounded_PingException
+ Control.DeepSeq.Bounded.NFDataP: data DeepSeqBounded_PingException
+ Control.DeepSeq.Bounded.NFDataP: handleAttrs :: Typeable d => Pattern -> d -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: elidePats :: Pattern -> [Int] -> [Int] -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: emptyPat :: Pattern
+ Control.DeepSeq.Bounded.PatUtil: erodePat :: StdGen -> [Int] -> Pattern -> (Pattern, StdGen)
+ Control.DeepSeq.Bounded.PatUtil: ghom :: Data d => GenericQ r -> d -> Rose r
+ Control.DeepSeq.Bounded.PatUtil: growPat :: Data d => Pattern -> d -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: intersectPats :: [Pattern] -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: liftPats :: [Pattern] -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: mkPat :: Data d => d -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: mkPatN :: Data d => Int -> d -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: probDensRose :: Rose r -> Rose (r, Double)
+ Control.DeepSeq.Bounded.PatUtil: shapeOf :: Data d => d -> Shape
+ Control.DeepSeq.Bounded.PatUtil: showRose :: Show r => Rose r -> String
+ Control.DeepSeq.Bounded.PatUtil: shrinkPat :: Pattern -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: splicePats :: Pattern -> [Int] -> [(Int, Pattern)] -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: subPat :: Pattern -> Pattern -> Bool
+ Control.DeepSeq.Bounded.PatUtil: truncatePat :: Int -> Pattern -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: type Shape = Rose ()
+ Control.DeepSeq.Bounded.PatUtil: unionPats :: [Pattern] -> Pattern
+ Control.DeepSeq.Bounded.PatUtil: unzipRose :: Rose (r, s) -> (Rose r, Rose s)
+ Control.DeepSeq.Bounded.PatUtil: weightedRose :: Rose r -> Rose (r, Int)
+ Control.DeepSeq.Bounded.Pattern: PatNodeAttrs :: !Int -> !Int -> !Bool -> ![String] -> !Bool -> !Int -> !Bool -> !Bool -> Maybe [Int] -> !Bool -> !Bool -> Maybe ThreadId -> !Bool -> !Bool -> !Int -> !Int -> !Int -> PatNodeAttrs
+ Control.DeepSeq.Bounded.Pattern: XX :: PatNode
+ Control.DeepSeq.Bounded.Pattern: data PatNodeAttrs
+ Control.DeepSeq.Bounded.Pattern: data SeqNode
+ Control.DeepSeq.Bounded.Pattern: delayus :: PatNodeAttrs -> !Int
+ Control.DeepSeq.Bounded.Pattern: delta_timestamp :: PatNodeAttrs -> !Int
+ Control.DeepSeq.Bounded.Pattern: depth :: PatNodeAttrs -> !Int
+ Control.DeepSeq.Bounded.Pattern: doConstrainType :: PatNodeAttrs -> !Bool
+ Control.DeepSeq.Bounded.Pattern: doDelay :: PatNodeAttrs -> !Bool
+ Control.DeepSeq.Bounded.Pattern: doDie :: PatNodeAttrs -> !Bool
+ Control.DeepSeq.Bounded.Pattern: doPing :: PatNodeAttrs -> !Bool
+ Control.DeepSeq.Bounded.Pattern: doPseq :: PatNodeAttrs -> !Bool
+ Control.DeepSeq.Bounded.Pattern: doSpark :: PatNodeAttrs -> !Bool
+ Control.DeepSeq.Bounded.Pattern: doTiming :: PatNodeAttrs -> !Bool
+ Control.DeepSeq.Bounded.Pattern: doTrace :: PatNodeAttrs -> !Bool
+ Control.DeepSeq.Bounded.Pattern: emptyPatNodeAttrs :: PatNodeAttrs
+ Control.DeepSeq.Bounded.Pattern: getPatNodeAttrs :: PatNode -> PatNodeAttrs
+ Control.DeepSeq.Bounded.Pattern: isTI :: PatNode -> Bool
+ Control.DeepSeq.Bounded.Pattern: isTN :: PatNode -> Bool
+ Control.DeepSeq.Bounded.Pattern: isTR :: PatNode -> Bool
+ Control.DeepSeq.Bounded.Pattern: isTW :: PatNode -> Bool
+ Control.DeepSeq.Bounded.Pattern: isWI :: PatNode -> Bool
+ Control.DeepSeq.Bounded.Pattern: isWN :: PatNode -> Bool
+ Control.DeepSeq.Bounded.Pattern: isWR :: PatNode -> Bool
+ Control.DeepSeq.Bounded.Pattern: isWS :: PatNode -> Bool
+ Control.DeepSeq.Bounded.Pattern: isWW :: PatNode -> Bool
+ Control.DeepSeq.Bounded.Pattern: parent_timestamp :: PatNodeAttrs -> !Int
+ Control.DeepSeq.Bounded.Pattern: pingParentTID :: PatNodeAttrs -> Maybe ThreadId
+ Control.DeepSeq.Bounded.Pattern: pseqPerm :: PatNodeAttrs -> Maybe [Int]
+ Control.DeepSeq.Bounded.Pattern: setPatNodeAttrs :: PatNode -> PatNodeAttrs -> PatNode
+ Control.DeepSeq.Bounded.Pattern: setPatNodePingParentTID :: ThreadId -> PatNode -> PatNode
+ Control.DeepSeq.Bounded.Pattern: setPatternPatNodeUniqueIDs :: Int -> Pattern -> Pattern
+ Control.DeepSeq.Bounded.Pattern: showPatNodeRaw :: PatNode -> String
+ Control.DeepSeq.Bounded.Pattern: showPatRaw :: Pattern -> String
+ Control.DeepSeq.Bounded.Pattern: showPerm :: Maybe [Int] -> String
+ Control.DeepSeq.Bounded.Pattern: timestamp :: PatNodeAttrs -> !Int
+ Control.DeepSeq.Bounded.Pattern: typeConstraints :: PatNodeAttrs -> ![String]
+ Control.DeepSeq.Bounded.Pattern: uniqueID :: PatNodeAttrs -> !Int
+ Control.DeepSeq.Bounded.Seqable: data SeqNode
- Control.DeepSeq.Bounded.NFDataP: class (Typeable a, NFDataN a, NFData a) => NFDataP a where 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 rnfp _ d = d `seq` ()
+ Control.DeepSeq.Bounded.NFDataP: class (Typeable a, NFDataN a, NFData a) => NFDataP a where rnfp p x | handleAttrs p x == Node XX [] = undefined rnfp (Node (WI {}) _) _ = () 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 rnfp (Node (TW as) chs) d = if elem td treps then d `seq` () else () where td = show $ typeRepTyCon $ typeOf d treps = typeConstraints as rnfp _ d = d `seq` ()
- Control.DeepSeq.Bounded.Pattern: Insulate :: SeqNodeKind
+ Control.DeepSeq.Bounded.Pattern: Insulate :: SeqNode
- Control.DeepSeq.Bounded.Pattern: Propagate :: SeqNodeKind
+ Control.DeepSeq.Bounded.Pattern: Propagate :: SeqNode
- Control.DeepSeq.Bounded.Pattern: Spark :: SeqNodeKind
+ Control.DeepSeq.Bounded.Pattern: Spark :: SeqNode
- Control.DeepSeq.Bounded.Pattern: TI :: [String] -> PatNode
+ Control.DeepSeq.Bounded.Pattern: TI :: !PatNodeAttrs -> PatNode
- Control.DeepSeq.Bounded.Pattern: TN :: Int -> [String] -> PatNode
+ Control.DeepSeq.Bounded.Pattern: TN :: !PatNodeAttrs -> PatNode
- Control.DeepSeq.Bounded.Pattern: TR :: [String] -> PatNode
+ Control.DeepSeq.Bounded.Pattern: TR :: !PatNodeAttrs -> PatNode
- Control.DeepSeq.Bounded.Pattern: TW :: [String] -> PatNode
+ Control.DeepSeq.Bounded.Pattern: TW :: !PatNodeAttrs -> PatNode
- Control.DeepSeq.Bounded.Pattern: WI :: PatNode
+ Control.DeepSeq.Bounded.Pattern: WI :: !PatNodeAttrs -> PatNode
- Control.DeepSeq.Bounded.Pattern: WN :: Int -> PatNode
+ Control.DeepSeq.Bounded.Pattern: WN :: !PatNodeAttrs -> PatNode
- Control.DeepSeq.Bounded.Pattern: WR :: PatNode
+ Control.DeepSeq.Bounded.Pattern: WR :: !PatNodeAttrs -> PatNode
- Control.DeepSeq.Bounded.Pattern: WS :: PatNode
+ Control.DeepSeq.Bounded.Pattern: WS :: !PatNodeAttrs -> PatNode
- Control.DeepSeq.Bounded.Pattern: WW :: PatNode
+ Control.DeepSeq.Bounded.Pattern: WW :: !PatNodeAttrs -> PatNode
- Control.DeepSeq.Bounded.Seqable: Insulate :: SeqNodeKind
+ Control.DeepSeq.Bounded.Seqable: Insulate :: SeqNode
- Control.DeepSeq.Bounded.Seqable: Propagate :: SeqNodeKind
+ Control.DeepSeq.Bounded.Seqable: Propagate :: SeqNode
- Control.DeepSeq.Bounded.Seqable: Spark :: SeqNodeKind
+ Control.DeepSeq.Bounded.Seqable: Spark :: SeqNode
- Control.DeepSeq.Bounded.Seqable: force_ :: Generic a => SeqNodeKind -> a -> a
+ Control.DeepSeq.Bounded.Seqable: force_ :: Generic a => SeqNode -> a -> a
- Control.DeepSeq.Bounded.Seqable: rnf_ :: Generic a => SeqNodeKind -> a -> ()
+ Control.DeepSeq.Bounded.Seqable: rnf_ :: Generic a => SeqNode -> a -> ()
- Control.DeepSeq.Bounded.Seqable: seq_ :: Generic a => SeqNodeKind -> a -> b -> b
+ Control.DeepSeq.Bounded.Seqable: seq_ :: Generic a => SeqNode -> a -> b -> b

Files

HTML/deepseq-bounded.html view
@@ -1,4 +1,4 @@-<!DOCTYPE html>+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd"> <html> <head> <title>Bounded DeepSeq</title>@@ -13,15 +13,36 @@  <h2 style="margin-top: 50px;">Bounded Forcing</h2> +<a id="dig07s" class="dig-toggle-show" href='javascript:toggle("dig07");' style="margin-left: 0px;">Show Contents</a>+<div id="dig07" class="digression" style="margin-left: 0px;">+<a id="dig07h" style="margin-bottom: -16px;" class="dig-toggle-show" href='javascript:toggle("dig07");'>Hide</a><p style="margin-bottom: -10px;">+<div style="font-size: 85%;">+<ul><div style="font-size: 110%;">Contents</div>+<li> <a href="#intro">Intro</a>+<li> <a href="#design">Design Overview</a>+<li> <a href="#formally">Formally</a>+<li> <a href="#example">Example</a>+<li> <a href="#parallelism">Parallelism</a>+<li> <a href="#order">Controlling Evaluation Order</a>+<li> <a href="#fusion">Fusion</a>+<li> <a href="#generic-deriving">Generic Deriving</a>+<a id="intro"></a>+<li> <a href="#patalg">Pattern Algorithms</a>+<li> <a href="#otherexamples">Other Examples</a>+<li> <a href="#afterthoughts">Afterthoughts</a>+</ul>+</div>+</div>+<p style="margin-top: 20px;"> The <a href="http://hackage.haskell.org/package/deepseq-bounded"><span class="nowrap">deepseq-bounded</span></a> package provides two means of forcing a Haskell expression to an arbitrary but bounded depth, <tt>deepseqn</tt> and <tt>deepseqp</tt>. As compared with plain <tt>seq</tt> (incremental forcing) and the beloved <tt>deepseq</tt> (full forcing), the bounded versions bridge the gap between these extremes. <p>-Artificially forcing evaluation can be useful to relieve space leak, measure and tune performance, influence exception behaviour, make lazy I/O happen in a timely manner, and assure threads don't accidentally pass unevaluated computations to other threads ("time leak").-Bounded forcing (what this package offers) is necessary to work with streams, and other "infinite" data structures, where plain <tt>rnf</tt>/<tt>deepseq</tt>/<tt>force</tt> will diverge.+Artificially forcing evaluation can be useful to relieve space leak, measure and tune performance, influence exception behaviour, make lazy I/O happen in a timely manner, and assure threads don't accidentally pass unevaluated computations to other threads (<span class="nowrap">"time leak"</span>).+Bounded forcing (what this package offers) is necessary <span class="nowrap">to work</span> with streams, and other "infinite" data structures, where plain <tt>rnf</tt>/<tt>deepseq</tt>/<tt>force</tt> will diverge. <p> <a id="dig03s" class="dig-toggle-show" href='javascript:toggle("dig03");' style="margin-left: 0px;">Show</a> <div id="dig03" class="digression" style="margin-left: 0px;">-<a id="dig03h" class="dig-toggle-hide" href='javascript:toggle("dig03");'>Hide</a><p>+<a id="dig03h" style="margin-bottom: -16px;" class="dig-toggle-hide" href='javascript:toggle("dig03");'>Hide</a><p style="margin-bottom: 0px;"> My particular motivation for <tt><span class="nowrap">deepseq-bounded</span></tt> is to support tool building for space leak characterisation (and provisional alleviation). Readers interested in those aspects might like to have a look at <a href="http://hackage.haskell.org/package/seqaid">seqaid</a> and <a href="http://hackage.haskell.org/package/leaky">leaky</a>. Space leak is still an Achilles' heel of Haskell, they're often fatally severe, and can be as hard to debug as anything you see in other languages.@@ -33,6 +54,7 @@ The bounded forcing functions also have theoretical interest, spanning the <tt>seq</tt> / <tt>deepseq</tt> axis. They can be considered in a broader context of, for instance, strictness analysis and evaluation transformers. +<a id="design"></a> <h3>Library Design Overview</h3>  Following the tradition of the <a href="http://hackage.haskell.org/package/deepseq">deepseq</a> package, the <tt>NFDataN</tt> module contains a class <tt>NFDataN</tt>, with a method called <tt>rnfn</tt>, instances of which do the work of forcing bounded evaluation.@@ -58,8 +80,9 @@ <p> <a id="dig04s" class="dig-toggle-show" href='javascript:toggle("dig04");' style="margin-left: 0px;">Show</a> <div id="dig04" class="digression" style="margin-left: 0px;">-<a id="dig04h" class="dig-toggle-hide" href='javascript:toggle("dig04");'>Hide</a><p>-<pre style="width: 800px;">+<a id="dig04h" style="margin-bottom: -16px;" class="dig-toggle-hide" href='javascript:toggle("dig04");'>Hide</a><p style="margin-bottom: 0px;">+<pre>+<!--pre style="width: 800px;"--> rnfp      :: NFDataP a =&gt; Pattern -&gt; a -&gt; () deepseqp_ :: NFDataP a =&gt; Pattern -&gt; a -&gt; b -&gt; b forcep_   :: NFDataP a =&gt; Pattern -&gt; a -&gt; a@@ -75,56 +98,33 @@  compilePat :: String -&gt; Pattern </pre>-</div>  <p>-More examples are given further down this page, but here is one example to illustrate the use of <tt>NFDataP</tt>.-There is no essential dependence on <tt>rnf</tt> (from <tt>DeepSeq</tt>), but it is available as <tt>*</tt> and helps to concoct an example.-+Note also that <tt>rnfp</tt>/<tt>forcep</tt>/<tt>deepseqp</tt> influence strictness of their second argument, but the strictness of their first, <tt>Pattern</tt>, argument is totally unspecified.+It can, of course, be controlled by forcing the <tt>Pattern</tt>.+Note how this is not the same as composition of forcing functions: <pre>-  expr = (   undefined :: SomeType-           , ( someValueWantToForce, [2,4..] )-           , anotherValueWantToForce-         )---  forcep ".{#.{*#}*}" expr--= forcep_ ( compilePat ".{#.{*#}*}" ) expr--= forcep_ (Node WR [Node WI [],Node WR [Node WW [],Node WI []],Node WW []]) expr+     (&phi; &pi;<sub>B</sub> . &phi; &pi;<sub>A</sub>) x                 (1)+  =  &phi; &pi;<sub>B</sub> (&phi; &pi;<sub>A</sub> x) </pre>--<p>-which can be translated as-+versus <pre>-= let someval = someValueWeWantToForce-      another = anotherValueWeWantToForce-  in-        rnf someval-  `seq` rnf another-  `seq` expr+     &phi; (&phi; &pi;<sub>B</sub> &pi;<sub>A</sub>) x                   (2) </pre>--<p>-<div class="digression" style="padding-bottom: 0px;">-This final translation is actually not quite correct &mdash; <tt>forcep</tt> forces the spine of the paths from <tt>expr</tt> to the substructures we want to hammer with <tt>rnf</tt>, but this translation does not.-In particular, the pair constructor <tt>(,)</tt> for <tt>( someValueWantToForce, [2,4..] )</tt> is forced by <tt>forcep</tt>, but not by this translation.-<p>-This has no semantic impact, because it only concerns interior nodes, never leaves, and bottoms are always leaves.-It may burn a few more cycles to force paths, but it always produces the same value as the translation, given the same inputs.-</div>--<p>-The pattern <tt>".{#.{*#}*}"</tt> will match any ternary constructor, ignoring the first subexpression, completely forcing the third, and recursively matching subpattern <tt>".{*#}"</tt> on the middle subexpression.-+In <tt>(1)</tt> both <tt>Pattern</tt>s <tt>&pi;<sub>A</sub></tt> and <tt>&pi;<sub>B</sub></tt> have unspecified strictness.+However, in <tt>(2)</tt> <tt>&pi;<sub>B</sub></tt> has unspecified strictness, but <tt>&pi;<sub>A</sub></tt> has strictness determined (entirely) by <tt>&pi;<sub>B</sub></tt>.+We may say "entirely" since no additional demands placed on these expressions, in the context of execution of the program, can influence the strictness of either <tt>Pattern</tt> argument.+If we had <tt>&phi; &pi;<sub>B</sub> &pi;<sub>A</sub></tt>, without the outer <tt>&phi;</tt> wrapper of <tt>(2)</tt>, then the execution context might induce additional strictness in <tt>&pi;<sub>A</sub></tt> since now the program itself is demanding a value of type <tt>Pattern</tt>. <p>+This is all a bit subtle, the above might not be totally correct...+<!--+However, in <tt>(2)</tt> <tt>&pi;<sub>B</sub></tt> has unspecified strictness, but <tt>&pi;<sub>A</sub></tt> has strictness determined (in part) by <tt>&pi;<sub>B</sub></tt>.+We must say "in part" because the demands placed on these expressions, in the context of execution of the program, may induce strictness surpassing that encoded by <tt>&pi;<sub>B</sub></tt>.+--> -It's worth emphasising that pattern-matching requires forcing constructors along the way.-That is to say, every node in the path from the root to a node being pattern-matched is already forced.-So the shape of these forcing functions is always a rooted tree, with the root node corresponding to the outermost redex of the expression being forced.+</div> +<a id="formally"></a> <h3>Formally</h3>  <!--span class="red">Is this correct only relative to an arbitrary but fixed value?</span-->@@ -134,8 +134,8 @@ <!-- &sc; &sccue; --> <!-- &#8827; &#8829; --> <pre>-        b &gt; a  &rArr;                forcen b  &#8827;  forcen a    -- (strict) monotonicity-                  &or;  &forall; c &gt; b .  forcen c  =  forcen a    -- convergence+        b &gt; a  &rArr;                forcen b  &#8827;  forcen a    <span class="dcmnt">-- (strict) monotonicity</span>+                  &or;  &forall; c &gt; b .  forcen c  =  forcen b    <span class="dcmnt">-- convergence</span> </pre> <p> and@@ -150,45 +150,102 @@ Only strict monotonicity is interesting, since non-decreasing monotonicity <tt>&#8829;</tt> is axiomatic: you cannot unevaluate anything (push thunks back on the heap?...). +<a id="example"></a>+<h3>Example</h3>++<p>+Here is one example to illustrate the use of <tt>NFDataP</tt>.+There is no essential dependence on <tt>rnf</tt> (from <tt>DeepSeq</tt>), but it is available as <tt>*</tt> and it's familiarity helps to concoct an example.++<p>+So, suppose the following expression occurs in your code, and you have need (for whatever reason) to force the evaluation of <tt>exp_A</tt> and <tt>exp_B</tt>.+However, the total expression also contains some things you mustn't force, represented here by <tt>undefined</tt> and an infinite list.++<pre>+  expr = (   undefined :: SomeType+           , ( exp_A, [2,4..] )+           , exp_B+         )++  forcep "(.(*.)*)" expr<div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>= forcep_ ( compilePat "(.(*.)*)" ) expr<div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>= forcep_ (Node WR [Node WI [],Node WR [Node WW [],Node WI []],Node WW []]) expr+</pre>++<p>+which can be (almost) translated as++<pre>+= let x1 = exp_A+      x2 = exp_B+  in+        rnf x1+  `seq` rnf x2+  `seq` (   undefined :: SomeType+          , ( x1, [2,4..] )+          , x2+        )+</pre>++<p>+<a id="dig05s" class="dig-toggle-show" href='javascript:toggle("dig05");' style="margin-left: 0px;">Show</a>+<div id="dig05" class="digression" style="margin-left: 0px;">+<a id="dig05h" style="margin-bottom: -16px;" class="dig-toggle-hide" href='javascript:toggle("dig05");'>Hide</a><p style="margin-bottom: 0px;">+This final translation is actually not quite correct &mdash; <tt>forcep</tt> forces the spine of the paths from <tt>expr</tt> to the substructures we want to hammer with <tt>rnf</tt>, but this translation does not.+In particular, the pair constructor <tt>(,)</tt> for <tt>( exp_A, [2,4..] )</tt> is forced by <tt>forcep</tt>, but not by this translation.+[Is this true?...]+<!--+<p>+This has no semantic impact, because it only concerns interior nodes, never leaves, and bottoms are always leaves.+It may burn a few more cycles to force paths, but it always produces the same value as the translation, given the same inputs.+[Later: This really sounds like BS to me.]+-->+</div>++<p>+The pattern <tt>(.(*.)*)</tt> will match any ternary constructor, ignoring the first subterm, completely forcing the third, and recursively matching subpattern <tt>(*.)</tt> on the middle subterm!++<p>++It's worth emphasising that pattern-matching requires forcing constructors along the way.+That is to say, every node in the path from the root to a node being pattern-matched is already forced.+So the shape of these forcing functions is always a rooted tree, with the root node corresponding to the outermost redex of the expression being forced.++<a id="parallelism"></a> <h3>Parallelism</h3>  Varieties of <tt>PatNode</tt> to trigger <tt>Control.Parallel.par</tt> parallel evaluation are of interest.-This is supported by the new <tt>PR</tt>, <tt>PN</tt> and <tt>PW</tt> <tt>PatNode</tt> constructors.+This (along with a half dozen other things) is supported by the new <tt>PatNodeAttrs</tt> node attributes. In the DSL such nodes are represented by preceding them with an <tt>=</tt> character.-This is new work and not yet completely implemented, but it's very straightforward.  <p> So, revisiting our example  <pre>   expr = (   undefined :: SomeType-           , ( someValueWantToForce, [2,4..] )-           , anotherValueWantToForce+           , ( exp_A, [2,4..] )+           , exp_B          ) --  forcep ".{#.{=*#}*}" expr--= forcep_ ( compilePat ".{#.{=*#}*}" ) expr--= forcep_ (Node WR [Node WI [],Node WR [Node PW [],Node WI []],Node WW []]) expr+  forcep "(.(=*.)*)" expr<div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>= forcep_ ( compilePat "(.(=*.)*)" ) expr<div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>= forcep_ (Node WR [Node WI [],Node WR [Node PW [],Node WI []],Node WW []]) expr </pre>  <p> which translates approximately as -<a id="order"></a> <pre>-= let someval = someValueWeWantToForce-      another = anotherValueWeWantToForce+= let x1 = exp_A+      x2 = exp_B   in-        rnf someval-  `par` rnf another   -- note `par` (not `seq`)-  `seq` expr+        rnf x1+  `par` rnf x2                       <span class="dcmnt">-- note `par` (not `seq`)</span>+  `seq` (   undefined :: SomeType+          , ( x1, [2,4..] )+          , x2+        ) </pre> +<a id="order"></a> <p>-In particular, <tt>rnf someval</tt> will be sparked in parallel with the remainder of the forcing (<tt>rnf another</tt>).+In particular, <tt>rnf x1</tt> will be sparked in parallel with the remainder of the forcing (<tt>rnf x2</tt>).  <h3>Controlling Evaluation Order</h3> @@ -206,6 +263,24 @@ </pre> <p> where <a href="http://hackage.haskell.org/package/base-4.7.0.1/docs/GHC-Exts.html#v:lazy"><tt>lazy</tt></a> is a GHC primitve that prevents strictness of the second argument.++<p>This lets us write something like++<pre>+= let x1 = exp_A+      x2 = exp_B+  in+         rnf x1+  `pseq` rnf x2                       <span class="dcmnt">-- note `pseq` (not `seq`)</span>+  `seq`  (   undefined :: SomeType+          , ( x1, [2,4..] )+           , x2+         )+</pre>++<a id="dig06s" class="dig-toggle-show" href='javascript:toggle("dig06");' style="margin-left: 0px;">Show</a>+<div id="dig06" class="digression" style="margin-left: 0px;">+<a id="dig06h" style="margin-bottom: -16px;" class="dig-toggle-hide" href='javascript:toggle("dig06");'>Hide</a><p style="margin-bottom: 0px;"> In fact <tt>lazy</tt> is one of just two definitions living in the internal module <tt>GHC.Magic</tt> in the GHC source (the other is <tt>inline</tt>). Quoting from the source in <a href="http://hackage.haskell.org/package/base/docs/src/GHC-Conc-Sync.html#pseq">base</a> @@ -216,9 +291,16 @@ -- If it thinks pseq is strict in "y", then it often evaluates -- "y" before "x", which is totally wrong. </pre>+</div> -<h3 id="fusion">Fusion</h3>+<p>+This and more is now supported with the <tt>PatNodeAttrs</tt>.+Specifically, controlling order of evaluation of sibling forcing patterns is expressed as the prefix modifier <tt>&gt;cdba</tt>.+(Prefix modifiers may appear in any order.) +<a id="fusion"></a>+<h3>Fusion</h3>+ Little has been done so far to tune performance.  <p>@@ -240,7 +322,7 @@ </pre>  <p>-Other rules are probably possible (considering <a href="#patalg">PatAlg</a>), and may have been implemented since the last time this section was updated.+Other rules are probably possible (considering <a href="#patalg">PatUtil</a>), and may have been implemented since the last time this section was updated.  <p> Unfortunately I get GHC warnings for all my rules, such as@@ -255,7 +337,7 @@ <p> <a id="dig01s" class="dig-toggle-show" href='javascript:toggle("dig01");' style="margin-left: 0px;">Show</a> <div id="dig01" class="digression" style="margin-left: 0px;">-<a id="dig01h" class="dig-toggle-hide" href='javascript:toggle("dig01");'>Hide</a><p>+<a id="dig01h" style="margin-bottom: -16px;" class="dig-toggle-hide" href='javascript:toggle("dig01");'>Hide</a><p style="margin-bottom: 0px;"> There haven't been many cases of pattern composition coming up so far, except those deliberately written for the tests. Also, given the amount of pattern-matching required by unionPat, it's far from certain that this rule will improve performance. If the union could be computed once at compile-time (for static patterns only, of course) it would make a lot more sense.@@ -302,7 +384,8 @@ </div> --> -<h3 id="generic-deriving">Generic Deriving is Supported</h3>+<a id="generic-deriving"></a>+<h3>Generic Deriving is Supported</h3>  The <tt>GNFDataN</tt> and <tt>GNFDataP</tt> classes support automatic derivation of instances of <tt>NFDataN</tt> and <tt>NFDataP</tt> for arbitrary types, <span style="white-space: nowrap;">using SOP (<a href="http://hackage.haskell.org/package/generics-sop">generics-sop</a></span></tt>), a relatively new generics library. Latterly, <tt>Seqable</tt> supports all types via SOP, and there is no <tt>Seqable</tt> class, only generic functions.@@ -348,7 +431,7 @@ <p> <a id="dig02s" class="dig-toggle-show" href='javascript:toggle("dig02");' style="margin-left: 0px;">Show</a> <div id="dig02" class="digression" style="margin-left: 0px;">-<a id="dig02h" class="dig-toggle-hide" href='javascript:toggle("dig02");'>Hide</a><p>+<a id="dig02h" style="margin-bottom: -16px;" class="dig-toggle-hide" href='javascript:toggle("dig02");'>Hide</a><p style="margin-bottom: 0px;"> To derive instances of <tt>NFDataP</tt> for a data type (which requires also instances of superclasses <tt>NFDataN</tt> and of <tt>NFData</tt>), the incantation is:  <pre>@@ -361,8 +444,8 @@ import Generics.SOP.TH import Control.DeepSeq.Bounded ( NFDataN(..), grnfn, NFDataP(..), grnfp ) import Control.DeepSeq.Generics ( NFData(..), genericRnf )-import GHC.Generics ( Generic )    -- for deriving NFData-import Data.Typeable ( Typeable )  -- for name-constrained pattern nodes+import GHC.Generics ( Generic )    <span class="dcmnt">-- for deriving NFData</span>+import Data.Typeable ( Typeable )  <span class="dcmnt">-- for name-constrained pattern nodes</span>  data TA = A1 TB | A2 deriving ( Show, Generic, Typeable ) instance NFData  TA where rnf  = genericRnf@@ -387,18 +470,16 @@ It might be worth noting that the <a href="http://hackage.haskell.org/package/seqaid">seqaid</a> package provides a mechanism for completely automating this process. However, it depends on use of a preprocessor, and was deemed inappropriate for this core library. -<h3>Pattern Algebra</h3>+<h3>Pattern Utilities</h3>  In the course of developing <tt>NFDataP</tt>, several utility functions were written for creating, modifying and combining patterns.-They've been collected in the <tt>PatAlg</tt> module.--<pre>-  module Control.DeepSeq.Bounded.PatAlg+They've been collected in the <tt>PatUtil</tt> module. -  import Control.DeepSeq.Bounded.Pattern+<pre style="padding-top: 20px;">+  module Control.DeepSeq.Bounded.PatUtil   -- implicitly imports Pattern also  -  <b>Basic operations on Patterns</b>+  <b>Basic operations on Pattern</b>    <span style="font-size: 95%;"><em>-- Compute the union of a list of </em>Pattern<em>s.</em></span>   <b style="color: #333;">unionPats :: [ Pattern ] -&gt; Pattern</b>@@ -408,30 +489,27 @@    <span style="font-size: 95%;"><em>-- Return </em>True<em> if the first pattern matches the second   -- (and </em>False<em> otherwise).  Note that matching does not imply-  -- spanning. Equality </em>(==)<em> or </em>flip isSubPatOf<em> will-  -- work there, depending on your intentions.</em></span>-  <b style="color: #333;">isSubPatOf :: Pattern -&gt; Pattern -&gt; Bool</b>+  -- spanning;  </em>flip subPat<em> would work for that.</em></span>+  <b style="color: #333;">subPat :: Pattern -&gt; Pattern -&gt; Bool</b>     <b>Operations for obtaining and modifying Patterns based on a term</b>    <span style="font-size: 95%;"><em>-- Obtain a lazy pattern, matching the shape of   -- an arbitrary term (value expression).-  -- Interior nodes will be </em>WR<em>, and leaves will be </em>WS<em>.</em></span>+  -- All nodes will be </em>WR<em>.</em></span>   <b style="color: #333;">mkPat :: forall d. Data d =&gt; d -&gt; Pattern</b>    <span style="font-size: 95%;"><em>-- Obtain a lazy pattern, matching the shape of   -- an arbitrary term, but only down to at most depth </em>n<em>.-  -- Interior nodes will be </em>WR<em>.  Leaf nodes will be </em>WS<em> if they-  -- were leaves in the host value; otherwise they will be </em>WR<em>.-  -- Satisfies </em>forcep . mkPatN n = forcen n<em>.</em></span>+  -- Satisfies </em>forcep (mkPatN n x) x = forcen n x<em>.</em></span>   <b style="color: #333;">mkPatN :: forall d. Data d =&gt; Int -&gt; d -&gt; Pattern</b>    <span style="font-size: 95%;"><em>-- Grow all leaves by one level within the shape of the provided value.</em></span>   <b style="color: #333;">growPat :: forall d. Data d =&gt; Pattern -&gt; d -&gt; Pattern</b>  -  <b>Operations for obtaining subpatterns (in the 'isSubPatOf' sense)</b>+  <b>Operations for obtaining subpatterns (in the 'subPat' sense)</b>    <span style="font-size: 95%;"><em>-- Given an integer depth and a pattern, truncate the pattern to   -- extend to at most this requested depth.</em></span>@@ -447,7 +525,7 @@   <b>Operations for the direct construction and perturbation of Patterns</b>    <span style="font-size: 95%;"><em>-- There is no Nil in the Pattern type, but a single </em>WI<em> node as-  -- empty pattern is a dependable way to assure the empty pattern+  -- empty pattern is a dependable way to ensure that the empty pattern   -- never forces anything.</em></span>   <b style="color: #333;">emptyPat :: Pattern</b> @@ -455,13 +533,13 @@   -- become the children of the root (order is preserved).</em></span>   <b style="color: #333;">liftPats :: [ Pattern ] -&gt; Pattern</b> -  <span style="font-size: 95%;"><em>-- Introduce siblings at a node (interior or leaf) of the target.+  <span style="font-size: 95%;"><em>-- Add children to a node (interior or leaf) of the target.   -- The first argument is target, the second is a path, and the   -- third is a list of subpatterns for insertion, along with the   -- indices of the child before which to insert.</em></span>   <b style="color: #333;">splicePats :: Pattern -&gt; [Int] -&gt; [ (Int, Pattern) ] -&gt; Pattern</b> -  <span style="font-size: 95%;"><em>-- Elide siblings at a node (interior or leaf) of the target.+  <span style="font-size: 95%;"><em>-- Elide children of a node (interior or leaf) of the target.   -- The first argument is target, the second is a path, and the   -- third is a list of child indices for elision.</em></span>   <b style="color: #333;">elidePats :: Pattern -&gt; [Int] -&gt; [Int] -&gt; Pattern</b>@@ -473,7 +551,8 @@   <b style="color: #333;">erodePat :: StdGen -&gt; [Int] -&gt; Pattern -&gt; (Pattern, StdGen)</b> </pre> -<h3>Examples</h3>+<a id="otherexamples"></a>+<h3>Other Examples</h3>  More examples can be browsed in the <a href="tests.html">testing output</a>. Here we only touch on a few particulars.@@ -506,40 +585,288 @@ First, note that we can handle infinite values, unlike <tt>deepseq</tt>.  <pre>-     force $ take 5 [1,2..]   -- [1,2,3,4,5]-     take 5 $ force [1,2..]   -- &lt;&lt; nonterminates &gt;&gt;+  force $ take 5 [1,2..]   <span class="dcmnt">-- [1,2,3,4,5]</span>+  take 5 $ force [1,2..]   <span class="dcmnt">-- &lt;&lt; nonterminates &gt;&gt;</span> -     forcen 100 $ take 5 [1,2..]   -- [1,2,3,4,5]-     take 5 $ forcen 100 [1,2..]   -- [1,2,3,4,5]+  forcen 100 $ take 5 [1,2..]   <span class="dcmnt">-- [1,2,3,4,5]</span>+  take 5 $ forcen 100 [1,2..]   <span class="dcmnt">-- [1,2,3,4,5]</span> </pre>  <p> Oops, never finished this section... And that's a pretty silly example, although it illustrates the distinction. Best to refer to the tests for examples, or just play around.-Will try to toss in a few more scraps...  <p> Here is the result of iterating <tt>shrinkPat</tt> on a test pattern.+<!--span style="font-size: 80%;">[Note to self: This should include <tt>P*</tt> and <tt>T*</tt> nodes for illustration, if they actually even work.]</span-->  <pre>-.{.{#.{*.{.*3}}}.{..{*1.{..{##}}}}}-.{.{#.{*5.{#*2}}}.{#.{#.{##}}}}-.{.{#.{*4.{#.}}}.{#.{##}}}-.{.{#.{*3.{##}}}.{##}}-.{.{#.{*2#}}#}-.{.{#.{.#}}#}-.{.{#.{##}}#}-.{.{##}#}-.{##}+((.(*(!*3)))(!(*1(!(.!)))))+((.(*5(.*2)))(.(.(.(..)))))+((.(*4(.!)))(.(.(..))))+((.(*3(..)))(.(..)))+((.(*2.))(..))+((.(!.)).)+((.(..)).)+((..).)+(..)+.+.+</pre>+<!--+((.(*(!*3)))(!(*1(!(.!)))))+((.(*5(.*2)))(.(.(.(..)))))+((.(*4(.!)))(.(.(.!))))    +((.(*3(..)))(.(.(..))))    +((.(*2!))(.(.!)))          +((.(!.))(.(..)))           +((.(..))(.!))              +((.!)(..))                 +((..)!)                    +(!.)                       +(..)                       +!                          +.                          +.                          +{{#{*{.*3}}}{.{*1{.{#.}}}}}+{{#{*5{#*2}}}{#{#{#{##}}}}}+{{#{*4{#.}}}{#{#{#.}}}}+{{#{*3{##}}}{#{#{##}}}}+{{#{*2.}}{#{#.}}}+{{#{.#}}{#{##}}}+{{#{##}}{#.}}+{{#.}{##}}+{{##}.}+{.#}+{##}+. # #+-->++<!-- style="text-align: center; width: 90%; height: 20px; background: #fff;"> -->+<!--hr style="display: block; width: 80%; height: 1px; border: 0; border-top: 1px solid #ccc; padding: 0; margin-top: 46px; margin-bottom: 0px;" /-->+<!--hr class="hrule" /-->++<a id="afterthoughts"></a>+<h3 style="margin-top: 50px;">Afterthoughts</h3>++<p style="margin-top: 20px;">+<a id="dig08s" class="dig-toggle-show" href='javascript:toggle("dig08");' style="margin-left: 20px;">Show</a>+<div id="dig08" class="digression" style="margin-left: 20px;">+<a id="dig08h" style="margin-bottom: -16px;" class="dig-toggle-show" href='javascript:toggle("dig08");'>Hide</a><p style="margin-bottom: -10px;">++<a id="newsyntax"></a>+<h4 style="margin-bottom: 18px; margin-top: 0px;">Better concrete pattern syntax</h4>++<p style="margin-top: 20px;">+<div style="color: #F33; font-size: 80%;">+This change is in 0.6. The text above, and all related online<br />documents, have been revised to use the <em>new</em> grammar.+</div>++<p>+It seems possible to simplify the lexical syntax of the pattern DSL.+<ul>+<li> If the <tt>PatNode</tt> is <tt>WR</tt>, don't show the dot!+<li> For <tt>PR</tt>, show <tt>=</tt><em style="font-size: 85%;">subpats</em><tt></tt> instead of <tt>=.</tt><em style="font-size: 85%;">subpats</em><tt></tt>+<li> For <tt>TR</tt>, show <tt>:</tt><em style="font-size: 85%;">type subpats</em><tt></tt> instead of <tt>.:</tt><em style="font-size: 85%;">type subpats</em><tt></tt>+</ul>++<p>+Here is the <tt>shrinkPat</tt> sequence again, new syntax on the left.++<pre>+ {{#{*{.*3}}}{.{*1{.{#.}}}}}    .{.{#.{*.{.*3}}}.{..{*1.{..{#.}}}}}+ {{#{*5{#*2}}}{#{#{#{##}}}}}    .{.{#.{*5.{#*2}}}.{#.{#.{#.{##}}}}}+ {{#{*4{#.}}}{#{#{#.}}}}        .{.{#.{*4.{#.}}}.{#.{#.{#.}}}}+ {{#{*3{##}}}{#{#{##}}}}        .{.{#.{*3.{##}}}.{#.{#.{##}}}}+ {{#{*2.}}{#{#.}}}              .{.{#.{*2.}}.{#.{#.}}}+ {{#{.#}}{#{##}}}               .{.{#.{.#}}.{#.{##}}}+ {{#{##}}{#.}}                  .{.{#.{##}}.{#.}}+ {{#.}{##}}                     .{.{#.}.{##}}+ {{##}.}                        .{.{##}.}+ {.#}                           .{.#}+ {##}                           .{##}+ .                              .+ #                              #+ #                              # </pre> -<div class="footer" style="margin-top: 50px;">+<p>+It'll require quite a few changes, and a major version bump, but I've filed the <a href="http://fremissant.net/seqaid/trac#20141223-01">ticket</a>.+This didn't really get much attention, since my main thrust is toweard <a href="http://hackage.haskell.org/package/seqaid">seqaid</a> automation.++<p>+Later: And now the changes were made, and the concrete syntax is slightly different (refer to the <a href="grammar.html">grammar</a>):++<pre>+ ((.(*(!*3)))(!(*1(!(.!)))))    !(!(.!(*!(!*3)))!(!!(*1!(!!(.!)))))+ ((.(*5(.*2)))(.(.(.(..)))))    !(!(.!(*5!(.*2)))!(.!(.!(.!(..)))))+ ((.(*4(.!)))(.(.(.!))))        !(!(.!(*4!(.!)))!(.!(.!(.!))))+ ((.(*3(..)))(.(.(..))))        !(!(.!(*3!(..)))!(.!(.!(..))))+ ((.(*2!))(.(.!)))              !(!(.!(*2!))!(.!(.!)))+ ((.(!.))(.(..)))               !(!(.!(!.))!(.!(..)))+ ((.(..))(.!))                  !(!(.!(..))!(.!))+ ((.!)(..))                     !(!(.!)!(..))+ ((..)!)                        !(!(..)!)+ (!.)                           !(!.)+ (..)                           !(..)+ !                              !+ .                              .+ .                              .+</pre>++<p>+It's nice to see this in the reverse sequence, as a "growth strategy"+to arrive at the big pattern. As a bonus, I've added whitespace padding+to emphasise the structural relationships &mdash; this can't be done+automatcially yet, although whitespace is accepted by the parser.++<pre>+ .                          + !                          + <span class="grey">(</span>.        <span class="grey">   </span>.         <span class="grey">    )</span>+ <span class="grey">(</span>!        <span class="grey">   </span>.         <span class="grey">    )</span>+ <span class="grey">(</span>(..      <span class="grey">  )</span>!         <span class="grey">    )</span>+ <span class="grey">(</span>(.!      <span class="grey">  )</span>(..       <span class="grey">    )</span>+ <span class="grey">(</span>(.(. .   <span class="grey"> ))</span>(.!       <span class="grey">    )</span>+ <span class="grey">(</span>(.(! .   <span class="grey"> ))</span>(.(. .    <span class="grey">  )))</span>+ <span class="grey">(</span>(.(*2!   <span class="grey"> ))</span>(.(. !    <span class="grey">  )))</span>+ <span class="grey">(</span>(.(*3(.. <span class="grey">)))</span>(.(. (..  <span class="grey"> ))))</span>+ <span class="grey">(</span>(.(*4(.! <span class="grey">)))</span>(.(. (.!  <span class="grey"> ))))</span>+ <span class="grey">(</span>(.(*5(.*2<span class="grey">)))</span>(.(. (.(..<span class="grey">)))))</span>+ <span class="grey">(</span>(.(* (!*3<span class="grey">)))</span>(!(*1(!(.!<span class="grey">)))))</span>+</pre>++<p>+Oops! I see my tree shape was more monotonous than intended (although this is the most common texture seen in the wild, namely, right-biased binary trees).+<p>+I've fainted some parentheses, because, while I hesitate to obliterate them, they just take up space.+<p>+Now, if only we could just write <tt>"3"</tt> instead of <tt>"*3"</tt>!++<pre>+ .+ 1+ <span class="grey">(</span>.      <span class="grey">   </span>.        <span class="grey">    )</span>+ <span class="grey">(</span>1      <span class="grey">   </span>.        <span class="grey">    )</span>+ <span class="grey">(</span>(..    <span class="grey">  )</span>1        <span class="grey">    )</span>+ <span class="grey">(</span>(.1    <span class="grey">  )</span>(..      <span class="grey">    )</span>+ <span class="grey">(</span>(.(..  <span class="grey"> ))</span>(.1      <span class="grey">    )</span>+ <span class="grey">(</span>(.(1.  <span class="grey"> ))</span>(.(..    <span class="grey">  )))</span>+ <span class="grey">(</span>(.(21  <span class="grey"> ))</span>(.(.1    <span class="grey">  )))</span>+ <span class="grey">(</span>(.(3(..<span class="grey">)))</span>(.(.(..  <span class="grey"> ))))</span>+ <span class="grey">(</span>(.(4(.1<span class="grey">)))</span>(.(.(.1  <span class="grey"> ))))</span>+ <span class="grey">(</span>(.(5(.2<span class="grey">)))</span>(.(.(.(..<span class="grey">)))))</span>+ <span class="grey">(</span>(.(*(13<span class="grey">)))</span>(1(1(1(.1<span class="grey">)))))</span>+</pre>++<p>+But unfortunately note the <tt>"13"</tt> on the last line. (And this example was in no way contrived to exhibit this problem, it arises naturally enough.)+<p>+To get around this up to and including depth 19, we can continue to use <tt>"!"</tt> for <tt>"*1"</tt>:++<pre>+ .+ !+ <span class="grey">(</span>.      <span class="grey">   </span>.        <span class="grey">    )</span>+ <span class="grey">(</span>!      <span class="grey">   </span>.        <span class="grey">    )</span>+ <span class="grey">(</span>(..    <span class="grey">  )</span>!        <span class="grey">    )</span>+ <span class="grey">(</span>(.!    <span class="grey">  )</span>(..      <span class="grey">    )</span>+ <span class="grey">(</span>(.(..  <span class="grey"> ))</span>(.!      <span class="grey">    )</span>+ <span class="grey">(</span>(.(!.  <span class="grey"> ))</span>(.(..    <span class="grey">  )))</span>+ <span class="grey">(</span>(.(2!  <span class="grey"> ))</span>(.(.!    <span class="grey">  )))</span>+ <span class="grey">(</span>(.(3(..<span class="grey">)))</span>(.(.(..  <span class="grey"> ))))</span>+ <span class="grey">(</span>(.(4(.!<span class="grey">)))</span>(.(.(.!  <span class="grey"> ))))</span>+ <span class="grey">(</span>(.(5(.2<span class="grey">)))</span>(.(.(.(..<span class="grey">)))))</span>+ <span class="grey">(</span>(.(*(!3<span class="grey">)))</span>(!(!(!(.!<span class="grey">)))))</span>+</pre>++<p>+If I were going to be doing a lot of manual work with patterns, and didn't need <tt>NFDataN</tt> facilities deeper than 19, I would probably go with this.+<p>+However, the default must remain <tt>"*23"</tt> as it is unambiguous in the general case.+<p>+I'll offer a <tt>.cabal</tt> flag to enable the short version, why not.... This flag must absolutely be <tt>False</tt> by default. It is at the user's risk that they adopt non-default syntax...++<p>+And this one's even better (because unambiguous), though it can only express <tt>*N</tt> nodes up to a depth of nine:++<pre>+ .+ !+ <span class="grey">(</span>0      <span class="grey">   </span>0        <span class="grey">    )</span>+ <span class="grey">(</span>1      <span class="grey">   </span>0        <span class="grey">    )</span>+ <span class="grey">(</span>(00    <span class="grey">  )</span>1        <span class="grey">    )</span>+ <span class="grey">(</span>(01    <span class="grey">  )</span>(00      <span class="grey">    )</span>+ <span class="grey">(</span>(0(00  <span class="grey"> ))</span>(01      <span class="grey">    )</span>+ <span class="grey">(</span>(0(10  <span class="grey"> ))</span>(0(00    <span class="grey">  )))</span>+ <span class="grey">(</span>(0(21  <span class="grey"> ))</span>(0(01    <span class="grey">  )))</span>+ <span class="grey">(</span>(0(3(00<span class="grey">)))</span>(0(0(00  <span class="grey"> ))))</span>+ <span class="grey">(</span>(0(4(01<span class="grey">)))</span>(0(0(01  <span class="grey"> ))))</span>+ <span class="grey">(</span>(0(5(02<span class="grey">)))</span>(0(0(0(00<span class="grey">)))))</span>+ <span class="grey">(</span>(0(*(13<span class="grey">)))</span>(1(1(1(01<span class="grey">)))))</span>+</pre>++<p>+And I then see a mistake (this is an hour before uploading 0.6.0.0), that <tt>WS</tt> has greater forcing potential than any <tt>WR</tt> so situated!+So cannot shrink into it. After changing <tt>shrinkPat</tt>:++<pre>+0                       +<span class="grey">(</span>0      <span class="grey">   </span>0        <span class="grey">    )</span>+<span class="grey">(</span>(00    <span class="grey">  )</span>0        <span class="grey">    )</span>+<span class="grey">(</span>(0(00  <span class="grey"> ))</span>0        <span class="grey">    )</span>+<span class="grey">(</span>(0(10  <span class="grey"> ))</span>0        <span class="grey">    )</span>+<span class="grey">(</span>(0(20  <span class="grey"> ))</span>(00      <span class="grey">   ))</span>+<span class="grey">(</span>(0(3(00<span class="grey">)))</span>(0(00    <span class="grey">  )))</span>+<span class="grey">(</span>(0(4(01<span class="grey">)))</span>(0(0(00  <span class="grey"> ))))</span>+<span class="grey">(</span>(0(5(02<span class="grey">)))</span>(0(0(0(00<span class="grey">)))))</span>+<span class="grey">(</span>(0(*(13<span class="grey">)))</span>(1(1(1(01<span class="grey">)))))</span>+</pre>++<h4 style="margin-bottom: 20px;">"I can has data family?..."</h4>++I'm not normally big on type extensions, and rarely stray beyond the precincts of H98 in my own code, but type families allured me.+I am hoping to use it to express things about forcing functions in general (<em>e.g.</em> commutativity of composition).++<p>+The data family certainly packs a whollop, making an extremely concise summary of <tt>deepseq-bounded</tt>.+I don't know how to use it yet, but it compiles. :)+Thought I'd throw it in, since Haskellers like their type extensions.+<!--+The actual evaluation order of <tt>&phi; &kappa;<sub>1</sub> &middot; &phi; &kappa;<sub>2</sub></tt> is probably interleaved, and could easily be in parallel.+So, if it <em>did</em> matter what order the forcings occurred, we'd likely be noticing.+Still, it's possible to miss the pockets of observable nondeterminacy.+-->++<pre>+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}  <span class="cmnt">-- b/c Pattern = Node PatNode [Pattern]</span><div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>class FF k where+   data F k :: * -&gt; *+<span class="cmnt">-- phi :: (<span style="color: #C44;">Seqable</span> v, NFDataN v, NFDataP v) =&gt; k -&gt; F k v -&gt; v</span>+   phi :: (<span style="color: #1B3;"><b>Generic</b></span> v, NFDataN v, NFDataP v) =&gt; k -&gt; F k v -&gt; v+<span class="cmnt">-- phi ::  <span style="color: #1B3;"><b>Generic</b></span> v                        =&gt; k -&gt; F k v -&gt; v</span>  <span style="color: #95C;">-- would be nice...</span><div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>instance FF SeqNode   <span class="cmnt">-- Seqable.force_</span>+instance FF Int       <span class="cmnt">-- NFDataN.forcen</span>+instance FF Pattern   <span class="cmnt">-- NFDataP.forcep</span>+</pre>++The constraints could probably shrink to <em>just</em> <tt class="virgin" style="color: #1B3;"><b>Generic</b></tt> with a bit of work... In fact, trying it now -- to do away with <tt>NFDataN</tt> and <tt>NFDataP</tt> classes, same way implemented <tt>JUST_ALIAS_GSEQABLE</tt> flag for <tt>Seqable</tt>&hellip;+<div style="display: inline-block; margin-left: 8px; font-size: 60%;">[<span style="color: red;">Fail</span> (even for <tt>NFDataN</tt>) &hellip;&hellip; for now&hellip;]</span></div>+<div style="height: 10px;"></div>+<span style="font-size: 80%; margin-left: 6px;">Jan. 2015</span>+</div>++<p style="margin-top: 40px;">+<div class="comments" style="margin-top: 10px;" onclick="javascript:document.location.href = 'http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/';">+<a href="http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/"><b>Discussion</b></a><br /><span style="font-size: 60%;"><a style="display: inline-block; color: black; position: relative; top: -8px; href="http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/">(reddit)&nbsp;</a></span>+</div>++<div class="footer" style="margin-top: 30px;"> Andrew Seniuk <br>-July 13, 2014+July 13 / Dec. 2014 <br> <tt>rasfar@gmail.com</tt> </div>
+ HTML/grammar.html view
@@ -0,0 +1,305 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">+<html>+<head>+<title>Pattern DSL for deepseq-bounded</title>+<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate" />+<meta http-equiv="Pragma" content="no-cache" />+<meta http-equiv="Expires" content="0" />+<link rel="stylesheet" href="style.css" />+<style>+tt { background: transparent; }+.open { color: #000; font-weight: normal; font-style: italic; }+.meta2 { color: #448; font-weight: normal; font-style: italic; }+.meta2b { color: #448; font-weight: normal; font-style: italic; font-size: 100%; }+.meta { color: #BB0; font-weight: normal; font-style: normal; font-size: 130%; }+/*+.meta { color: #BB0; font-weight: normal; font-style: normal; font-size: 120%; }+*/+.bmeta { color: #BB0; font-weight: bold; font-style: normal; font-size: 120%; }+/*+.meta { color: #AA0; font-weight: normal; font-style: italic; }+.bmeta { color: #AA0; font-weight: bold; font-style: italic; }+*/+.ameta { color: #DD0; font-weight: bold; font-style: normal; font-size: 130%; }+/*+.ameta { color: #DD0; font-weight: bold; font-style: normal; font-size: 120%; }+*/+.ametafaint { color: rgba(220,220,0,0.2); font-weight: bold; font-style: normal; font-size: 120%; }+.conc { color: #E30; font-weight: bold; font-style: normal; }+.conc2 { color: #E30; font-weight: bold; font-style: normal; font-size: 110%; }+</style>+</head>++<body>++<div class="main">+<!--div class="main" style="font-size: 14pt;"-->++<h3 style="margin-top: 50px;">Grammar for <tt class="virgin" style="font-size: 90%;">Control.DeepSeq.Bounded.Pattern</tt> Language</h3>++<p style="margin-top: 16px;">+<div style="color: #F33; font-size: 80%;">+This change is in 0.6.&nbsp;&nbsp;All related online documents<br />have been revised to use the <em>new</em> grammar.+</div>++<p style="margin-top: 16px;">+The current grammar for the deepseq-bounded Pattern DSL is:++<a id="new-grammar"></a>+<p style="margin-bottom: 30px;">+<pre>+  <b>New Grammar</b> (deepseq-bounded &gt;=0.6)<div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>  <span class="meta2">pat</span>          <span class="meta">&rarr;</span>  <span class="meta">[</span> <span class="meta2">modifiers</span> <span class="meta">]</span><span style="margin-left: 6px;">&nbsp;</span><span class="meta2">pat'</span><div style="margin: 0px; padding:0px; clear: both; height: 4px">&nbsp;</div>  <span class="meta2">pat'</span>         <span class="meta">&rarr;</span>  <span class="ametafaint">|</span>  <span class="conc">.</span> <span class="ameta"> | </span> <span class="conc" style="font-size: 120%;">!</span> <span class="ameta"> | </span> <span class="conc">*</span> <span class="meta">[</span> <span class="meta2">decimalint</span> <span class="meta">]</span> <span class="ameta"> | </span> <span class="conc2">(</span> <span class="meta">{</span> <span class="meta2">pat</span> <span class="meta">}</span> <span class="conc2">)</span><div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>  <span class="meta2">modifiers</span>    <span class="meta">&rarr;</span>  <span class="open">zero or one of each of the eight</span> <span class="meta2">modifier</span><span class="open">, in any order</span>+  <span class="meta2">modifier</span>     <span class="meta">&rarr;</span>  <span class="ametafaint">|</span>  <span class="conc">=</span> <span class="ameta"> | </span> <span class="conc">+</span> <span class="ameta"> | </span> <span class="conc">^</span> <span class="ameta"> | </span> <span class="conc">/</span> <span class="ameta"> | </span> <span class="conc">%</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">| </span> <span class="conc">:</span> <span class="meta2">typename</span> <span class="meta">{</span> <span class="conc">;</span> <span class="meta2">typename</span> <span class="meta">}</span> <span class="conc">:</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">| </span> <span class="conc">@</span> <span class="meta2">decimalint</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">| </span> <span class="conc">></span> <span class="meta2">permutation</span><div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>  <span class="meta2">typename</span>     <span class="meta">&rarr;</span>  <span class="open">string containing neither</span> <span class="conc">:</span> <span class="open">(unless <span class="meta2">escaped</span><span class="open">), nor <span class="conc">;</span>+  <span class="meta2">escaped</span>      <span class="meta">&rarr;</span>  <span class="conc">\\:</span>+  <span class="meta2">decimalint</span>   <span class="meta">&rarr;</span>  <span class="open">digit string not beginning with zero</span>+  <span class="meta2">permutation</span>  <span class="meta">&rarr;</span>  <span class="open">of an initial part of the lowercase alphabet, e.g.</span> <span class="conc">cdba</span>+</pre>++<p>+Here <tt class="virgin"><span class="meta" style="font-weight: bold; font-size: 110%;">gold</span></tt> and <span class="meta2" style="font-weight: bold;">blue</span> are meta-syntax, <tt class="virgin"><span class="conc" style="font-size: 110%;">red</span></tt> is concrete lexical syntax, and <tt class="virgin"><span class="open" style="font-weight: bold; font-size: 110%;">black</span></tt> is informal description.++<p>+<ul>+<li>+<tt class="virgin">+<span class="bmeta">{</span></tt>&hellip;<tt><span class="bmeta">}</span>+</tt>+means "zero or more repetitions of the enclosed".+<li>+<tt class="virgin">+<span class="bmeta">[</span></tt>&hellip;<tt><span class="bmeta">]</span>+</tt> +means "zero or one occurrence of the enclosed".+<li>+<tt class="virgin">+</tt>&hellip;<tt><span class="ameta">|</span></tt>&hellip;<tt>+</tt> +signifies a group of two or more alternatives, exactly one of which must be selected. This important metasyntax is more brightly tinted, to help it stand out.+<li>+<tt class="virgin">+<span class="bmeta">(</span></tt>&hellip;<tt><span class="bmeta">)</span>+</tt> +groups meta-expressions, useful for nested alternation.+</ul>++<p>+Optional whitespace can go between any two tokens (basically,+anyplace there is space shown in the grammar above).++<p>+Semicolons never need escaping, because they're already illegal+as part of any Haskell type name.++<p>+The semantics are given formally in the+<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#t:PatNode">PatNode</a>+and+<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#t:PatNodeAttrs">PatNodeAttrs</a>+documentation, as well as informally in the <a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#t:setPatternPatNodeUniqueIDs">examples</a>, and through the project <a href="http://www.fremissant.net/deepseq-bounded">homepage</a>.++<hr class="hrule" style="margin-top: 40px;"/>++<p style="margin-top: 40px;">+Notable changes from 0.5.5 are:++<ul>+<li>+<span class="conc">.</span>+became <span class="conc">!</span>&nbsp;+(<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#v:WS">WS</a> pattern nodes)+<li>+<span class="conc">#</span>+became <span class="conc">.</span>&nbsp;+(<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#v:WS">WI</a> pattern nodes)+<li> braces (<span class="conc">{</span>&hellip;<span class="conc">}</span>) became parentheses (<span class="conc">(</span>&hellip;<span class="conc">)</span>)+<li> semicolon (instead of space) used to separate <span class="meta2">typename</span>s+<li> <span class="conc">()</span> (empty subpattern group, formerly using braces of course) is no longer used to terminate type constraint lists for+<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#v:TI">TI</a>,+<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#v:TN">TN</a>, and+<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#v:TW">TW</a> pattern nodes;+rather, a single colon is used+<li> a single colon is now also required to terminate <span class="meta2">typename</span> lists in+<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#v:TR">TR</a>+pattern nodes, which formerly were implicitly closed by the opening brace of the ensuing subpattern group (which must be present)+<li> the language was enriched with seven new, prefix modifiers (called attributes in the API; refer to+<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#t:PatNodeAttrs">PatNodeAttrs</a>)+<li> type-constraint was made simply an eighth prefix modifer (formerly postfix; now only depth for <tt>*N</tt> nodes is postfix).+</ul>++<p style="margin-top: 40px;">+There were also a few things which were almost changed, but decided against for 0.6.+These may or may not end up in 0.7.++<ul>+<li> the <a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#v:WS">WS</a> pattern node was almost removed from the language, since it is expressible as <tt>*1</tt>, but it is too convenient in testing and examples to sacrifice a single-character designation+<li> the <a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#v:TI">T*</a> pattern nodes are probably going to get absorbed by +<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#t:PatNodeAttrs">PatNodeAttrs</a>+in a way analogous to what happened to <span class="nowrap">the <span class="conc">=</span>+(<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html#v:doSpark">doSpark</a>)</span>+</ul>++<p>+Up until version 0.7, flags are available to revert to the old grammar (or to turn off certain changes only), while allowing you to continue to enjoy some of the code improvements since 0.5.5.+However, use of the new grammar is strongly encouraged, the old grammar is deprecated and support will probably be dropped in 0.7.++<hr class="hrule" style="margin-top: 60px;"/>++<p style="margin-top: 40px;">+The rest of this page details earlier versions of the grammar, and discusses some rationales behind the changes leading to the above, present syntax.++<p>+First, we have the grammar for all versions of <tt>deepseq-bounded</tt> up to and including 0.5.5:++<p style="margin-bottom: 30px;">+<pre>+  <b>Old Grammar</b> (deepseq-bounded &lt;0.6)<div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>  <span class="meta2">pat</span> <span class="meta">&rarr;</span>  <span class="meta">[</span> <span class="conc">=</span> <span class="meta">]</span> <span class="conc">.</span> <span class="meta">[</span> <span class="conc">{</span> <span class="meta">{</span> <span class="meta2">pat</span> <span class="meta">}</span> <span class="conc">}</span> <span class="meta">]</span>+      <span class="ameta">|</span>  <span class="meta">(</span> <span class="meta">[</span> <span class="conc">=</span> <span class="meta">]</span> <span class="conc">*</span> <span class="meta">[</span> <span class="meta2">decimalint</span> <span class="meta">]</span> <span class="ameta"> | </span> <span class="conc">#</span> <span class="meta">)</span>+      <span class="ameta">|</span>  <span class="conc">.:</span> <span class="meta2">ctorname</span> <span class="meta">{</span> <span class="meta2">space</span> <span class="meta2">ctorname</span> <span class="meta">}</span> <span class="conc">{</span> <span class="meta">{</span> <span class="meta2">pat</span> <span class="meta">}</span> <span class="conc">}</span>+      <span class="ameta">|</span>  <span class="meta">(</span> <span class="conc">*</span> <span class="meta">[</span> <span class="meta2">decimalint</span> <span class="meta">]</span> <span class="ameta"> | </span> <span class="conc">#</span> <span class="meta">)</span> <span class="conc">:</span> <span class="meta2">typename</span> <span class="meta">{</span> <span class="meta2">space</span> <span class="meta2">typename</span> <span class="meta">}</span> <span class="conc">{}</span>+  <span class="meta2">ctorname</span> <span class="meta">&rarr;</span> <span class="open">string not containing whitespace</span>+  <span class="meta2">typename</span> <span class="meta">&rarr;</span> <span class="open">string not containing whitespace</span>+  <span class="meta2">decimalint</span> <span class="meta">&rarr;</span> <span class="open">digit string not beginning with zero</span>+  <span class="meta2">space</span> <span class="meta">&rarr;</span> <span class="open">space character ASCII 0x32</span>+</pre>++<p style="margin-top: 45px;">+And below is a simpler variant of the language that I'm in the process of changing over to, starting at the upcoming <tt>deepseq-bounded-0.6.0.0</tt>.+It has less verbose concrete syntax, so the pattern strings are more concise with higher information density.++<p>+The difference is mostly cosmetic, although the new grammar is slightly more expressive, permitting <span class="conc">=</span> on any pattern, not only the ones it would seem worthwhile to parallelise.++<p>+This could even be useful, since a single node might represent an expensive computation, so if we wanted to force this node, it might pay to parallelise the forcing.+And <span class="conc">=#</span> might make sense to measure parallelisation overhead.+Essentially, there's no use complicating the language by constraining it:+there are always possible uses just beyond the horizon of consideration.++<a id="new-grammar"></a>+<p style="margin-bottom: 30px;">+<pre>+  <b>Transitional Grammar</b> (unpublished deepseq-bounded version)<div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>  <span class="meta2">pat</span>          <span class="meta">&rarr;</span>  <span class="meta">[</span> <span class="meta2">modifiers</span> <span class="meta">]</span><span style="margin-left: 6px;">&nbsp;</span><span class="meta2">pat'</span><div style="margin: 0px; padding:0px; clear: both; height: 4px">&nbsp;</div>  <span class="meta2">pat'</span>         <span class="meta">&rarr;</span>  <span class="ametafaint">|</span>  <span class="conc">#</span> <span class="ameta"> | </span> <span class="conc" style="font-size: 120%;">.</span> <span class="ameta"> | </span> <span class="conc">*</span> <span class="meta">[</span> <span class="meta2">decimalint</span> <span class="meta">]</span> <span class="ameta"> | </span> <span class="conc">{</span> <span class="meta">{</span> <span class="meta2">pat</span> <span class="meta">}</span> <span class="conc">}</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">|</span>  <span class="conc">:</span> <span class="meta2">ctorname</span> <span class="meta">{</span> <span class="conc">:</span> <span class="meta2">ctorname</span> <span class="meta">}</span> <span class="conc">{</span> <span class="meta">{</span> <span class="meta2">pat</span> <span class="meta">}</span> <span class="conc">}</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">|</span>  <span class="meta">(</span> <span class="conc">#</span> <span class="ameta"> | </span> <span class="conc">*</span> <span class="meta">[</span> <span class="meta2">decimalint</span> <span class="meta">]</span> <span class="meta">)</span> <span class="conc">::</span> <span class="meta2">typename</span> <span class="meta">{</span> <span class="conc">:</span> <span class="meta2">typename</span> <span class="meta">}</span> <span class="conc">{}</span><div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>  <span class="meta2">ctorname</span>     <span class="meta">&rarr;</span>  <span class="meta2">typename</span>+  <span class="meta2">typename</span>     <span class="meta">&rarr;</span>  <span class="open">string containing neither</span> <span class="conc">:</span> <span class="open">(unless <span class="meta2">escaped</span><span class="open">), nor <span class="conc">{</span>+  <span class="meta2">escaped</span>      <span class="meta">&rarr;</span>  <span class="conc">\:</span>+  <span class="meta2">decimalint</span>   <span class="meta">&rarr;</span>  <span class="open">digit string not beginning with zero</span>+  <span class="meta2">modifiers</span>    <span class="meta">&rarr;</span>  <span class="open">zero or one of each of the seven</span> <span class="meta2">modifier</span><span class="open">, in any order</span>+  <span class="meta2">modifier</span>     <span class="meta">&rarr;</span>  <span class="ametafaint">|</span>  <span class="conc">=</span> <span class="ameta"> | </span> <span class="conc">+</span> <span class="ameta"> | </span> <span class="conc">^</span> <span class="ameta"> | </span> <span class="conc">/</span> <span class="ameta"> | </span> <span class="conc">%</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">| </span> <span class="conc">@</span> <span class="meta2">decimalint</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">| </span> <span class="conc">></span> <span class="meta2">permutation</span>+  <span class="meta2">permutation</span>  <span class="meta">&rarr;</span>  <span class="open">of an initial part of the lowercase alphabet, e.g.</span> <span class="conc">cdba</span>+</pre>+  <!--span class="meta2">escaped</span> <span class="meta">&rarr;</span> <span class="conc">\{</span> <span class="ameta">|</span> <span class="conc">\:</span-->++<p style="margin-top: 40px;">+It still requires some thought, whether <span class="conc">#</span> should be allowed a type constraint, and maybe a few other wee questions of that nature, before stabilising the language until at least <span class="nowrap">version 1.*.</span>+The language may <span class="nowrap">grow &mdash;</span> for example, we may add <tt>pseq</tt> node types as we did for <span class="nowrap"><tt>par</tt> &mdash;</span> but the core presented here should remain valid and effectual.++<p>+<a id="dig01s" class="dig-toggle-show" href='javascript:toggle("dig01");' style="margin-left: 0px;">Show</a>+<div id="dig01" class="digression" style="margin-left: 0px;">+<a id="dig01h" style="margin-bottom: -16px;" class="dig-toggle-show" href='javascript:toggle("dig01");'>Hide</a><p style="margin-bottom: -10px;">+<p>+<!--div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div-->+<div style="margin-bottom: 0px;">+Note that if allow merely <span class="conc">:</span> instead of <span class="conc">::</span> for the <span class="meta2b">typename</span>-constrained case, there are two possible parses of+<pre class="virgin">+   #:(Int,Bool){}+</pre>+namely, using the old syntax to resolve the ambiguity for sake of illustration:+<pre class="virgin">+   #.:(Int,Bool){}     -- two nodes, # and .+</pre>+versus+<pre class="virgin">+   #:(Int,Bool){}      -- one type-qualified # node+</pre>++We could also keep the <span class="conc">.</span>&nbsp;&nbsp;<em>just</em> in type-qualified <span class="nowrap">contexts <span class="conc">.:</span>,</span> but that would overload <span class="nowrap"><span class="conc">.</span> unpleasantly,</span> besides placing the burden of verbosity on the (perhaps) more common <span class="nowrap"><tt>TR</tt> nodes.</span>+</div>+</div>++<p>+So, we need an <span class="nowrap">extra <span class="conc">:</span></span> in one production alternative, and <span class="nowrap">shed <span class="conc">.</span></span> in another.+<span class="nowrap">But the</span> latter is the most frequent <span class="meta2b">pat</span> alternative <span class="nowrap">(<span class="conc">{</span> <span class="meta">{</span> <span class="meta2b">pat</span> <span class="meta">}</span> <span class="conc">}</span>)</span>, and with only two characters instead of the three <span class="nowrap">(<span class="conc">.{</span> <span class="meta">{</span> <span class="meta2b">pat</span> <span class="meta">}</span> <span class="conc">}</span>)</span> of the old grammar, the result is <a href="deepseq-bounded.html#newsyntax">noticeably trimmer</a> concrete syntax.++<p>+<a id="dig02s" class="dig-toggle-show" href='javascript:toggle("dig02");' style="margin-left: 0px;">Show</a>+<div id="dig02" class="digression" style="margin-left: 0px;">+<a id="dig02h" style="margin-bottom: -16px;" class="dig-toggle-show" href='javascript:toggle("dig02");'>Hide</a><p style="margin-bottom: -10px;">+<p>+It would be possible to keep single-colon type qualification designators in all cases, if we required * and # to be written *{} and #{}.+That is very tempting, except it feels harsh to give up the plain simplicity and symmetry of the bare symbols, and the {}'s are, after all, completely perfunctory and, far from conveying useful meaning, actually falsely suggest we are matching only unary nodes. (In the * case this is not logically a likely idea, but in the # case it can be.)+And you have to consider also, what part of the syntax are you making less elegant, in exchange for more elegant type constraint syntax?+Because I haven't seen a huge motivation to use type-constrained pattern nodes yet!...+<p>+Yet another, comparatively menial consideration which led to a last-minute concrete syntax change today:+(Re)using colon as type list separator (was whitespace before).+This is preferable to whitespace, for the simple reason that whitespace is more common in type rep strings ("Maybe Int", etc.) than is colon, so the more common symbol (whitespace) should be allowed un-escaped.+Colon is the most economical choice (even including whitespace!) since semantically, colon is already being used exclusively to signal the beginning of such a type list!+<p>+Note that, in any case (and this wasn't appreciated before), when you're parsing a type list for a constraint, the parsing context is specific to that, and you can treat things differently -- you're only waiting for the stop character (or separator, or escape). So in particular, whitespace could have reserved special meaning within type constraints, and yet be used freely (say for verical alignment of constant pattern strings for visual HCI convenience) to space the other characters in the pattern.+<p>+Yes, I'd like that about the whitespace in.+<p>+This does mean the [currently enabled!]&nbsp;&nbsp;'<tt> </tt>'-for-'#'&nbsp;&nbsp;thing must go...+(I do like it faded to light grey in the HTML docs though; keep that.)++</div>++<p style="margin-top: 16px;">+The next rendition changed some concrete lexemes, among other things:++<a id="new-grammar"></a>+<p style="margin-bottom: 30px;">+<pre>+  <b>Penultimate Grammar</b> (deepseq-bounded 0.6.0.0 candidate)<div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>  <span class="meta2">pat</span>          <span class="meta">&rarr;</span>  <span class="meta">[</span> <span class="meta2">modifiers</span> <span class="meta">]</span><span style="margin-left: 6px;">&nbsp;</span><span class="meta2">pat'</span><div style="margin: 0px; padding:0px; clear: both; height: 4px">&nbsp;</div>  <span class="meta2">pat'</span>         <span class="meta">&rarr;</span>  <span class="ametafaint">|</span>  <span class="conc">.</span> <span class="ameta"> | </span> <span class="conc" style="font-size: 120%;">!</span> <span class="ameta"> | </span> <span class="conc">*</span> <span class="meta">[</span> <span class="meta2">decimalint</span> <span class="meta">]</span> <span class="ameta"> | </span> <span class="conc2">(</span> <span class="meta">{</span> <span class="meta2">pat</span> <span class="meta">}</span> <span class="conc2">)</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">|</span>  <span class="conc">:</span> <span class="meta2">ctorname</span> <span class="meta">{</span> <span class="conc">;</span> <span class="meta2">ctorname</span> <span class="meta">}</span> <span class="conc">:</span> <span class="conc2">(</span> <span class="meta">{</span> <span class="meta2">pat</span> <span class="meta">}</span> <span class="conc2">)</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">|</span>  <span class="meta">(</span> <span class="conc">.</span> <span class="ameta"> | </span> <span class="conc">*</span> <span class="meta">[</span> <span class="meta2">decimalint</span> <span class="meta">]</span> <span class="meta">)</span> <span class="conc">::</span> <span class="meta2">typename</span> <span class="meta">{</span> <span class="conc">;</span> <span class="meta2">typename</span> <span class="meta">}</span> <span class="conc">:</span><div style="margin: 0px; padding:0px; clear: both; height: 8px">&nbsp;</div>  <span class="meta2">ctorname</span>     <span class="meta">&rarr;</span>  <span class="meta2">typename</span>+  <span class="meta2">typename</span>     <span class="meta">&rarr;</span>  <span class="open">string containing neither</span> <span class="conc">:</span> <span class="open">(unless <span class="meta2">escaped</span><span class="open">), nor <span class="conc">;</span>+  <span class="meta2">escaped</span>      <span class="meta">&rarr;</span>  <span class="conc">\:</span>+  <span class="meta2">decimalint</span>   <span class="meta">&rarr;</span>  <span class="open">digit string not beginning with zero</span>+  <span class="meta2">modifiers</span>    <span class="meta">&rarr;</span>  <span class="open">zero or one of each of the seven</span> <span class="meta2">modifier</span><span class="open">, in any order</span>+  <span class="meta2">modifier</span>     <span class="meta">&rarr;</span>  <span class="ametafaint">|</span>  <span class="conc">=</span> <span class="ameta"> | </span> <span class="conc">+</span> <span class="ameta"> | </span> <span class="conc">^</span> <span class="ameta"> | </span> <span class="conc">/</span> <span class="ameta"> | </span> <span class="conc">%</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">| </span> <span class="conc">@</span> <span class="meta2">decimalint</span>+                 <span class="meta" style="color: transparent;">&rarr;</span><span class="ameta">| </span> <span class="conc">></span> <span class="meta2">permutation</span>+  <span class="meta2">permutation</span>  <span class="meta">&rarr;</span>  <span class="open">of an initial part of the lowercase alphabet, e.g.</span> <span class="conc">cdba</span>+</pre>++<p>+And the much trimmer final grammar you find at the top of the page was the result of making type-constraint just another prefix modifier.++<div class="footer" style="margin-top: 30px;">+Andrew Seniuk+<br>+Dec. 2014 / Jan. 2015+<br>+<tt>rasfar@gmail.com</tt>+</div>++</div>++<script language="javascript">+function toggle(id1){+  var ele_s = document.getElementById(id1+"s");+  var ele_h = document.getElementById(id1+"h");+  var ele = document.getElementById(id1);+  if( ele.style.display == "inline-block" ){+    ele.style.display = "none";+    ele_s.style.display = "inline-block";+    ele_h.style.display = "none";+  }else{+    ele.style.display = "inline-block";+    ele_s.style.display = "none";+    ele_h.style.display = "block";+  }+}+</script>++</body>+</html>+
HTML/index.html view
@@ -1,4 +1,4 @@-<!DOCTYPE html>+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd"> <html> <head> <title>Bounded DeepSeq</title>
− HTML/style-old.css 
@@ -1,26 +0,0 @@-pre { font-size: 12pt; margin-left: 20px; padding-left: 10px; padding-right: 10px; padding-top: 10px; padding-bottom: 10px; background-color: #DDD; }-tt { padding-left: 2px; padding-right: 2px; font-size: 85%; background-color: rgba(220,220,220,0.5); }-tt.virgin { padding-left: 0px; padding-right: 0px; font-size: 85%; background-color: transparent; }-/* Works, but not nicely:-red { color: #f00; }-*/-.red { color: #f00; }-div.outdated { display: inline-block; padding-left: 2px; padding-right: 2px; padding-top: 2px; font-size: 11pt; background-color: #EEC; }-div.digression { display: inline-block; padding: 8px 8px 8px 8px; font-size: 11pt; background-color: #EDD; }-a { text-decoration: none; }-div.main { font-size: 18pt; margin-left: 10px; margin-right: 100px; margin-bottom: 40px; }-h2 { margin-top: 30px; color: #444; }-h3 { margin-top: 30px; color: #222; }-h4 { margin-top: 40px; color: #111; }-div.footer { font-family: sans; font-size: 70%; margin-top: 40px; }-div.footer > tt { font-size: 90%; }-/*-table.table { text-align: top; vertical-align: top; }-table.table > tr { text-align: top; vertical-align: top; }-table.table > tr > td { text-align: top; vertical-align: top; }-*/-/* table { border-collapse: collapse; } */-tr { text-align: top; vertical-align: top; }-td { text-align: top; vertical-align: top; padding-left: 8px; padding-top: 16px; }-li { margin-top: 4px; }-.nowrap { white-space: nowrap; }
HTML/style.css view
@@ -1,6 +1,10 @@-pre { font-size: 12pt; margin-left: 20px; padding-left: 10px; padding-right: 10px; padding-top: 10px; padding-bottom: 10px; background-color: #DDD; }++pre { font-size: 12pt; margin-left: 20px; padding-left: 10px; padding-right: 10px; padding-top: 10px; padding-bottom: 10px; background-color: rgba(230,230,230,1.0); }+pre.virgin { padding-left: 0px; padding-right: 0px; font-size: 85%; background-color: transparent; margin-top: 0px; margin-bottom: 0px; } tt { padding-left: 2px; padding-right: 2px; font-size: 85%; background-color: rgba(220,220,220,0.5); } tt.virgin { padding-left: 0px; padding-right: 0px; font-size: 85%; background-color: transparent; }+div.digression > tt { padding-left: 0px; padding-right: 0px; font-size: 85%; background-color: transparent; }+div.digression > p > tt { padding-left: 0px; padding-right: 0px; font-size: 85%; background-color: transparent; } /* Works, but not nicely: red { color: #f00; } */@@ -15,6 +19,11 @@ h2 { margin-top: 30px; color: #777; } h3 { margin-top: 30px; color: #444; } h4 { margin-top: 40px; color: #222; }+a:visited { color: #7700BB; } /* visited link */+a:hover { color: #BB00BB; } /* mouse over link */+a:active { color: #7700BB; } /* selected link */+a.comments:link { color: #0000BB; } /* unvisited link */+div.comments { cursor: hand; text-align: center; display: inline-block; padding-left: 12px; padding-right: 12px; padding-top: 8px; padding-bottom: 0px; background-color: #CDE; cursor: pointer; font-family: sans; font-size: 90%; margin-top: 30px; margin-left: 10px; } div.footer { font-family: sans; font-size: 70%; margin-top: 40px; } div.footer > tt { font-size: 90%; } /*@@ -27,3 +36,35 @@ td { text-align: top; vertical-align: top; padding-left: 8px; padding-top: 16px; } li { margin-top: 4px; } .nowrap { white-space: nowrap; }+.cmnt { color: #888; }+.dcmnt { color: #555; }+hr.hrule {+/* Thanks to http://css-tricks.com/examples/hrs/ */+  border: 0;+  height: 1px;+  background: #333;+  background-image: -webkit-linear-gradient(left, #ccc, #333, #ccc); +  background-image:    -moz-linear-gradient(left, #ccc, #333, #ccc); +  background-image:     -ms-linear-gradient(left, #ccc, #333, #ccc); +  background-image:      -o-linear-gradient(left, #ccc, #333, #ccc); +  margin: 50px 0 5px 0;+}+/* Thanks to SO answer of daGUY in http://stackoverflow.com/questions/2539207/ho+w-to-change-the-strike-out-line-through-thickness-in-css */+.strikeout {+    position: relative;+    padding-left: 3pt;+    padding-right: 3pt;+}+.strikeout::after {+    border-bottom: 2px solid #C33;+    content: "";+    left: 0;+    position: absolute;+    right: 0;+    top: 50%;+}+.grey { color: #BBB; letter-spacing: -4px; }++tt { background: transparent; }+
HTML/tests.html view
@@ -1,1649 +1,1873 @@-<html>-<head>-<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate" />-<meta http-equiv="Pragma" content="no-cache" />-<meta http-equiv="Expires" content="0" />-</head>-<body>-<pre>-kadath:script&gt; cabal repl-Preprocessing library deepseq-bounded-0.5.0...-In-place registering deepseq-bounded-0.5.0...-Preprocessing test suite 'deepseq-bounded-tests' for deepseq-bounded-0.5.0...-GHCi, version 7.8.3: http://www.haskell.org/ghc/  :? for help-Loading package ghc-prim ... linking ... done.-Loading package integer-gmp ... linking ... done.- ...-Ok, modules loaded: Main, Tests, Blah, Bottom, Foo, FooG.-*Main&gt; main-Running tests for deepseq-bounded...-Cases: 1  Tried: 0  Errors: 0  Failures: 0--Testing.--Pattern                       Compiles to-*                             Node WW []-#                             Node WI []-.                             Node WS []-.{}                           Node WR []-.{*}                          Node WR [Node WW []]-.{**}                         Node WR [Node WW [],Node WW []]-.{.*}                         Node WR [Node WS [],Node WW []]-.{#.}                         Node WR [Node WI [],Node WS []]-compilePat-"{": warning: # with subpattern-.{#{#}}                       Node WR [Node WI []]-.{.{#}}                       Node WR [Node WR [Node WI []]]-.{*#*#*#**#*#*}               Node WR [Node WW [],Node WI [],Node WW [],Node WI [],Node WW [],Node WI [],Node WW [],Node WW [],Node WI [],Node WW [],Node WI [],Node WW []]-compilePat-"{": warning: * with subpattern-.{*#.{*#.{*#}*}*{#*}#*}       Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI []],Node WW []],Node WW [],Node WI [],Node WW []]-.{*#.{*#.{*#}*}*#*}           Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI []],Node WW []],Node WW [],Node WI [],Node WW []]-.{.*.{*23*}}                  Node WR [Node WS [],Node WW [],Node WR [Node (WN 23) [],Node WW []]]-.{.=*.{=*23*}}                Node WR [Node WS [],Node PW [],Node WR [Node (PN 23) [],Node WW []]]-===================================================-exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-get (_,xs,_) = show $ (xs!!2)-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .##-showPat.compilePat       = compilePat: disconnected pattern (not rooted)-Perhaps you used parentheses instead of braces?-----------------------------------------------------patstr                   = .{.##}-showPat.compilePat       = .{.##}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{.{}#{}#{}}-expected value           = 7 (but "# with subpattern" warning)-showPat.compilePat       = .{.{}##}-actual value             = 7-----------------------------------------------------patstr                   = *-showPat.compilePat       = *-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{***}-showPat.compilePat       = .{***}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{###}-showPat.compilePat       = .{###}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{*##}-showPat.compilePat       = .{*##}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{**#}-showPat.compilePat       = .{**#}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{##*}-showPat.compilePat       = .{##*}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{..{*#*}#}-expected value           = 7 (but with pattern-match failure warning)-showPat.compilePat       = .{..{*#*}#}-actual value             = 7-----------------------------------------------------patstr                   = .{..{*###}#}-expected value           = 7 (but with pattern-match failure warning)-showPat.compilePat       = .{..{*###}#}-actual value             = 7-----------------------------------------------------patstr                   = .{..{*####}#}-expected value           = 7 (but with pattern-match failure warning)-showPat.compilePat       = .{..{*####}#}-actual value             = 7-----------------------------------------------------patstr                   = .{..{*####}.}-expected value           = Prelude.undefined (but with pattern-match failure warning)-showPat.compilePat       = .{..{*####}.}-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{..{*#}*}-showPat.compilePat       = .{..{*#}*}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{..{*#}#}-showPat.compilePat       = .{..{*#}#}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{..{*.{#*}}#}-showPat.compilePat       = .{..{*.{#*}}#}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{..{*.{*#}}#}-showPat.compilePat       = .{..{*.{*#}}#}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{..{.{..{#*}}}#}-expected value           = 7 (but with pattern-match failure warning)-showPat.compilePat       = .{..{.{..{#*}}}#}-actual value             = 7-----------------------------------------------------patstr                   = .{#.{..{..{#*}}}#}-showPat.compilePat       = .{#.{..{..{#*}}}#}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{..{..{#.{..}}}#}-showPat.compilePat       = .{..{..{#.{..}}}#}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{..{..{#*}}#}-showPat.compilePat       = .{..{..{#*}}#}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{*.{*.{#*}}#}-showPat.compilePat       = .{*.{*.{#*}}#}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{##*}-showPat.compilePat       = .{##*}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{*#*}-showPat.compilePat       = .{*#*}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .:Tuple3{*.{*.{#*}}#}-showPat.compilePat       = .:Tuple3{*.{*.{#*}}#}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .:(,,){*.{*.{#*}}#}-showPat.compilePat       = .:(,,){*.{*.{#*}}#}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .:(,,){*.{*.{.*}}#}-showPat.compilePat       = .:(,,){*.{*.{.*}}#}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .:Bool{***}-showPat.compilePat       = .:Bool{***}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = *:Bool-showPat.compilePat       = *:Bool-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = *:(,,)-showPat.compilePat       = *:(,,)-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{*#.}-showPat.compilePat       = .{*#.}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{*#.:Bool}-showPat.compilePat       = .{*#.:Bool{}}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{*#.:Bool{}}-showPat.compilePat       = .{*#.:Bool{}}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{*#.:Int{}}-showPat.compilePat       = .{*#.:Int{}}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{*#.:(,){}}-showPat.compilePat       = .{*#.:(,){}}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{*#.:Int }-showPat.compilePat       = .{*#.:Int{}}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{*#.:Int'}-showPat.compilePat       = .{*#.:Int'{}}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{*##:Bool}-showPat.compilePat       = .{*##:Bool}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{*##:Int}-showPat.compilePat       = .{*##:Int}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{*##:(,)}-showPat.compilePat       = .{*##:(,)}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{*##:Bool{}}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-.{*##:Bool}-expected value           = 7-compilePat-"{": warning: # with subpattern-actual value             = 7-----------------------------------------------------patstr                   = .{*##:Int{}}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-.{*##:Int}-expected value           = Prelude.undefined-compilePat-"{": warning: # with subpattern-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{*##:(,){}}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-.{*##:(,)}-expected value           = Prelude.undefined-compilePat-"{": warning: # with subpattern-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{**2#}-showPat.compilePat       = .{**2#}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{**3#}-showPat.compilePat       = .{**3#}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{*#:G2{}#}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-.{*#:G2#}-expected value           = 7-compilePat-"{": warning: # with subpattern-actual value             = 7-----------------------------------------------------patstr                   = .{*#:Int{}#}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-.{*#:Int#}-expected value           = 7-compilePat-"{": warning: # with subpattern-actual value             = 7----------------------------------------------------===================================================-exp = (G1, G2 5 __ 7, __) :: (TG, TG, Bool)-get (_,(G2 _ _ n),_) = n-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .{*#:G2{}#}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-.{*#:G2#}-expected value           = 7-compilePat-"{": warning: # with subpattern-actual value             = 7-----------------------------------------------------patstr                   = .{*#:Int{}#}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-.{*#:Int#}-expected value           = 7-compilePat-"{": warning: # with subpattern-actual value             = 7----------------------------------------------------===================================================-exp = G2 5 __ 7 :: TG-get (G2 _ _ n) = n-? = get $ forcep patstr exp-===================================================-patstr                   = ..-showPat.compilePat       = compilePat: disconnected pattern (not rooted)-Perhaps you used parentheses instead of braces?-----------------------------------------------------patstr                   = *-showPat.compilePat       = *-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = *0-showPat.compilePat       = *0-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = *1-showPat.compilePat       = *1-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = *2-showPat.compilePat       = *2-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = *3-showPat.compilePat       = *3-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{.#.}-showPat.compilePat       = .{.#.}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .{...}-showPat.compilePat       = .{...}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = *:TG-showPat.compilePat       = *:TG-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = *:G1-showPat.compilePat       = *:G1-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = *:G2-showPat.compilePat       = *:G2-expected value           = Prelude.undefined-actual value             = 7-----------------------------------------------------patstr                   = *:G1{..}-showPat.compilePat       = compilePat-"{": warning: * with subpattern-*:G1-expected value           = 7-compilePat-"{": warning: * with subpattern-actual value             = 7-----------------------------------------------------patstr                   = *:G1{...}-showPat.compilePat       = compilePat-"{": warning: * with subpattern-*:G1-expected value           = 7-compilePat-"{": warning: * with subpattern-actual value             = 7-----------------------------------------------------patstr                   = *:G2{..}-showPat.compilePat       = compilePat-"{": warning: * with subpattern-*:G2-expected value           = Prelude.undefined-compilePat-"{": warning: * with subpattern-actual value             = 7-----------------------------------------------------patstr                   = *:G2{...}-showPat.compilePat       = compilePat-"{": warning: * with subpattern-*:G2-expected value           = Prelude.undefined-compilePat-"{": warning: * with subpattern-actual value             = 7-----------------------------------------------------patstr                   = #:G1-showPat.compilePat       = #:G1-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = #:G2-showPat.compilePat       = #:G2-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = #:G1{..}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-#:G1-expected value           = 7-compilePat-"{": warning: # with subpattern-actual value             = 7-----------------------------------------------------patstr                   = #:G1{...}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-#:G1-expected value           = 7-compilePat-"{": warning: # with subpattern-actual value             = 7-----------------------------------------------------patstr                   = #:G2{..}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-#:G2-expected value           = 7-compilePat-"{": warning: # with subpattern-actual value             = 7-----------------------------------------------------patstr                   = #:G2{...}-showPat.compilePat       = compilePat-"{": warning: # with subpattern-#:G2-expected value           = 7-compilePat-"{": warning: # with subpattern-actual value             = 7-----------------------------------------------------patstr                   = .:G1{..}-showPat.compilePat       = .:G1{..}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .:G1{...}-showPat.compilePat       = .:G1{...}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .:G2{..}-showPat.compilePat       = .:G2{..}-expected value           = 7-actual value             = 7-----------------------------------------------------patstr                   = .:G2{...}-showPat.compilePat       = .:G2{...}-expected value           = Prelude.undefined-actual value             = Prelude.undefined----------------------------------------------------===================================================-exp = J2 (1, J4 (J3, K3 __ (J1 4.5))) False-get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .{.{..{.{..{..{.}}}}}.}-showPat.compilePat       = .{.{..{.{..{..{.}}}}}.}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{.{..{.{#.{..{.}}}}}#}-showPat.compilePat       = .{.{..{.{#.{..{.}}}}}#}-expected value           = 4.5-actual value             = 4.5----------------------------------------------------===================================================-exp = J2 (1, J4 (__, K2)) False-get ~_ = show 1  -- seems to suffice?!?...-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .{.{..{.{..}}}.}-showPat.compilePat       = .{.{..{.{..}}}.}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{.{..{.{#.}}}.}-showPat.compilePat       = .{.{..{.{#.}}}.}-expected value           = 1-actual value             = 1-----------------------------------------------------patstr                   = .{.{..{#{..}}}.}-showPat.compilePat       = .{.{..{#}}.}-expected value           = 1-actual value             = 1-----------------------------------------------------patstr                   = .{.{.#{.{..}}}.}-showPat.compilePat       = .{.{.#}.}-expected value           = 1-actual value             = 1----------------------------------------------------===================================================-exp = J4 (__, K2)-get ~_ = show 1  -- seems to suffice?!?...-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .{.{..}}-showPat.compilePat       = .{.{..}}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{.{#.}}-showPat.compilePat       = .{.{#.}}-expected value           = 1-actual value             = 1-----------------------------------------------------patstr                   = .{#{..}}-showPat.compilePat       = .{#}-expected value           = 1-actual value             = 1-----------------------------------------------------patstr                   = #{.{..}}-showPat.compilePat       = #-expected value           = 1-actual value             = 1----------------------------------------------------===================================================-exp = (__, K2)-get ~_ = show 1  -- seems to suffice?!?...-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .{..}-showPat.compilePat       = .{..}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{#.}-showPat.compilePat       = .{#.}-expected value           = 1-actual value             = 1-----------------------------------------------------patstr                   = #{..}-showPat.compilePat       = #-expected value           = 1-actual value             = 1----------------------------------------------------===================================================-exp = __ :: TJ-get ~_ = show 1  -- seems to suffice?!?...-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .-showPat.compilePat       = .-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = #-showPat.compilePat       = #-expected value           = 1-actual value             = Prelude.undefined----------------------------------------------------===================================================-exp = (K5 (__::TJ))-get ~_ = show 1  -- seems to suffice?!?...-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .-showPat.compilePat       = .-expected value           = okay-actual value             = okay-----------------------------------------------------patstr                   = .{#}-showPat.compilePat       = .{#}-expected value           = okay-actual value             = okay-----------------------------------------------------patstr                   = .{.}-showPat.compilePat       = .{.}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = #-showPat.compilePat       = #-expected value           = okay-actual value             = okay----------------------------------------------------===================================================-exp = K3 (__::TK) J3-get ~_ = show 1  -- seems to suffice?!?...-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .-showPat.compilePat       = .-expected value           = okay-actual value             = okay-----------------------------------------------------patstr                   = .{#.}-showPat.compilePat       = .{#.}-expected value           = okay-actual value             = okay-----------------------------------------------------patstr                   = .{.#}-showPat.compilePat       = .{.#}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{..}-showPat.compilePat       = .{..}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = #-showPat.compilePat       = #-expected value           = okay-actual value             = okay----------------------------------------------------===================================================-exp = L1 5.6 (M1 __)-get (L1 f (M1 _)) = show f-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = #-showPat.compilePat       = #-expected value           = 5.6-actual value             = 5.6-----------------------------------------------------patstr                   = #{..}-expected value           = 5.6 (but "# with subpattern" warning)-showPat.compilePat       = #-actual value             = 5.6-----------------------------------------------------patstr                   = .{..}-showPat.compilePat       = .{..}-expected value           = 5.6-actual value             = 5.6-----------------------------------------------------patstr                   = .{.{.}.}-showPat.compilePat       = .{.{.}.}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{.{#}.}-showPat.compilePat       = .{.{#}.}-expected value           = 5.6-actual value             = 5.6----------------------------------------------------===================================================-exp = K3 __ (J1 4.5)-get = (K3 _ (J1 f)) = show f-? = get $ forcep patstr exp-===================================================-patstr                   = -showPat.compilePat       = compilePat: empty pattern (syntax error)-----------------------------------------------------patstr                   = .{..{.}}-showPat.compilePat       = .{..{.}}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{##}-showPat.compilePat       = .{##}-expected value           = 4.5-actual value             = 4.5-----------------------------------------------------patstr                   = .{#.}-showPat.compilePat       = .{#.}-expected value           = 4.5-actual value             = 4.5-----------------------------------------------------patstr                   = .{#.{#}}-showPat.compilePat       = .{#.{#}}-expected value           = 4.5-actual value             = 4.5-----------------------------------------------------patstr                   = .{#.{.}}-showPat.compilePat       = .{#.{.}}-expected value           = 4.5-actual value             = 4.5-----------------------------------------------------patstr                   = .{.#{.}}-showPat.compilePat       = .{.#}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{.#{#}}-showPat.compilePat       = .{.#}-expected value           = Prelude.undefined-actual value             = Prelude.undefined-----------------------------------------------------patstr                   = .{##{#}}-showPat.compilePat       = .{##}-expected value           = 4.5-actual value             = 4.5-----------------------------------------------------patstr                   = #{##{#}}-showPat.compilePat       = #-expected value           = 4.5-actual value             = 4.5----------------------------------------------------===================================================-exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-get (_,xs,_) = show $ (xs!!2)-? = get $ ( forcep patstr2 . forcep patstr1 ) exp-? = get $! ( forcep_ ( unionPats [ pat1, pat2 ] ) ) exp-(Results were more interesting with a previous semantics...).-===================================================-patstr1                     = .-patstr2                     = .-patstrU                     = .-showPat.compilePat patstr1  = .-showPat.compilePat patstr2  = .-showPat.compilePat patstrU  = .-expected value              = 7-actual value                = 7-actual value                = 7-----------------------------------------------------patstr1                     = .-patstr2                     = *-patstrU                     = *-showPat.compilePat patstr1  = .-showPat.compilePat patstr2  = *-showPat.compilePat patstrU  = *-expected value              = Prelude.undefined-actual value                = Prelude.undefined-----------------------------------------------------patstr1                     = *-patstr2                     = .-patstrU                     = *-showPat.compilePat patstr1  = *-showPat.compilePat patstr2  = .-showPat.compilePat patstrU  = *-expected value              = Prelude.undefined-actual value                = Prelude.undefined-----------------------------------------------------patstr1                     = *-patstr2                     = *-patstrU                     = *-showPat.compilePat patstr1  = *-showPat.compilePat patstr2  = *-showPat.compilePat patstrU  = *-expected value              = Prelude.undefined-actual value                = Prelude.undefined-----------------------------------------------------patstr1                     = .{...}-patstr2                     = .{*..}-patstrU                     = .{*..}-showPat.compilePat patstr1  = .{...}-showPat.compilePat patstr2  = .{*..}-showPat.compilePat patstrU  = .{*..}-expected value              = Prelude.undefined-actual value                = Prelude.undefined-----------------------------------------------------patstr1                     = .{*..}-patstr2                     = .{..*}-patstrU                     = .{*.*}-showPat.compilePat patstr1  = .{*..}-showPat.compilePat patstr2  = .{..*}-showPat.compilePat patstrU  = .{*.*}-expected value              = Prelude.undefined-actual value                = Prelude.undefined-----------------------------------------------------patstr1                     = .{.*#}-patstr2                     = .{.#.}-patstrU                     = .{.*.}-showPat.compilePat patstr1  = .{.*#}-showPat.compilePat patstr2  = .{.#.}-showPat.compilePat patstrU  = .{.*.}-expected value              = Prelude.undefined-actual value                = Prelude.undefined----------------------------------------------------===================================================-Testing splicePats.-----------------------------------------------------target       .-path         []-isibs        [(0,"*")]-result       .{*}-----------------------------------------------------target       .{}-path         []-isibs        [(0,"*")]-result       .{*}-----------------------------------------------------target       .-path         [0]-isibs        [(0,"*")]-result       splicePats: path escapes target (depth)-----------------------------------------------------target       .{..}-path         []-isibs        [(0,"*")]-result       .{*..}-----------------------------------------------------target       .{..}-path         [0]-isibs        [(0,"*")]-result       .{.{*}.}-----------------------------------------------------target       .{..}-path         [2]-isibs        [(0,"*")]-result       splicePats: path escapes target (breadth)-----------------------------------------------------target       .{..}-path         []-isibs        [(0,"*"),(0,"#")]-result       .{*#..}-----------------------------------------------------target       .{..}-path         []-isibs        [(0,"*"),(1,"#")]-result       .{*.#.}-----------------------------------------------------target       .{..}-path         []-isibs        [(1,"#"),(0,"*")]-result       .{*.#.}-----------------------------------------------------target       .{..}-path         []-isibs        [(0,"*"),(2,"#")]-result       .{*..#}-----------------------------------------------------target       .{..}-path         []-isibs        [(2,"*"),(2,"#"),(2,"#")]-result       .{..*##}-----------------------------------------------------target       .{..}-path         []-isibs        [(-1,"*")]-result       .{..*}-----------------------------------------------------target       .{..}-path         []-isibs        [(0,"*")]-result       .{*..}-----------------------------------------------------target       .{..}-path         []-isibs        [(1,"*")]-result       .{.*.}-----------------------------------------------------target       .{..}-path         []-isibs        [(2,"*")]-result       .{..*}-----------------------------------------------------target       .{..}-path         []-isibs        [(3,"*")]-result       splicePats: sibling indices must not exceed the number of existing children-----------------------------------------------------target       .{..{..}.}-path         [1]-isibs        [(0,"*")]-result       .{..{*..}.}-----------------------------------------------------target       .{..{..}.}-path         [1]-isibs        [(0,"*3"),(1,"#"),(2,"*")]-result       .{..{*3.#.*}.}-----------------------------------------------------target       .{..{..}.}-path         [1,0]-isibs        [(0,"*"),(0,"#")]-result       .{..{.{*#}.}.}-----------------------------------------------------target       .{.{...}.{.{}.}.}-path         [1]-isibs        [(0,"*"),(0,"#")]-result       .{.{...}.{*#.{}.}.}-----------------------------------------------------target       .{.{...}.{.{}.}.}-path         [1,0]-isibs        [(0,"*"),(0,"#")]-result       .{.{...}.{.{*#}.}.}-----------------------------------------------------target       .{.{###}.{.{}#}#}-path         [1,0]-isibs        [(0,"*"),(0,"#")]-result       .{.{###}.{.{*#}#}#}-----------------------------------------------------target       .{.:(,,){###}.{.{}#}#}-path         [1,0]-isibs        [(0,"*"),(0,"#")]-result       .{.:(,,){###}.{.{*#}#}#}-===================================================-Testing elidePats.-----------------------------------------------------target       .{.{..}..{.}}-path         []-isibs        [0]-result       .{..{.}}-----------------------------------------------------target       .{.{..}..{.}}-path         [0]-isibs        [0]-result       .{.{.}..{.}}-----------------------------------------------------target       .{.{..}..{.}}-path         [1]-isibs        [0]-result       elidePats: (2) path escapes target: [0]-----------------------------------------------------target       .{.{..}..{.}}-path         [1]-isibs        [1]-result       elidePats: sibling indices must not exceed the number of existing children-===================================================-Testing erodePat.-----------------------------------------------------target       .{.{..}..{.}}-stdgen       1355035016 2147483398-path         []-result       .{.{.#}..{.}}-----------------------------------------------------target       .{.{..}..{.}}-stdgen       164232961 367188984-path         []-result       .{.{.#}..{.}}-----------------------------------------------------target       .{.{..}..{.}}-stdgen       23844443 223185073-path         []-result       .{.{..}..{#}}-----------------------------------------------------target       .{.{..}..{.}}-stdgen       1900020236 1632766708-path         []-result       .{.{..}..{#}}-----------------------------------------------------target       .{.{..}..{.}}-stdgen       1186277707 709377745-path         []-result       .{.{..}#.{.}}-----------------------------------------------------===================================================-Testing miscellaneous PatAlg functions...-----------------------------------------------------unionPats test already done test13-1!-----------------------------------------------------Testing      intersectPats [patA, patB]-patA         .{...}-patB         .{.#}-result       intersection: node arity disparity!-.{#.}-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .-patB         .-as expected  True-----------------------------------------------------Testing      isSubPatOf patA patB-patA         #-patB         #-as expected  True-----------------------------------------------------Testing      isSubPatOf patA patB-patA         *-patB         *-as expected  True-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .-patB         .{}-as expected  True-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .{}-patB         .-as expected  False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .{}-patB         .{.}-intersection: node arity disparity!-as expected  False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .{.}-patB         .{.}-as expected  True-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .{.}-patB         .{..}-intersection: node arity disparity!-as expected  False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .{.}-patB         .{.{.}}-expect       True-result       False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .{..}-patB         .{.#}-as expected  False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .{.#}-patB         .{..}-expect       True-result       False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .{..}-patB         .{...}-intersection: node arity disparity!-as expected  False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .{}-patB         .{...}-intersection: node arity disparity!-as expected  False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         .-patB         .{*.#}-as expected  True-----------------------------------------------------Testing      isSubPatOf patA patB-patA         #-patB         .{*.#}-as expected  True-----------------------------------------------------Testing      isSubPatOf patA patB-patA         *-patB         .{*.#}-as expected  False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         *-patB         .{*}-as expected  False-----------------------------------------------------Testing      isSubPatOf patA patB-patA         *-patB         .{**}-as expected  False-doit13: unexpected code 4-----------------------------------------------------Testing      emptyPat-result       #-----------------------------------------------------Testing      mkPat ([1,2,3],(False,"foo"))-result       .{.{..{..{..}}}.{..{..{..{..}}}}}-----------------------------------------------------Testing      growPat patA ([1,2,3],(False,"foo"))-patA         .{.{..{..}}.{..{..}}}-result       .{.{..{..{..}}}.{..{..{..}}}}-----------------------------------------------------Testing      growPat patA ([1,2,3],(False,"foo"))-patA         .{.{..{..{..}}}.{..{..{..}}}}-result       .{.{..{..{..}}}.{..{..{..{..}}}}}-----------------------------------------------------Testing      growPat patA ([1,2,3],(False,"foo"))-patA         .{.{..{..{..}}}.{..{..{..{..}}}}}-result       .{.{..{..{..}}}.{..{..{..{..}}}}}-----------------------------------------------------Testing      shrinkPat patA-patA         .{.{..{..{..}}}.{..{..{..{..}}}}}-result       .{.{#.{#.{##}}}.{#.{#.{#.{##}}}}}-----------------------------------------------------Testing      shrinkPat patA-patA         .{.{..{..{..}}}.{..{..{..}}}}-result       .{.{#.{#.{##}}}.{#.{#.{##}}}}-----------------------------------------------------Testing      shrinkPat patA-patA         .{.{..{..}}.{..{..}}}-result       .{.{#.{##}}.{#.{##}}}-----------------------------------------------------Testing      shrinkPat patA-patA         .{.{#.{..}}.{#.{*3.}}}-result       .{.{#.{##}}.{#.{*2#}}}-----------------------------------------------------Testing      shrinkPat patA-patA         .{.{#.}.{#.}}-result       .{.{##}.{##}}-----------------------------------------------------Testing      shrinkPat patA-patA         .{..}-result       .{##}-----------------------------------------------------Testing      shrinkPat patA-patA         .-result       #-----------------------------------------------------Testing      liftPats patstrlst-patstrs      [".{...}",".{.#}"]-result       .{.{...}.{.#}}-----------------------------------------------------splicePats test already done test13-10!-----------------------------------------------------isPath test already done test13-11!-----------------------------------------------------Testing      mkPatN 2 ([1,2,3],(False,"foo"))-result       .{.{..{}}.{..{}}}------------------------------------------------------Testing fusion--fenable-rewrite-rules -O -ddump-rules -ddump-simpl-stats -ddump-rule-firings--7-7-7-7--  expN_1 = [__] :: [Int]-  expN_2 = [0,1,__,3] :: [Int]-  expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)-  expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)--  getN_1 xs = show $ ()---getN_1 xs = show $ head xs---getN_2 xs = show $ (xs!!1)-  getN_2 xs = show $ (xs!!3)-  getN_3 (_,xs,_) = show $ (xs!!2)--forcen 0 expN_1 `seq` ()  =  ()-forcen 1 expN_1 `seq` ()  =  ()-forcen 2 expN_1 `seq` ()  =  Prelude.undefined-forcen 3 expN_1 `seq` ()  =  Prelude.undefined-forcen 4 expN_1 `seq` ()  =  Prelude.undefined--getN_2 $ forcen 0 expN_2  =  3-getN_2 $ forcen 1 expN_2  =  3-getN_2 $ forcen 2 expN_2  =  3-getN_2 $ forcen 3 expN_2  =  3-getN_2 $ forcen 4 expN_2  =  Prelude.undefined--getN_3 $ forcen 0 expN_3  =  7-getN_3 $ forcen 1 expN_3  =  7-getN_3 $ forcen 2 expN_3  =  7-getN_3 $ forcen 3 expN_3  =  7-getN_3 $ forcen 4 expN_3  =  Prelude.undefined--getN_3 $ forcen 0 expN_4  =  7-getN_3 $ forcen 1 expN_4  =  7-getN_3 $ forcen 2 expN_4  =  Prelude.undefined-getN_3 $ forcen 3 expN_4  =  Prelude.undefined-getN_3 $ forcen 4 expN_4  =  Prelude.undefined--===================================================-Testing generic GNFDataN (refer to Foo.hs for the defs).------------------------------------------------------( getB_1 $ forcen 0  expTB_1 )  True-( getB_1 $ forcen 1  expTB_1 )  True-( getB_1 $ forcen 2  expTB_1 )  True-( getB_1 $ forcen 3  expTB_1 )  True-( getB_1 $ forcen 4  expTB_1 )  True-( getB_1 $ forcen 5  expTB_1 )  True-( getB_1 $ forcen 6  expTB_1 )  True-( getB_1 $ forcen 7  expTB_1 )  True-( getB_1 $ forcen 8  expTB_1 )  True-( getB_1 $ forcen 9  expTB_1 )  True-( getB_1 $ forcen 10 expTB_1 )  True-( getB_1 $ forcen 0  expTB_2 )  True-( getB_1 $ forcen 1  expTB_2 )  True-( getB_1 $ forcen 2  expTB_2 )  True-( getB_1 $ forcen 3  expTB_2 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_2 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_2 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_2 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_2 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_2 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_2 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_2 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 1  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 2  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 3  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_3 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_3 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 1  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 2  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 3  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_4 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_4 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_5 )  True-( getB_1 $ forcen 1  expTB_5 )  True-( getB_1 $ forcen 2  expTB_5 )  True-( getB_1 $ forcen 3  expTB_5 )  True-( getB_1 $ forcen 4  expTB_5 )  True-( getB_1 $ forcen 5  expTB_5 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_5 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_5 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_5 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_5 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_5 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_6 )  True-( getB_1 $ forcen 1  expTB_6 )  True-( getB_1 $ forcen 2  expTB_6 )  True-( getB_1 $ forcen 3  expTB_6 )  True-( getB_1 $ forcen 4  expTB_6 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_6 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_6 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_6 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_6 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_6 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_6 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 1  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 2  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 3  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_7 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_7 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_8 )  True-( getB_1 $ forcen 1  expTB_8 )  True-( getB_1 $ forcen 2  expTB_8 )  True-( getB_1 $ forcen 3  expTB_8 )  True-( getB_1 $ forcen 4  expTB_8 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_8 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_8 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_8 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_8 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_8 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_8 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_9 )  True-( getB_1 $ forcen 1  expTB_9 )  True-( getB_1 $ forcen 2  expTB_9 )  True-( getB_1 $ forcen 3  expTB_9 )  True-( getB_1 $ forcen 4  expTB_9 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_9 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_9 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_9 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_9 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_9 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_9 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_10 )  True-( getB_1 $ forcen 1  expTB_10 )  True-( getB_1 $ forcen 2  expTB_10 )  True-( getB_1 $ forcen 3  expTB_10 )  True-( getB_1 $ forcen 4  expTB_10 )  True-( getB_1 $ forcen 5  expTB_10 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_10 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_10 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_10 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_10 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_10 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_11 )  True-( getB_1 $ forcen 1  expTB_11 )  True-( getB_1 $ forcen 2  expTB_11 )  True-( getB_1 $ forcen 3  expTB_11 )  True-( getB_1 $ forcen 4  expTB_11 )  True-( getB_1 $ forcen 5  expTB_11 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_11 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_11 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_11 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_11 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_11 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_12 )  True-( getB_1 $ forcen 1  expTB_12 )  True-( getB_1 $ forcen 2  expTB_12 )  True-( getB_1 $ forcen 3  expTB_12 )  True-( getB_1 $ forcen 4  expTB_12 )  True-( getB_1 $ forcen 5  expTB_12 )  True-( getB_1 $ forcen 6  expTB_12 )  True-( getB_1 $ forcen 7  expTB_12 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_12 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_12 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_12 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_13 )  True-( getB_1 $ forcen 1  expTB_13 )  True-( getB_1 $ forcen 2  expTB_13 )  True-( getB_1 $ forcen 3  expTB_13 )  True-( getB_1 $ forcen 4  expTB_13 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_13 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_13 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_13 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_13 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_13 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_13 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_14 )  True-( getB_1 $ forcen 1  expTB_14 )  True-( getB_1 $ forcen 2  expTB_14 )  True-( getB_1 $ forcen 3  expTB_14 )  True-( getB_1 $ forcen 4  expTB_14 )  True-( getB_1 $ forcen 5  expTB_14 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_14 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_14 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_14 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_14 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_14 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_15 )  True-( getB_1 $ forcen 1  expTB_15 )  True-( getB_1 $ forcen 2  expTB_15 )  True-( getB_1 $ forcen 3  expTB_15 )  True-( getB_1 $ forcen 4  expTB_15 )  True-( getB_1 $ forcen 5  expTB_15 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_15 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_15 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_15 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_15 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_15 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_16 )  5-( getB_1 $ forcen 1  expTB_16 )  5-( getB_1 $ forcen 2  expTB_16 )  5-( getB_1 $ forcen 3  expTB_16 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_16 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_16 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_16 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_16 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_16 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_16 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_16 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_17 )  5-( getB_1 $ forcen 1  expTB_17 )  5-( getB_1 $ forcen 2  expTB_17 )  Prelude.undefined-( getB_1 $ forcen 3  expTB_17 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_17 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_17 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_17 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_17 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_17 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_17 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_17 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_18 )  5-( getB_1 $ forcen 1  expTB_18 )  5-( getB_1 $ forcen 2  expTB_18 )  Prelude.undefined-( getB_1 $ forcen 3  expTB_18 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_18 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_18 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_18 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_18 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_18 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_18 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_18 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_19 )  False-( getB_1 $ forcen 1  expTB_19 )  False-( getB_1 $ forcen 2  expTB_19 )  Prelude.undefined-( getB_1 $ forcen 3  expTB_19 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_19 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_19 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_19 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_19 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_19 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_19 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_19 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_20 )  beesix-( getB_1 $ forcen 1  expTB_20 )  beesix-( getB_1 $ forcen 2  expTB_20 )  Prelude.undefined-( getB_1 $ forcen 3  expTB_20 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_20 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_20 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_20 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_20 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_20 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_20 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_20 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_21 )  &lt;bah&gt;-( getB_1 $ forcen 1  expTB_21 )  &lt;bah&gt;-( getB_1 $ forcen 2  expTB_21 )  &lt;bah&gt;-( getB_1 $ forcen 3  expTB_21 )  &lt;bah&gt;-( getB_1 $ forcen 4  expTB_21 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_21 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_21 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_21 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_21 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_21 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_21 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_22 )  &lt;bah&gt;-( getB_1 $ forcen 1  expTB_22 )  &lt;bah&gt;-( getB_1 $ forcen 2  expTB_22 )  &lt;bah&gt;-( getB_1 $ forcen 3  expTB_22 )  &lt;bah&gt;-( getB_1 $ forcen 4  expTB_22 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_22 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_22 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_22 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_22 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_22 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_22 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_23 )  &lt;bah&gt;-( getB_1 $ forcen 1  expTB_23 )  &lt;bah&gt;-( getB_1 $ forcen 2  expTB_23 )  &lt;bah&gt;-( getB_1 $ forcen 3  expTB_23 )  &lt;bah&gt;-( getB_1 $ forcen 4  expTB_23 )  &lt;bah&gt;-( getB_1 $ forcen 5  expTB_23 )  &lt;bah&gt;-( getB_1 $ forcen 6  expTB_23 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_23 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_23 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_23 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_23 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_24 )  &lt;bah&gt;-( getB_1 $ forcen 1  expTB_24 )  &lt;bah&gt;-( getB_1 $ forcen 2  expTB_24 )  &lt;bah&gt;-( getB_1 $ forcen 3  expTB_24 )  &lt;bah&gt;-( getB_1 $ forcen 4  expTB_24 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_24 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_24 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_24 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_24 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_24 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_24 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_25 )  &lt;bah&gt;-( getB_1 $ forcen 1  expTB_25 )  &lt;bah&gt;-( getB_1 $ forcen 2  expTB_25 )  Prelude.undefined-( getB_1 $ forcen 3  expTB_25 )  Prelude.undefined-( getB_1 $ forcen 4  expTB_25 )  Prelude.undefined-( getB_1 $ forcen 5  expTB_25 )  Prelude.undefined-( getB_1 $ forcen 6  expTB_25 )  Prelude.undefined-( getB_1 $ forcen 7  expTB_25 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_25 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_25 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_25 )  Prelude.undefined-( getB_1 $ forcen 0  expTB_26 )  &lt;bah&gt;-( getB_1 $ forcen 1  expTB_26 )  &lt;bah&gt;-( getB_1 $ forcen 2  expTB_26 )  &lt;bah&gt;-( getB_1 $ forcen 3  expTB_26 )  &lt;bah&gt;-( getB_1 $ forcen 4  expTB_26 )  &lt;bah&gt;-( getB_1 $ forcen 5  expTB_26 )  &lt;bah&gt;-( getB_1 $ forcen 6  expTB_26 )  &lt;bah&gt;-( getB_1 $ forcen 7  expTB_26 )  Prelude.undefined-( getB_1 $ forcen 8  expTB_26 )  Prelude.undefined-( getB_1 $ forcen 9  expTB_26 )  Prelude.undefined-( getB_1 $ forcen 10 expTB_26 )  Prelude.undefined---Testing SOP rnfpDyn with SYB generic stop condition.--Float-WR-BBB 3.4-[Int]-WI-AAA -Bool-WI-AAA -7--Testing SOP/SYB rnfpDyn again.--[[Int]]-Noo-C-WI-Noo-C-AAA -[[[Int]]]-Noo-D-WI-Noo-D-AAA -6--Testing SOP rnfpDyn' with SOP generic stop condition.--*** :-WR--Testing SOP rnfpDyn'' with Typeable generic stop condition--[[Int]]-WI-AAA -[[[Int]]]-WI-AAA -7---Testing Seqable class (tuple with list):--===================================================-exp = &lt;refer to test code&gt;-get (_,xs,_) = show $ (xs!!2)-? = get $! exp-===================================================-1 expected value           = 7-1 actual value             = 7-----------------------------------------------------2 expected value           = Prelude.undefined-2 actual value             = Prelude.undefined-----------------------------------------------------3 expected value           = Prelude.undefined-3 actual value             = Prelude.undefined-----------------------------------------------------4 expected value           = 7-4 actual value             = 7-----------------------------------------------------5 expected value           = 7-5 actual value             = 7-----------------------------------------------------6 expected value           = Prelude.undefined-6 actual value             = Prelude.undefined-----------------------------------------------------7 expected value           = 7-7 actual value             = 7-----------------------------------------------------8 expected value           = 7-8 actual value             = 7-----------------------------------------------------9 expected value           = 7-9 actual value             = 7-----------------------------------------------------Testing Seqable class (nested tuples):--===================================================-exp = &lt;refer to test code&gt;-get (_,(_,x),_) = show x-? = get $! exp-===================================================-1 expected value           = 7-1 actual value             = 7-----------------------------------------------------2 expected value           = 7-2 actual value             = 7-----------------------------------------------------3 expected value           = Prelude.undefined-3 actual value             = Prelude.undefined-----------------------------------------------------4 expected value           = Prelude.undefined-4 actual value             = Prelude.undefined-----------------------------------------------------5 expected value           = Prelude.undefined-5 actual value             = Prelude.undefined-----------------------------------------------------6 expected value           = 7-6 actual value             = 7-----------------------------------------------------7 expected value           = Prelude.undefined-7 actual value             = Prelude.undefined-----------------------------------------------------8 expected value           = 7-8 actual value             = 7-----------------------------------------------------9 expected value           = Prelude.undefined-9 actual value             = Prelude.undefined-----------------------------------------------------Testing generic Seqable (tuple with list):--===================================================-exp = &lt;refer to test code&gt;-get (_,xs,_) = show $ (xs!!2)-? = get $! exp-===================================================-1 expected value           = 7-1 actual value             = 7-----------------------------------------------------2 expected value           = Prelude.undefined-2 actual value             = Prelude.undefined-----------------------------------------------------3 expected value           = Prelude.undefined-3 actual value             = Prelude.undefined-----------------------------------------------------4 expected value           = 7-4 actual value             = 7-----------------------------------------------------5 expected value           = 7-5 actual value             = 7-----------------------------------------------------6 expected value           = Prelude.undefined-6 actual value             = Prelude.undefined-----------------------------------------------------7 expected value           = 7-7 actual value             = 7-----------------------------------------------------8 expected value           = 7-8 actual value             = 7-----------------------------------------------------9 expected value           = 7-9 actual value             = 7-----------------------------------------------------Testing generic Seqable (expTJ_*):--===================================================-exp = J2 (1, J4 (__, K3 __ (J1 4.5))) __-get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f-? = get exp-===================================================-1 expected value           = 4.5-1 actual value             = 4.5-----------------------------------------------------2 expected value           = Prelude.undefined-2 actual value             = Prelude.undefined-----------------------------------------------------3 expected value           = 4.5-3 actual value             = 4.5-----------------------------------------------------4 expected value           = Prelude.undefined-4 actual value             = Prelude.undefined-----------------------------------------------------5 expected value           = Prelude.undefined-5 actual value             = Prelude.undefined-----------------------------------------------------6 expected value           = Prelude.undefined-6 actual value             = Prelude.undefined------------------------------------------------------FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!--### Failure in: All:0-expected: 0- but got: 1-Cases: 1  Tried: 1  Errors: 0  Failures: 1-*** Exception: ExitFailure 1-*Main&gt; -Leaving GHCi.-kadath:script&gt; +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">+<html>+<head>+<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate" />+<meta http-equiv="Pragma" content="no-cache" />+<meta http-equiv="Expires" content="0" />+</head>+<body>+<pre>+<span style="color: #00F; font-weight: bold;">&gt;&gt;</span> main+Running tests for deepseq-bounded...+Cases: 1  Tried: 0  Errors: 0  Failures: 0++Testing.++Note that  __ = undefined  (abbrev. occurring in what follows).++Testing showPat+---------------+input:                       Node WW []+expect: *+   got: *+input:                       Node WI []+expect: .+   got: .+input:                       Node WS []+expect: !+   got: !+input:                       Node WR []+expect: ()+   got: ()+input:                       Node WR [Node WW []]+expect: (*)+   got: (*)+input:                       Node WR [Node WW [],Node WW []]+expect: (**)+   got: (**)+input:                       Node WR [Node WS [],Node WW []]+expect: (!*)+   got: (!*)+input:                       Node WR [Node WI [],Node WS []]+expect: (.!)+   got: (.!)+input:                       Node WR [Node WI []]+expect: (.)+   got: (.)+input:                       Node WR [Node WR [Node WI []]]+expect: ((.))+   got: ((.))+input:                       Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI []],Node WW [],Node WW [],Node WI [],Node WW []],Node WI [],Node WW []]+expect: (*.(*.(*.)**.*).*)+   got: (*.(*.(*.)**.*).*)+input:                       Node WR [Node WI [],Node WS [],Node WR [Node WN 23 [],Node WW []]]+expect: (.!(*23*))+   got: (.!(*23*))+input:                       Node WR [Node WI [],Node =WR [Node =WN 23 [],Node WW []],Node WW []]+expect: (.=(=*23*)*)+   got: (.=(=*23*)*)+input:                       Node TR (Int) []+expect: :Int:()+   got: :Int:()+input:                       Node TN 23 (Int) []+expect: :Int:*23+   got: :Int:*23+input:                       Node TW (Int) []+expect: :Int:*+   got: :Int:*+input:                       Node TI (Int) []+expect: :Int:.+   got: :Int:.+input:                       Node =TR (Int) []+expect: =:Int:()+   got: =:Int:()+input:                       Node =TN 23 (Int) []+expect: =:Int:*23+   got: =:Int:*23+input:                       Node =TW (Int) []+expect: =:Int:*+   got: =:Int:*+input:                       Node =TI (Int) []+expect: =:Int:.+   got: =:Int:.+input:                       Node =TR ([Int]) []+expect: =:[Int]:()+   got: =:[Int]:()+input:                       Node =TW ([Int]) []+expect: =:[Int]:*+   got: =:[Int]:*+input:                       Node =TN 23 ([Int]) []+expect: =:[Int]:*23+   got: =:[Int]:*23+input:                       Node =+^WR []+expect: =+^()+   got: =+^()+input:                       Node =+^TN 23 ([Int]) []+expect: =+^:[Int]:*23+   got: =+^:[Int]:*23++Pattern                       Compiles to+-----------------------------------------+.                             Node WI []+!                             Node WS []+*                             Node WW []+*!                            Node WR [Node WW [],Node WS []]+()                            Node WR []+(.)                           Node WR [Node WI []]+(*)                           Node WR [Node WW []]+(**)                          Node WR [Node WW [],Node WW []]+(!*)                          Node WR [Node WS [],Node WW []]+(.!)                          Node WR [Node WI [],Node WS []]+(.(.))                        Node WR [Node WI [],Node WR [Node WI []]]+((.))                         Node WR [Node WR [Node WI []]]+(.(().))                      Node WR [Node WI [],Node WR [Node WR [],Node WI []]]+(*.*.*.**.*.*)                Node WR [Node WW [],Node WI [],Node WW [],Node WI [],Node WW [],Node WI [],Node WW [],Node WW [],Node WI [],Node WW [],Node WI [],Node WW []]+(*.(*.(*.)*)*(.*).*)          Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI []],Node WW []],Node WW [],Node WR [Node WI [],Node WW []],Node WI [],Node WW []]+(*.(*.(*.)*)*.*)              Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI []],Node WW []],Node WW [],Node WI [],Node WW []]+(*.(*.(*.)*)(*)(.*).*)        Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI [],Node WR [Node WW [],Node WI []],Node WW []],Node WR [Node WW []],Node WR [Node WI [],Node WW []],Node WI [],Node WW []]+((!(!)(((!).!(!))))!(!(!)))   Node WR [Node WR [Node WS [],Node WR [Node WS []],Node WR [Node WR [Node WR [Node WS []],Node WI [],Node WS [],Node WR [Node WS []]]]],Node WS [],Node WR [Node WS [],Node WR [Node WS []]]]+*23                           Node WN 23 []+(.!(*23*))                    Node WR [Node WI [],Node WS [],Node WR [Node WN 23 [],Node WW []]]+:Int:                         compilePat: input not completely consumed+Input remaining: :Int:+Patterns so far parsed: []+:Int:()                       Node TR (Int) []+:Int:!                        compilePat: input not completely consumed+Input remaining: :Int:!+Patterns so far parsed: []+:Int.                         compilePat: input not completely consumed+Input remaining: :Int.+Patterns so far parsed: []+:Int:.                        Node TI (Int) []+:Int:*                        Node TW (Int) []+:Int*23                       compilePat: input not completely consumed+Input remaining: :Int*23+Patterns so far parsed: []+:Int:*23                      Node TN 23 (Int) []+=.                            Node =WI []+=!                            Node =WS []+=*                            Node =WW []+(.=(=*23*)*)                  Node WR [Node WI [],Node =WR [Node =WN 23 [],Node WW []],Node WW []]+=:Int                         compilePat: input not completely consumed+Input remaining: =:Int+Patterns so far parsed: []+=:Int:()                      Node =TR (Int) []+=:Int:!                       compilePat: input not completely consumed+Input remaining: =:Int:!+Patterns so far parsed: []+=:Int:.                       Node =TI (Int) []+=:Int:*                       Node =TW (Int) []+=:Int*23                      compilePat: input not completely consumed+Input remaining: =:Int*23+Patterns so far parsed: []+=:Int:*23                     Node =TN 23 (Int) []+=:[Int]:()                    Node =TR ([Int]) []+=:[Int]:*                     Node =TW ([Int]) []+=:[Int]:*23                   Node =TN 23 ([Int]) []+=+^()                         Node =+^WR []++^=()                         Node =+^WR []+=+^:[Int]:*23                 Node =+^TN 23 ([Int]) []++===================================================+exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+get (_,xs,_) = show $ (xs!!2)+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = !..+showPat.compilePat       = (!..)+expected value           = syntax error+actual value             = 7+---------------------------------------------------+patstr                   = (!..)+showPat.compilePat       = (!..)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (().().())+expected value           = 7 (but "# with subpattern" warning)+showPat.compilePat       = (().().())+actual value             = 7+---------------------------------------------------+patstr                   = *+showPat.compilePat       = *+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (***)+showPat.compilePat       = (***)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (...)+showPat.compilePat       = (...)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (*..)+showPat.compilePat       = (*..)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (**.)+showPat.compilePat       = (**.)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (..*)+showPat.compilePat       = (..*)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = ((*.*).)+expected value           = 7 (with silent pattern-match failure)+showPat.compilePat       = ((*.*).)+actual value             = 7+---------------------------------------------------+patstr                   = ((*...).)+expected value           = 7 (with silent pattern-match failure)+showPat.compilePat       = ((*...).)+actual value             = 7+---------------------------------------------------+patstr                   = ((*....).)+expected value           = 7 (with silent pattern-match failure)+showPat.compilePat       = ((*....).)+actual value             = 7+---------------------------------------------------+patstr                   = ((*....)!)+expected value           = 7 (with silent pattern-match failure)+showPat.compilePat       = ((*....)!)+actual value             = 7+---------------------------------------------------+patstr                   = ((*.)*)+showPat.compilePat       = ((*.)*)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = ((*.).)+showPat.compilePat       = ((*.).)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = ((*(.*)).)+showPat.compilePat       = ((*(.*)).)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = ((*(*.)).)+showPat.compilePat       = ((*(*.)).)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = ((((.*))).)+expected value           = 7 (with silent pattern-match failure)+showPat.compilePat       = ((((.*))).)+actual value             = 7+---------------------------------------------------+patstr                   = (.(((.*))).)+showPat.compilePat       = (.(((.*))).)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (!(!(.(!!))).)+showPat.compilePat       = (!(!(.(!!))).)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (!(!(.*)).)+showPat.compilePat       = (!(!(.*)).)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (*(*(.*)).)+showPat.compilePat       = (*(*(.*)).)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (..*)+showPat.compilePat       = (..*)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*.*)+showPat.compilePat       = (*.*)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = :Tuple3:(*(*(.*)).)+showPat.compilePat       = :Tuple3:(*(*(.*)).)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :(,,):(*(*(.*)).)+showPat.compilePat       = :(,,):(*(*(.*)).)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :(,,):(*(*(!*)).)+showPat.compilePat       = :(,,):(*(*(!*)).)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = :Bool:(***)+showPat.compilePat       = :Bool:(***)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :Bool*+showPat.compilePat       = compilePat: input not completely consumed+Input remaining: :Bool*+Patterns so far parsed: []+---------------------------------------------------+patstr                   = :Bool:*+showPat.compilePat       = :Bool:*+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :(,,):*+showPat.compilePat       = :(,,):*+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*.!)+showPat.compilePat       = (*.!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*:Bool:..)+showPat.compilePat       = (*:Bool:..)+expected value           = 7+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*:Int:..)+showPat.compilePat       = (*:Int:..)+expected value           = 7+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*:(,):..)+showPat.compilePat       = (*:(,):..)+expected value           = 7+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*:OutOfScopeType:..)+showPat.compilePat       = (*:OutOfScopeType:..)+expected value           = 7+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*:[Int]:..)+showPat.compilePat       = (*:[Int]:..)+expected value           = 7+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*:[Int]:.!)+showPat.compilePat       = (*:[Int]:.!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*.:Bool:.)+showPat.compilePat       = (*.:Bool:.)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (*.:Int:.)+showPat.compilePat       = (*.:Int:.)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*.:(,):.)+showPat.compilePat       = (*.:(,):.)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*.:OutOfScopeType:.)+showPat.compilePat       = (*.:OutOfScopeType:.)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*.:[Int]:.)+showPat.compilePat       = (*.:[Int]:.)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*:[Int]:*.)+showPat.compilePat       = (*:[Int]:*.)+expected value           = Prelude.undefined+actual value             = 7+---------------------------------------------------+patstr                   = (*:Bool:*.)+showPat.compilePat       = (*:Bool:*.)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (*:Int:*.)+showPat.compilePat       = (*:Int:*.)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (*:(,):*.)+showPat.compilePat       = (*:(,):*.)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (*:OutOfScopeType:*.)+showPat.compilePat       = (*:OutOfScopeType:*.)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (*.:Bool:*)+showPat.compilePat       = (*.:Bool:*)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*.:Int:*)+showPat.compilePat       = (*.:Int:*)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (*.:(,):*)+showPat.compilePat       = (*.:(,):*)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (**2.)+showPat.compilePat       = (**2.)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (**3.)+showPat.compilePat       = (**3.)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*:G2:..)+showPat.compilePat       = (*:G2:..)+expected value           = 7+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (*:Int:..)+showPat.compilePat       = (*:Int:..)+expected value           = 7+actual value             = Prelude.undefined+--------------------------------------------------+===================================================+exp = (G1, G2 5 __ 7, __) :: (TG, TG, Bool)+get (_,(G2 _ _ n),_) = n+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = (*:G2:..)+showPat.compilePat       = (*:G2:..)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (*:Int:..)+showPat.compilePat       = (*:Int:..)+expected value           = 7+actual value             = 7+--------------------------------------------------+===================================================+exp = G2 5 __ 7 :: TG+get (G2 _ _ n) = n+? = get $ forcep patstr exp+===================================================+patstr                   = *+showPat.compilePat       = *+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = *0+showPat.compilePat       = *0+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = *1+showPat.compilePat       = *1+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = *2+showPat.compilePat       = *2+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = *3+showPat.compilePat       = *3+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (!.!)+showPat.compilePat       = (!.!)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (!!!)+showPat.compilePat       = (!!!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (!!)+showPat.compilePat       = (!!)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = (!!!)+showPat.compilePat       = (!!!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (!!!!)+showPat.compilePat       = (!!!!)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :G1:(!!)+showPat.compilePat       = :G1:(!!)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :G1:(!!!)+showPat.compilePat       = :G1:(!!!)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :G2:(!!)+showPat.compilePat       = :G2:(!!)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :G2:(!!!)+showPat.compilePat       = :G2:(!!!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = :TG:(!!!)+showPat.compilePat       = :TG:(!!!)+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :G1:*+showPat.compilePat       = :G1:*+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :G2:*+showPat.compilePat       = :G2:*+expected value           = Prelude.undefined+actual value             = 7+---------------------------------------------------+patstr                   = :TG:*+showPat.compilePat       = :TG:*+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :Int:.+showPat.compilePat       = :Int:.+expected value           = Prelude.undefined+actual value             = 7+---------------------------------------------------+patstr                   = :G1:.+showPat.compilePat       = :G1:.+expected value           = Prelude.undefined+actual value             = 7+---------------------------------------------------+patstr                   = :G2:.+showPat.compilePat       = :G2:.+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :TG:.+showPat.compilePat       = :TG:.+expected value           = Prelude.undefined+actual value             = 7+---------------------------------------------------+patstr                   = :Int:.+showPat.compilePat       = :Int:.+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :G1:.(!!)+showPat.compilePat       = (:G1:.(!!))+expected value           = 7+actual value             = 7+---------------------------------------------------+patstr                   = :G1:*(!!)+showPat.compilePat       = (:G1:*(!!))+expected value           = 7+actual value             = 7+--------------------------------------------------+===================================================+exp = J2 (1, J4 (J3, K3 __ (J1 4.5))) False+get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = ((!((!(!(!)))))!)+showPat.compilePat       = ((!((!(!(!)))))!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = ((!((.(!(!))))).)+showPat.compilePat       = ((!((.(!(!))))).)+expected value           = 4.5+actual value             = 4.5+--------------------------------------------------+===================================================+exp = J2 (1, J4 (__, K2)) False+get ~_ = show 1  -- seems to suffice?!?...+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = ((!((!!)))!)+showPat.compilePat       = ((!((!!)))!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = ((!((.!)))!)+showPat.compilePat       = ((!((.!)))!)+expected value           = 1+actual value             = 1+---------------------------------------------------+patstr                   = ((!(.(!!)))!)+showPat.compilePat       = ((!(.(!!)))!)+expected value           = 1+actual value             = 1+---------------------------------------------------+patstr                   = ((!.((!!)))!)+showPat.compilePat       = ((!.((!!)))!)+expected value           = 1+actual value             = 1+--------------------------------------------------+===================================================+exp = J4 (__, K2)+get ~_ = show 1  -- seems to suffice?!?...+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = ((!!))+showPat.compilePat       = ((!!))+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = ((.!))+showPat.compilePat       = ((.!))+expected value           = 1+actual value             = 1+---------------------------------------------------+patstr                   = (.(!!))+showPat.compilePat       = (.(!!))+expected value           = 1+actual value             = 1+---------------------------------------------------+patstr                   = .((!!))+showPat.compilePat       = (.((!!)))+expected value           = 1+actual value             = 1+--------------------------------------------------+===================================================+exp = (__, K2)+get ~_ = show 1  -- seems to suffice?!?...+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = (!!)+showPat.compilePat       = (!!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (.!)+showPat.compilePat       = (.!)+expected value           = 1+actual value             = 1+---------------------------------------------------+patstr                   = .(!!)+showPat.compilePat       = (.(!!))+expected value           = 1+actual value             = 1+--------------------------------------------------+===================================================+exp = __ :: TJ+get ~_ = show 1  -- seems to suffice?!?...+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = !+showPat.compilePat       = !+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = .+showPat.compilePat       = .+expected value           = 1+actual value             = Prelude.undefined+--------------------------------------------------+===================================================+exp = (K5 (__::TJ))+get ~_ = show 1  -- seems to suffice?!?...+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = !+showPat.compilePat       = !+expected value           = okay+actual value             = okay+---------------------------------------------------+patstr                   = (.)+showPat.compilePat       = (.)+expected value           = okay+actual value             = okay+---------------------------------------------------+patstr                   = (!)+showPat.compilePat       = (!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = .+showPat.compilePat       = .+expected value           = okay+actual value             = okay+--------------------------------------------------+===================================================+exp = K3 (__::TK) J3+get ~_ = show 1  -- seems to suffice?!?...+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = !+showPat.compilePat       = !+expected value           = okay+actual value             = okay+---------------------------------------------------+patstr                   = (.!)+showPat.compilePat       = (.!)+expected value           = okay+actual value             = okay+---------------------------------------------------+patstr                   = (!.)+showPat.compilePat       = (!.)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (!!)+showPat.compilePat       = (!!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = .+showPat.compilePat       = .+expected value           = okay+actual value             = okay+--------------------------------------------------+===================================================+exp = L1 5.6 (M1 __)+get (L1 f (M1 _)) = show f+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = .+showPat.compilePat       = .+expected value           = 5.6+actual value             = 5.6+---------------------------------------------------+patstr                   = .(!!)+expected value           = 5.6 (but "# with subpattern" warning)+showPat.compilePat       = (.(!!))+actual value             = 5.6+---------------------------------------------------+patstr                   = (!!)+showPat.compilePat       = (!!)+expected value           = 5.6+actual value             = 5.6+---------------------------------------------------+patstr                   = ((!)!)+showPat.compilePat       = ((!)!)+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = ((.)!)+showPat.compilePat       = ((.)!)+expected value           = 5.6+actual value             = 5.6+--------------------------------------------------+===================================================+exp = K3 __ (J1 4.5)+get = (K3 _ (J1 f)) = show f+? = get $ forcep patstr exp+===================================================+patstr                   = +showPat.compilePat       = compilePat: syntax error+---------------------------------------------------+patstr                   = (!(!))+showPat.compilePat       = (!(!))+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = (..)+showPat.compilePat       = (..)+expected value           = 4.5+actual value             = 4.5+---------------------------------------------------+patstr                   = (.!)+showPat.compilePat       = (.!)+expected value           = 4.5+actual value             = 4.5+---------------------------------------------------+patstr                   = (.(.))+showPat.compilePat       = (.(.))+expected value           = 4.5+actual value             = 4.5+---------------------------------------------------+patstr                   = (.(!))+showPat.compilePat       = (.(!))+expected value           = 4.5+actual value             = 4.5+---------------------------------------------------+patstr                   = (!.(!))+showPat.compilePat       = (!.(!))+expected value           = Prelude.undefined+actual value             = 4.5+---------------------------------------------------+patstr                   = (!.(.))+showPat.compilePat       = (!.(.))+expected value           = Prelude.undefined+actual value             = 4.5+---------------------------------------------------+patstr                   = (..(.))+showPat.compilePat       = (..(.))+expected value           = 4.5+actual value             = 4.5+---------------------------------------------------+patstr                   = .(..(.))+showPat.compilePat       = (.(..(.)))+expected value           = 4.5+actual value             = 4.5+--------------------------------------------------+===================================================+exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+get (_,xs,_) = show $ (xs!!2)+? = get $ ( forcep patstr2 . forcep patstr1 ) exp+? = get $! ( forcep_ ( unionPats [ pat1, pat2 ] ) ) exp+(Results were more interesting with a previous semantics...).+===================================================+patstr1                     = !+patstr2                     = !+patstrU                     = !+showPat.compilePat patstr1  = !+showPat.compilePat patstr2  = !+showPat.compilePat patstrU  = !+expected value              = 7+actual value                = 7+actual value                = 7+---------------------------------------------------+patstr1                     = !+patstr2                     = *+patstrU                     = *+showPat.compilePat patstr1  = !+showPat.compilePat patstr2  = *+showPat.compilePat patstrU  = *+expected value              = Prelude.undefined+actual value                = Prelude.undefined+---------------------------------------------------+patstr1                     = *+patstr2                     = !+patstrU                     = *+showPat.compilePat patstr1  = *+showPat.compilePat patstr2  = !+showPat.compilePat patstrU  = *+expected value              = Prelude.undefined+actual value                = Prelude.undefined+---------------------------------------------------+patstr1                     = *+patstr2                     = *+patstrU                     = *+showPat.compilePat patstr1  = *+showPat.compilePat patstr2  = *+showPat.compilePat patstrU  = *+expected value              = Prelude.undefined+actual value                = Prelude.undefined+---------------------------------------------------+patstr1                     = (!!!)+patstr2                     = (*!!)+patstrU                     = (*!!)+showPat.compilePat patstr1  = (!!!)+showPat.compilePat patstr2  = (*!!)+showPat.compilePat patstrU  = (*!!)+expected value              = Prelude.undefined+actual value                = Prelude.undefined+---------------------------------------------------+patstr1                     = (*!!)+patstr2                     = (!!*)+patstrU                     = (*!*)+showPat.compilePat patstr1  = (*!!)+showPat.compilePat patstr2  = (!!*)+showPat.compilePat patstrU  = (*!*)+expected value              = Prelude.undefined+actual value                = Prelude.undefined+---------------------------------------------------+patstr1                     = (!*.)+patstr2                     = (!.!)+patstrU                     = (!*!)+showPat.compilePat patstr1  = (!*.)+showPat.compilePat patstr2  = (!.!)+showPat.compilePat patstrU  = (!*!)+expected value              = Prelude.undefined+actual value                = Prelude.undefined+--------------------------------------------------+===================================================+Testing splicePats.+---------------------------------------------------+target       !+path         []+isibs        [(0,"*")]+result       splicePats: path ends in non-recursive node type WS+---------------------------------------------------+target       ()+path         []+isibs        [(0,"*")]+result       (*)+---------------------------------------------------+target       !+path         [0]+isibs        [(0,"*")]+result       splicePats: path escapes target (depth)+---------------------------------------------------+target       (!!)+path         []+isibs        [(0,"*")]+result       (*!!)+---------------------------------------------------+target       (!!)+path         [0]+isibs        [(0,"*")]+result       splicePats: path ends in non-recursive node type WS+---------------------------------------------------+target       (!!)+path         [2]+isibs        [(0,"*")]+result       splicePats: path escapes target (breadth)+---------------------------------------------------+target       (!!)+path         []+isibs        [(0,"*"),(0,".")]+result       (*.!!)+---------------------------------------------------+target       (!!)+path         []+isibs        [(0,"*"),(1,".")]+result       (*!.!)+---------------------------------------------------+target       (!!)+path         []+isibs        [(1,"."),(0,"*")]+result       (*!.!)+---------------------------------------------------+target       (!!)+path         []+isibs        [(0,"*"),(2,".")]+result       (*!!.)+---------------------------------------------------+target       (!!)+path         []+isibs        [(2,"*"),(2,"."),(2,".")]+result       (!!*..)+---------------------------------------------------+target       (!!)+path         []+isibs        [(-1,"*")]+result       (!!*)+---------------------------------------------------+target       (!!)+path         []+isibs        [(0,"*")]+result       (*!!)+---------------------------------------------------+target       (!!)+path         []+isibs        [(1,"*")]+result       (!*!)+---------------------------------------------------+target       (!!)+path         []+isibs        [(2,"*")]+result       (!!*)+---------------------------------------------------+target       (!!)+path         []+isibs        [(3,"*")]+result       splicePats: insertion indices (0-based) must be+no greater than the number of children+---------------------------------------------------+target       (!(!!)!)+path         [1]+isibs        [(0,"*")]+result       (!(*!!)!)+---------------------------------------------------+target       (!(!!)!)+path         [1]+isibs        [(0,"*3"),(1,"."),(2,"*")]+result       (!(*3!.!*)!)+---------------------------------------------------+target       (!(!!)!)+path         [1,0]+isibs        [(0,"*"),(0,".")]+result       splicePats: path ends in non-recursive node type WS+---------------------------------------------------+target       ((!!!)(()!)!)+path         [1]+isibs        [(0,"*"),(0,".")]+result       ((!!!)(*.()!)!)+---------------------------------------------------+target       ((!!!)(()!)!)+path         [1,0]+isibs        [(0,"*"),(0,".")]+result       ((!!!)((*.)!)!)+---------------------------------------------------+target       ((...)(().).)+path         [1,0]+isibs        [(0,"*"),(0,".")]+result       ((...)((*.).).)+---------------------------------------------------+target       (:(,,):(...)(().).)+path         [1,0]+isibs        [(0,"*"),(0,".")]+result       (:(,,):(...)((*.).).)+===================================================+Testing elidePats.+---------------------------------------------------+target       ((!!)!(!))+path         []+isibs        [0]+result       (!(!))+---------------------------------------------------+target       ((!!)!(!))+path         [0]+isibs        [0]+result       ((!)!(!))+---------------------------------------------------+target       ((!!)!(!))+path         [1]+isibs        [0]+result       elidePats: elision indices (0-based) must be+less than the number of children+---------------------------------------------------+target       ((!!)!(!))+path         [1]+isibs        [1]+result       elidePats: elision indices (0-based) must be+less than the number of children+===================================================+Testing erodePat.+---------------------------------------------------+target       ((!!)!(!))+stdgen       1838733243 2147483398+path         []+result       ((.!)!(!))+---------------------------------------------------+target       ((!!)!(!))+stdgen       739886477 367188984+path         []+result       ((!.)!(!))+---------------------------------------------------+target       ((!!)!(!))+stdgen       1294374074 223185073+path         []+result       ((!.)!(!))+---------------------------------------------------+target       ((!!)!(!))+stdgen       1998638512 1632766708+path         []+result       ((.!)!(!))+---------------------------------------------------+target       ((!!)!(!))+stdgen       2068100998 709377745+path         []+result       ((.!)!(!))+---------------------------------------------------+===================================================+Testing miscellaneous PatUtil functions...+---------------------------------------------------+unionPats test already done test13-1!+---------------------------------------------------+Testing      intersectPats [patA, patB]+patA         (!!!)+patB         (!.)+result       intersectPat: WRWR: encountered arity disparity!+---------------------------------------------------+Testing      subPat patA patB+patA         !+patB         !+as expected  True+---------------------------------------------------+Testing      subPat patA patB+patA         .+patB         .+as expected  True+---------------------------------------------------+Testing      subPat patA patB+patA         *+patB         *+as expected  True+---------------------------------------------------+Testing      subPat patA patB+patA         !+patB         ()+expect       True+result       False+---------------------------------------------------+Testing      subPat patA patB+patA         ()+patB         !+expect       False+result       True+---------------------------------------------------+Testing      subPat patA patB+patA         ()+patB         (!)+intersectPat: WRWR: encountered arity disparity!+---------------------------------------------------+Testing      subPat patA patB+patA         (!)+patB         (!)+as expected  True+---------------------------------------------------+Testing      subPat patA patB+patA         (!)+patB         (!!)+intersectPat: WRWR: encountered arity disparity!+---------------------------------------------------+Testing      subPat patA patB+patA         (!)+patB         ((!))+expect       True+result       False+---------------------------------------------------+Testing      subPat patA patB+patA         (!!)+patB         (!.)+as expected  False+---------------------------------------------------+Testing      subPat patA patB+patA         (!.)+patB         (!!)+as expected  True+---------------------------------------------------+Testing      subPat patA patB+patA         (!!)+patB         (!!!)+intersectPat: WRWR: encountered arity disparity!+---------------------------------------------------+Testing      subPat patA patB+patA         ()+patB         (!!!)+intersectPat: WRWR: encountered arity disparity!+---------------------------------------------------+Testing      subPat patA patB+patA         !+patB         (*!.)+expect       True+result       False+---------------------------------------------------+Testing      subPat patA patB+patA         .+patB         (*!.)+as expected  True+---------------------------------------------------+Testing      subPat patA patB+patA         *+patB         (*!.)+as expected  False+---------------------------------------------------+Testing      subPat patA patB+patA         *+patB         (*)+as expected  False+---------------------------------------------------+Testing      subPat patA patB+patA         *+patB         (**)+as expected  False+doit13: unexpected code 4+---------------------------------------------------+Testing      emptyPat+result       .+---------------------------------------------------+Testing      mkPat ([1,2,3],(False,"foo"))+result       ((()(()(()())))(()(()(()(()())))))+---------------------------------------------------+Testing      growPat patA ([1,2,3],(False,"foo"))+patA         ((!(!!))(!(!!)))+result       ((()(()(..)))(()(()(..))))+---------------------------------------------------+Testing      growPat patA ([1,2,3],(False,"foo"))+patA         ((!(!(!!)))(!(!(!!))))+result       ((()(()(()())))(()(()(()(..)))))+---------------------------------------------------+Testing      growPat patA ([1,2,3],(False,"foo"))+patA         ((!(!(!!)))(!(!(!(!!)))))+result       ((()(()(()())))(()(()(()(()())))))+---------------------------------------------------+Testing      shrinkPat patA+patA         ((!(!(!!)))(!(!(!(!!)))))+result       ((.(.(..)))(.(.(.(..)))))+---------------------------------------------------+Testing      shrinkPat patA+patA         ((!(!(!!)))(!(!(!!))))+result       ((.(.(..)))(.(.(..))))+---------------------------------------------------+Testing      shrinkPat patA+patA         ((!(!!))(!(!!)))+result       ((.(..))(.(..)))+---------------------------------------------------+Testing      shrinkPat patA+patA         ((.(!!))(.(*3!)))+result       ((.(..))(.(*2.)))+---------------------------------------------------+Testing      shrinkPat patA+patA         ((.!)(.!))+result       ((..)(..))+---------------------------------------------------+Testing      shrinkPat patA+patA         (!!)+result       (..)+---------------------------------------------------+Testing      shrinkPat patA+patA         !+result       .+---------------------------------------------------+Testing      liftPats patstrlst+patstrs      ["(!!!)","(!.)"]+result       ((!!!)(!.))+---------------------------------------------------+splicePats test already done test13-10!+---------------------------------------------------+isPath test already done test13-11!+---------------------------------------------------+Testing      mkPatN 2 ([1,2,3],(False,"foo"))+result       ((()(..))(()(..)))+---------------------------------------------------++Testing fusion+-fenable-rewrite-rules -O -ddump-rules -ddump-simpl-stats -ddump-rule-firings++7+7+7+7++expN_1 = [__] :: [Int]+expN_2 = [0,1,__,3] :: [Int]+expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)+expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)++getN_1 xs = show $ ()+getN_2 xs = show $ (xs!!3)+getN_3 (_,xs,_) = show $ (xs!!2)+forcen 0 expN_1 `seq` ()  =  ()+forcen 1 expN_1 `seq` ()  =  ()+forcen 2 expN_1 `seq` ()  =  Prelude.undefined+forcen 3 expN_1 `seq` ()  =  Prelude.undefined+forcen 4 expN_1 `seq` ()  =  Prelude.undefined++getN_2 $ forcen 0 expN_2  =  3+getN_2 $ forcen 1 expN_2  =  3+getN_2 $ forcen 2 expN_2  =  3+getN_2 $ forcen 3 expN_2  =  3+getN_2 $ forcen 4 expN_2  =  Prelude.undefined++getN_3 $ forcen 0 expN_3  =  7+getN_3 $ forcen 1 expN_3  =  7+getN_3 $ forcen 2 expN_3  =  7+getN_3 $ forcen 3 expN_3  =  7+getN_3 $ forcen 4 expN_3  =  Prelude.undefined++getN_3 $ forcen 0 expN_4  =  7+getN_3 $ forcen 1 expN_4  =  7+getN_3 $ forcen 2 expN_4  =  Prelude.undefined+getN_3 $ forcen 3 expN_4  =  Prelude.undefined+getN_3 $ forcen 4 expN_4  =  Prelude.undefined++===================================================+Testing generic GNFDataN (refer to Foo.hs for the defs).++---------------------------------------------------+( getB_1 $ forcen 0  expTB_1 )  True+( getB_1 $ forcen 1  expTB_1 )  True+( getB_1 $ forcen 2  expTB_1 )  True+( getB_1 $ forcen 3  expTB_1 )  True+( getB_1 $ forcen 4  expTB_1 )  True+( getB_1 $ forcen 5  expTB_1 )  True+( getB_1 $ forcen 6  expTB_1 )  True+( getB_1 $ forcen 7  expTB_1 )  True+( getB_1 $ forcen 8  expTB_1 )  True+( getB_1 $ forcen 9  expTB_1 )  True+( getB_1 $ forcen 10 expTB_1 )  True+( getB_1 $ forcen 0  expTB_2 )  True+( getB_1 $ forcen 1  expTB_2 )  True+( getB_1 $ forcen 2  expTB_2 )  True+( getB_1 $ forcen 3  expTB_2 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_2 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_2 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_2 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_2 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_2 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_2 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_2 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 1  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 2  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 3  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_3 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_3 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 1  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 2  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 3  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_4 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_4 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_5 )  True+( getB_1 $ forcen 1  expTB_5 )  True+( getB_1 $ forcen 2  expTB_5 )  True+( getB_1 $ forcen 3  expTB_5 )  True+( getB_1 $ forcen 4  expTB_5 )  True+( getB_1 $ forcen 5  expTB_5 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_5 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_5 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_5 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_5 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_5 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_6 )  True+( getB_1 $ forcen 1  expTB_6 )  True+( getB_1 $ forcen 2  expTB_6 )  True+( getB_1 $ forcen 3  expTB_6 )  True+( getB_1 $ forcen 4  expTB_6 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_6 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_6 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_6 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_6 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_6 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_6 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 1  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 2  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 3  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_7 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_7 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_8 )  True+( getB_1 $ forcen 1  expTB_8 )  True+( getB_1 $ forcen 2  expTB_8 )  True+( getB_1 $ forcen 3  expTB_8 )  True+( getB_1 $ forcen 4  expTB_8 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_8 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_8 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_8 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_8 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_8 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_8 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_9 )  True+( getB_1 $ forcen 1  expTB_9 )  True+( getB_1 $ forcen 2  expTB_9 )  True+( getB_1 $ forcen 3  expTB_9 )  True+( getB_1 $ forcen 4  expTB_9 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_9 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_9 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_9 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_9 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_9 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_9 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_10 )  True+( getB_1 $ forcen 1  expTB_10 )  True+( getB_1 $ forcen 2  expTB_10 )  True+( getB_1 $ forcen 3  expTB_10 )  True+( getB_1 $ forcen 4  expTB_10 )  True+( getB_1 $ forcen 5  expTB_10 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_10 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_10 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_10 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_10 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_10 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_11 )  True+( getB_1 $ forcen 1  expTB_11 )  True+( getB_1 $ forcen 2  expTB_11 )  True+( getB_1 $ forcen 3  expTB_11 )  True+( getB_1 $ forcen 4  expTB_11 )  True+( getB_1 $ forcen 5  expTB_11 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_11 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_11 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_11 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_11 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_11 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_12 )  True+( getB_1 $ forcen 1  expTB_12 )  True+( getB_1 $ forcen 2  expTB_12 )  True+( getB_1 $ forcen 3  expTB_12 )  True+( getB_1 $ forcen 4  expTB_12 )  True+( getB_1 $ forcen 5  expTB_12 )  True+( getB_1 $ forcen 6  expTB_12 )  True+( getB_1 $ forcen 7  expTB_12 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_12 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_12 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_12 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_13 )  True+( getB_1 $ forcen 1  expTB_13 )  True+( getB_1 $ forcen 2  expTB_13 )  True+( getB_1 $ forcen 3  expTB_13 )  True+( getB_1 $ forcen 4  expTB_13 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_13 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_13 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_13 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_13 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_13 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_13 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_14 )  True+( getB_1 $ forcen 1  expTB_14 )  True+( getB_1 $ forcen 2  expTB_14 )  True+( getB_1 $ forcen 3  expTB_14 )  True+( getB_1 $ forcen 4  expTB_14 )  True+( getB_1 $ forcen 5  expTB_14 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_14 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_14 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_14 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_14 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_14 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_15 )  True+( getB_1 $ forcen 1  expTB_15 )  True+( getB_1 $ forcen 2  expTB_15 )  True+( getB_1 $ forcen 3  expTB_15 )  True+( getB_1 $ forcen 4  expTB_15 )  True+( getB_1 $ forcen 5  expTB_15 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_15 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_15 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_15 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_15 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_15 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_16 )  5+( getB_1 $ forcen 1  expTB_16 )  5+( getB_1 $ forcen 2  expTB_16 )  5+( getB_1 $ forcen 3  expTB_16 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_16 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_16 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_16 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_16 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_16 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_16 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_16 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_17 )  5+( getB_1 $ forcen 1  expTB_17 )  5+( getB_1 $ forcen 2  expTB_17 )  Prelude.undefined+( getB_1 $ forcen 3  expTB_17 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_17 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_17 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_17 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_17 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_17 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_17 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_17 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_18 )  5+( getB_1 $ forcen 1  expTB_18 )  5+( getB_1 $ forcen 2  expTB_18 )  Prelude.undefined+( getB_1 $ forcen 3  expTB_18 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_18 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_18 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_18 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_18 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_18 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_18 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_18 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_19 )  False+( getB_1 $ forcen 1  expTB_19 )  False+( getB_1 $ forcen 2  expTB_19 )  Prelude.undefined+( getB_1 $ forcen 3  expTB_19 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_19 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_19 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_19 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_19 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_19 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_19 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_19 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_20 )  beesix+( getB_1 $ forcen 1  expTB_20 )  beesix+( getB_1 $ forcen 2  expTB_20 )  Prelude.undefined+( getB_1 $ forcen 3  expTB_20 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_20 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_20 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_20 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_20 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_20 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_20 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_20 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_21 )  &lt;bah&gt;+( getB_1 $ forcen 1  expTB_21 )  &lt;bah&gt;+( getB_1 $ forcen 2  expTB_21 )  &lt;bah&gt;+( getB_1 $ forcen 3  expTB_21 )  &lt;bah&gt;+( getB_1 $ forcen 4  expTB_21 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_21 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_21 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_21 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_21 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_21 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_21 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_22 )  &lt;bah&gt;+( getB_1 $ forcen 1  expTB_22 )  &lt;bah&gt;+( getB_1 $ forcen 2  expTB_22 )  &lt;bah&gt;+( getB_1 $ forcen 3  expTB_22 )  &lt;bah&gt;+( getB_1 $ forcen 4  expTB_22 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_22 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_22 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_22 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_22 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_22 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_22 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_23 )  &lt;bah&gt;+( getB_1 $ forcen 1  expTB_23 )  &lt;bah&gt;+( getB_1 $ forcen 2  expTB_23 )  &lt;bah&gt;+( getB_1 $ forcen 3  expTB_23 )  &lt;bah&gt;+( getB_1 $ forcen 4  expTB_23 )  &lt;bah&gt;+( getB_1 $ forcen 5  expTB_23 )  &lt;bah&gt;+( getB_1 $ forcen 6  expTB_23 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_23 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_23 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_23 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_23 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_24 )  &lt;bah&gt;+( getB_1 $ forcen 1  expTB_24 )  &lt;bah&gt;+( getB_1 $ forcen 2  expTB_24 )  &lt;bah&gt;+( getB_1 $ forcen 3  expTB_24 )  &lt;bah&gt;+( getB_1 $ forcen 4  expTB_24 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_24 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_24 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_24 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_24 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_24 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_24 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_25 )  &lt;bah&gt;+( getB_1 $ forcen 1  expTB_25 )  &lt;bah&gt;+( getB_1 $ forcen 2  expTB_25 )  Prelude.undefined+( getB_1 $ forcen 3  expTB_25 )  Prelude.undefined+( getB_1 $ forcen 4  expTB_25 )  Prelude.undefined+( getB_1 $ forcen 5  expTB_25 )  Prelude.undefined+( getB_1 $ forcen 6  expTB_25 )  Prelude.undefined+( getB_1 $ forcen 7  expTB_25 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_25 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_25 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_25 )  Prelude.undefined+( getB_1 $ forcen 0  expTB_26 )  &lt;bah&gt;+( getB_1 $ forcen 1  expTB_26 )  &lt;bah&gt;+( getB_1 $ forcen 2  expTB_26 )  &lt;bah&gt;+( getB_1 $ forcen 3  expTB_26 )  &lt;bah&gt;+( getB_1 $ forcen 4  expTB_26 )  &lt;bah&gt;+( getB_1 $ forcen 5  expTB_26 )  &lt;bah&gt;+( getB_1 $ forcen 6  expTB_26 )  &lt;bah&gt;+( getB_1 $ forcen 7  expTB_26 )  Prelude.undefined+( getB_1 $ forcen 8  expTB_26 )  Prelude.undefined+( getB_1 $ forcen 9  expTB_26 )  Prelude.undefined+( getB_1 $ forcen 10 expTB_26 )  Prelude.undefined+++Testing SOP rnfpDyn with SYB generic stop condition.++Float+WR+BBB 3.4+[Int]+WI+AAA +Bool+WI+AAA +7++Testing SOP/SYB rnfpDyn again.++[[Int]]+Noo-C+WI+Noo-C+AAA +[[[Int]]]+Noo-D+WI+Noo-D+AAA +6++Testing SOP rnfpDyn' with SOP generic stop condition.++*** :+WR+Testing SOP rnfpDyn'' with Typeable generic stop condition++[[Int]]+WI+AAA +[[[Int]]]+WI+AAA +7++Testing Seqable class (tuple with list):++===================================================+exp = &lt;refer to test code&gt;+get (_,xs,_) = show $ (xs!!2)+? = get $! exp+===================================================+1 expected value           = 7+1 actual value             = 7+---------------------------------------------------+2 expected value           = Prelude.undefined+2 actual value             = Prelude.undefined+---------------------------------------------------+3 expected value           = Prelude.undefined+3 actual value             = Prelude.undefined+---------------------------------------------------+4 expected value           = 7+4 actual value             = 7+---------------------------------------------------+5 expected value           = 7+5 actual value             = 7+---------------------------------------------------+6 expected value           = Prelude.undefined+6 actual value             = Prelude.undefined+---------------------------------------------------+7 expected value           = 7+7 actual value             = 7+---------------------------------------------------+8 expected value           = 7+8 actual value             = 7+---------------------------------------------------+9 expected value           = 7+9 actual value             = 7+--------------------------------------------------++Testing Seqable class (nested tuples):++===================================================+exp = &lt;refer to test code&gt;+get (_,(_,x),_) = show x+? = get $! exp+===================================================+1 expected value           = 7+1 actual value             = 7+---------------------------------------------------+2 expected value           = 7+2 actual value             = 7+---------------------------------------------------+3 expected value           = Prelude.undefined+3 actual value             = Prelude.undefined+---------------------------------------------------+4 expected value           = Prelude.undefined+4 actual value             = Prelude.undefined+---------------------------------------------------+5 expected value           = Prelude.undefined+5 actual value             = Prelude.undefined+---------------------------------------------------+6 expected value           = 7+6 actual value             = 7+---------------------------------------------------+7 expected value           = Prelude.undefined+7 actual value             = Prelude.undefined+---------------------------------------------------+8 expected value           = 7+8 actual value             = 7+---------------------------------------------------+9 expected value           = Prelude.undefined+9 actual value             = Prelude.undefined+--------------------------------------------------++Testing generic Seqable (tuple with list):++===================================================+exp = &lt;refer to test code&gt;+get (_,xs,_) = show $ (xs!!2)+? = get $! exp+===================================================+1 expected value           = 7+1 actual value             = 7+---------------------------------------------------+2 expected value           = Prelude.undefined+2 actual value             = Prelude.undefined+---------------------------------------------------+3 expected value           = Prelude.undefined+3 actual value             = Prelude.undefined+---------------------------------------------------+4 expected value           = 7+4 actual value             = 7+---------------------------------------------------+5 expected value           = 7+5 actual value             = 7+---------------------------------------------------+6 expected value           = Prelude.undefined+6 actual value             = Prelude.undefined+---------------------------------------------------+7 expected value           = 7+7 actual value             = 7+---------------------------------------------------+8 expected value           = 7+8 actual value             = 7+---------------------------------------------------+9 expected value           = 7+9 actual value             = 7+--------------------------------------------------++Testing generic Seqable (expTJ_*):++===================================================+exp = J2 (1, J4 (__, K3 __ (J1 4.5))) __+get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f+? = get exp+===================================================+1 expected value           = 4.5+1 actual value             = 4.5+---------------------------------------------------+2 expected value           = Prelude.undefined+2 actual value             = Prelude.undefined+---------------------------------------------------+3 expected value           = 4.5+3 actual value             = 4.5+---------------------------------------------------+4 expected value           = Prelude.undefined+4 actual value             = Prelude.undefined+---------------------------------------------------+5 expected value           = Prelude.undefined+5 actual value             = Prelude.undefined+---------------------------------------------------+6 expected value           = Prelude.undefined+6 actual value             = Prelude.undefined+--------------------------------------------------++Testing PatNodeAttrs (pattern node attributes):++===================================================+exp = G2 5 __ 7 :: TG+get (G2 _ _ n) = n+? = get $ forcep patstr exp+===================================================+patstr                   = ^^!+showPat.compilePat       = compilePat: input not completely consumed+Input remaining: ^^!+Patterns so far parsed: []+---------------------------------------------------+patstr                   = ^=^!+showPat.compilePat       = compilePat: input not completely consumed+Input remaining: ^=^!+Patterns so far parsed: []+---------------------------------------------------+patstr                   = =*+showPat.compilePat       = =*+expected value           = Prelude.undefined+actual value             = 7+---------------------------------------------------+patstr                   = +*+showPat.compilePat       = +*+expected value           = Prelude.undefined+NFDataP: TRACE: 0 TG+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = ^*+showPat.compilePat       = ^*+expected value           = Prelude.undefined+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = +^!+showPat.compilePat       = +^!+expected value           = 7+NFDataP: TRACE: 0 TG+actual value             = 7+---------------------------------------------------+patstr                   = +^*+showPat.compilePat       = +^*+expected value           = Prelude.undefined+NFDataP: TRACE: 0 TG+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = +^(.!.)+showPat.compilePat       = +^(.!.)+expected value           = Prelude.undefined+NFDataP: TRACE: 0 TG+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = ^+()+showPat.compilePat       = +^()+expected value           = 7 (due to pattern-match failure)+actual value             = 7+---------------------------------------------------+patstr                   = ^+(!!)+showPat.compilePat       = +^(!!)+expected value           = 7 (due to pattern-match failure)+actual value             = 7+---------------------------------------------------+patstr                   = ^+(!!!)+showPat.compilePat       = +^(!!!)+expected value           = Prelude.undefined+NFDataP: TRACE: 0 TG+actual value             = Prelude.undefined+---------------------------------------------------+patstr                   = ^+(!!!!)+showPat.compilePat       = +^(!!!!)+expected value           = 7 (due to pattern-match failure)+actual value             = 7+--------------------------------------------------++Testing PatNodeAttrs (pattern node attributes):++===================================================+exp = (([0..999999],[1000000..1999999]),[2000000..3999999])+get ((xs,ys),zs) = show ((last xs,last ys),last zs)+? = get $ forcep patstr exp+===================================================+patstr                   = +( +&gt;ba(+*+*)=+*)+showPat.compilePat       = +(&gt;ba+(+*+*)=+*)+expected value           = ((999999,1999999),3999999)+NFDataP: TRACE: 0 (([Int],[Int]),[Int])+NFDataP: TRACE: 1 ([Int],[Int])+NFDataP: TRACE: 3 [Int]+NFDataP: TRACE: 2 [Int]+NFDataP: TRACE: 4 [Int]+actual value             = ((999999,1999999),3999999)+---------------------------------------------------+patstr                   = +(=+&gt;ba(+*+*) +*)+showPat.compilePat       = +(=&gt;ba+(+*+*)+*)+expected value           = ((999999,1999999),3999999)+NFDataP: TRACE: 0 (([Int],[Int]),[Int])+NFDataP: TRACE: 1 ([Int],[Int])+NFDataP: TRACE: 4 [Int]+actual value             = ((999999,1999999),3999999)+--------------------------------------------------+++FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!++                                          ### Failure in: All:0+expected: 0+ but got: 1+Cases: 1  Tried: 1  Errors: 0  Failures: 1+*** Exception: ExitFailure 1+<span style="color: #00F; font-weight: bold;">&gt;&gt;</span> ^D+Leaving GHCi. </pre> </body> </html>
+ HTML/transition-5-6-7.html view
@@ -0,0 +1,106 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">+<html>+<head>+<title>Pattern DSL for deepseq-bounded</title>+<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate" />+<meta http-equiv="Pragma" content="no-cache" />+<meta http-equiv="Expires" content="0" />+<link rel="stylesheet" href="style.css" />+<style>+tt { background: transparent; font-size: 90%; }+</style>+</head>++<body>++<!--div class="main"-->+<div class="main" style="font-size: 16pt;">++<h3 style="margin-top: 50px;">deepseq-bounded 0.5 &rarr; 0.6 (and plans for 0.7)</h3>++<p style="margin-top: 10px;">+This document accompanies the release of deepseq-bounded-0.6.0.0, which makes some API breaking changes.+Only changes which are API breaking are discussed here.+(Refer to the <a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/changelog">changelog</a> and <a href="http://www.fremissant.net/deepseq-bounded">homepage</a> documents for more information, in addition to more specific documents cited below.)+<p>+Nobody seems to care at the moment (just as well in flux of nascency), but I feel somehow morally obligated to provide this library, and ill-documented software is shoddy, how ever-miraculously the fancy types fit together. <b><tt style="letter-spacing: -5px;">`^</tt><tt style="letter-spacing: -4px;">&#546;(</tt></b>+<!--(If they really only fit together in one way that makes sense, there should be one exposed function, one entrypoint to this inevitable confluence of the puzzle pieces you call an API. If there are multiple ways, it's certainly time for individual verbal explanations, <em>i.e.</em> documentation.)--><!--not really; and no library in particular; but I'm sure many people feel this way regularly in the "Haskell Ecosystem"-->++<p>+API breaking changes consist of module renamings, pattern DSL syntax tweaks, and <tt>PatNode</tt> data type changes.+Also there are some new flags, and the roles of certain flags have changed slightly.+Please refer to the <tt>deepseq-bounded.cabal</tt> <a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0#flags">package description</a> for flag documentation, including remarks about changes and deprecation.++<p>+There is a flag (<tt>NEW_IMPROVED_PATTERN_GRAMMAR</tt>, True by default) which, set to False, will restore the old pattern syntax of version 0.5.*, while still allowing you to enjoy bug fixes and code improvements since version 0.5.5, and continuing as version 0.6 progresses towards 0.7.+<p>+However, in the version 0.7 release this compatibility flag will likely be removed, so please try to avoid reliance on the flags characterised as deprecated...++<p>+Finally a mention is in order, that at least fifteen new modules were necessary to organise the support for both old and new grammars and <tt>PatNode</tt> definitions.+It seems I've managed not to expose any in the API however!+(Wasn't the case in the first draft of this paragraph; come to think of it, it was this paragraph that spurred me to un-expose the three that were still exposed...).+These transient internal modules will be gone in 0.7.++<h3 style="margin-top: 30px;">API breaking changes in 0.5.5 -&gt; 0.6.0.0</h3>++<ul>+<li> Module renamings (all are prefixed <tt>Control.DeepSeq.Bounded</tt>):+  <ul>+  <li> <tt>Generics</tt> &rarr; <tt>Generic</tt>+  <li> (and <tt>Generics.*</tt> &rarr; <tt>Generic.*</tt>)+  <li> <tt>PatAlg</tt> &rarr; <tt>PatUtil</tt>&nbsp;&nbsp;(also&nbsp;&nbsp;<tt>isSubPatOf</tt> &rarr; <tt>subPat</tt>)+  </ul>+<li> Changed the pattern grammar considerably, for a number of benefits.+     Refer to <a href="http://fremissant.net/deepseq-bounded/grammar.html">this document</a> for details of the old and new grammars, and some discussion.++<li> Changed+<a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html:t:PatNode"><tt>PatNode</tt></a>+(compare <a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html:t:PatNode">version 5</a> <tt>PatNode</tt>)+so that constructors all take a single parameter of (new) type <a href="http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Pattern.html:t:PatNodeAttrs"><tt>PatNodeAttrs</tt></a>.  This simplified the <tt>PatNode</tt> type itself, which is more uniform, and has fewer constructors (and will have even fewer by version 0.7).+</ul>++<h3 style="margin-top: 30px;">Related changes planned for 0.7.0.0 <span style="font-size: 80%; font-weight: normal;">(ETA early March)</span></h3>++<ul>+<li> The backwards compatibility flag <tt>NEW_IMPROVED_PATTERN_GRAMMAR</tt> will be removed, and only the new grammar will remain available.+<li> Also, the module structure will become simpler in consequence. At present, there are at lest fifteen extra modules, just to organise the support for both old and new grammars and <tt>PatNode</tt> definitions.+<li> The flag <tt>PARALLELISM_EXPERIMENT</tt> is only used in the old grammar code, and will be removed as well (<tt>USE_PAR_PATNODE</tt> is the equivalent in the new grammar, along with a half dozen other new capabilities).+<li> Type-constrained <tt>PatNode</tt>'s, and the type-reflective <tt>NFDataPDyn</tt> facilities, will become stabilised -- at present, these are quite experimental, and haven't recevied much attention because <a href="http://hackage.haskell.org/package/seqaid">seqaid</a> provides a more powerful approach. But if the features are to stay in deepseq-bounded at all, they should be finished properly...+<li> In particular, the type-constrained <tt>PatNode</tt>'s <tt>TI</tt>, <tt>TR</tt>, <tt>TN</tt> and <tt>TW</tt> will be obsoleted, with type constraints being handled just like any other attribute (<tt>PatNodeAttrs</tt>) of the <tt>PatNode</tt>. The urge to do this will probably be the main push bumping to 0.7, but the refactoring is a big one and I don't want to rush it for 0.6 (which already feels overdue to me).+<li> Also, 0.6.0.*, if built with <tt>HASKELL98_FRAGMENT</tt> True, lacks pattern DSL facilities (except <tt>showPat</tt>). This is because attoparsec is not H98. There will be an H98 alternative parser again soon, probably by version 0.6.1.0.+</ul>++<p>+There will be other changes for 0.7 (probably a few API breaking), but whatever they will be, they're probably independent of the changes we're focused on for the bump 0.5 &rarr; 0.6.  Possibly this document will be evolved to cover those changes too, as well as non-API-breaking changes that are ongoing...++<div class="footer" style="margin-top: 30px;">+Andrew Seniuk+<br>+Jan. 15, 2014+<br>+<tt>rasfar@gmail.com</tt>+</div>++</div>++<script language="javascript">+function toggle(id1){+  var ele_s = document.getElementById(id1+"s");+  var ele_h = document.getElementById(id1+"h");+  var ele = document.getElementById(id1);+  if( ele.style.display == "inline-block" ){+    ele.style.display = "none";+    ele_s.style.display = "inline-block";+    ele_h.style.display = "none";+  }else{+    ele.style.display = "inline-block";+    ele_s.style.display = "none";+    ele_h.style.display = "block";+  }+}+</script>++</body>+</html>+
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014, Andrew G. Seniuk+Copyright (c) 2014-2015, Andrew G. Seniuk  All rights reserved.
+ cafe-and-glasgow-users-0.6.txt view
@@ -0,0 +1,37 @@++Subject:++ANN: deepseq-bounded 0.5 -> 0.6++Body:++This may affect depending code. Please consult the distro changelog+for specific information about how your code might be affected, or+better yet, refer to++  http://www.fremissant.net/deepseq-bounded/transition-5-6-7.html++and++  http://www.fremissant.net/deepseq-bounded/grammar.html++This is a transitional version of deepseq-bounded, with stability+of the grammar expected in early March for version 0.7.++This also causes major version bumps to the seqaid and leaky packages.+To update everything, issue++  cabal update+  cabal install --reinstall --force-reinstalls seqaid++which reinstalls the latest deepseq-bounded in passing. And also+if you were to run "seqaid demo" it will use the updated version+of leaky, so everything's up to date.++The homepage for these projects starts at++  http://www.fremissant.net/deepseq-bounded-seqaid-leaky.html++Kind Regards,+Andrew+
+ changelog.txt view
@@ -0,0 +1,38 @@++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.5.5 -> 0.6.0.0+ - many misc. bug fixes+ - much polishing of documentation (corrections, elaborations, refinements)+ - renamed module "...Bounded.Generics" to "...Bounded.Generic"+ - changed the pattern concrete syntax slightly (now more compact)+    - refer to http://fremissant.net/deepseq-bounded/grammar.html+    - more than "slightly", in the end!+ - added nice data family FF :)+ - changed PatNode so all constructors take a single parameter of+   (new) type PatNodeAttrs+ - several new capabilities (refer to the API docs for PatNodeAttrs)+ - simplified the PatNode type itself+ - using attoparsec to build the pattern DSL parser+ - PatAlg.hs -> PatUtil.hs+ - isSubPatOf -> subPat+    - I hesitated to shed the "is", but the Bool result value+      pretty much clears up any possible ambiguity there+    - the ambiguity (which still remains) is, which is the+      subpattern, which the host pattern, as the types don't+      help you there!+       - but we're pretty safe, corresponds to infix use as+         if it were the mathematical inclusion symbol+ - type constraints are now handled as a prefix modifier like+   any other (except that internally they still have their+   own PatNode's TI, TR etc.)+ - more...+
+ deepseq-bounded-seqaid-leaky.css view
@@ -0,0 +1,34 @@++pre { font-size: 14pt; margin-left: 20px; padding-left: 10px; padding-right: 10px; padding-top: 10px; padding-bottom: 10px; background-color: rgba(230,230,230,1.0); }+tt { padding-left: 2px; padding-right: 2px; font-size: 100%; background-color: rgba(220,220,220,0.5); }+tt.virgin { padding-left: 0px; padding-right: 0px; font-size: 100%; background-color: transparent; }+/* Works, but not nicely:+red { color: #f00; }+*/+.red { color: #f00; }+div.outdated { display: inline-block; padding-left: 2px; padding-right: 2px; padding-top: 2px; font-size: 80%; background-color: #EEC; }+div.digression { display: none; padding: 8px 8px 8px 8px; font-size: 80%; background-color: #EDD; }+div.digression-closed { display: inline-block; padding: 8px 8px 8px 8px; font-size: 80%; background-color: #EDD; }+.dig-toggle-show { outline: 0; text-decoration: none; color: #33E; display: inline-block; padding: 8px 8px 8px 8px; font-size: 11pt; background-color: #EDD; }+.dig-toggle-hide { outline: 0; text-decoration: none; color: #33E; display: inline-block; padding: 0px 0px 4px 0px; font-size: 11pt; background-color: #EDD; }+a { text-decoration: none; }+div.main { font-size: 16pt; margin-left: 10px; margin-right: 100px; margin-bottom: 40px; }+h2 { margin-top: 30px; color: #777; }+h3 { margin-top: 30px; color: #444; }+h4 { margin-top: 40px; color: #222; }+div.comments { font-family: sans; font-size: 80%; margin-top: 40px; }+div.footer { font-family: sans; font-size: 80%; margin-top: 40px; }+div.footer > tt { font-size: 90%; }+/*+table.table { text-align: top; vertical-align: top; }+table.table > tr { text-align: top; vertical-align: top; }+table.table > tr > td { text-align: top; vertical-align: top; }+*/+/* table { border-collapse: collapse; } */+tr { text-align: top; vertical-align: top; }+td { text-align: top; vertical-align: top; padding-left: 8px; padding-top: 16px; }+li { margin-top: 4px; }+.nowrap { white-space: nowrap; }++tt { background: transparent; }+
+ deepseq-bounded-seqaid-leaky.html view
@@ -0,0 +1,89 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">+<html>+<head>+<title>Seqaid : Space leak diagnostic and remedial tool</title>+<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate" />+<meta http-equiv="Pragma" content="no-cache" />+<meta http-equiv="Expires" content="0" />+<link rel="stylesheet" href="deepseq-bounded-seqaid-leaky.css" />+</head>+<body>+<!--body style="width: 800px;"-->++<div class="main">++<h2 style="margin-top: 50px; color: #555;">deepseq-bounded, seqaid, leaky</h2>++This trio of related packages explores strictness control in a variety of ways.++<p>+<a href="http://www.fremissant.net/deepseq-bounded">deepseq-bounded</a> provides classes and generic functions to artificially force evaluation, to extents controlled by static or dynamic configuration.++<p>+<a href="http://www.fremissant.net/seqaid">seqaid</a> puts that into practise, providing a GHC plugin to auto-instrument your package with a strictness harness, which is dynamically optimisable during runtime.+This is supported directly in the GHC compilation pipeline, without requiring (or performing!) any edits to your sources.++<p>+<a href="http://www.fremissant.net/leaky">leaky</a> is a minimal, prototypic executable that leaks space under current <span class="nowrap">state-of-the-art</span> compilation (even with <span class="nowrap">-O2 GHC <a href="https://downloads.haskell.org/~ghc/7.10.1-rc1/">7.10.1-rc1</a></span>; but certainly <span class="nowrap">with -O2 GHC 7.8.*</span>).++<p>+On hackage.haskell.org:+<ul>+<li> <a href="https://hackage.haskell.org/package/deepseq-bounded">deepseq-bounded</a>+<li> <a href="https://hackage.haskell.org/package/seqaid">seqaid</a>+<li> <a href="https://hackage.haskell.org/package/leaky">leaky</a>+</ul>++<p>+I've started a <a href="http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/">reddit discussion</a> page for the three together.++<p>+Easiest way to try them all, is to install seqaid and run the demo:++<pre>+  cabal install seqaid+  seqaid demo+</pre>++<p>+This tests seqaid on a local copy of the leaky source package.++<p>+It turned out to be routine to extend deepseq-bounded and seqaid to dynamically configurable parallelisation (paraid?).+Many other wrappers could be explored, too!+Maybe seqaid should be renamed to koolaid or something...++<p>+It's a pretty complicated system, and just first release, so there's bound to be lots of problems.+For now, any issues or comments can be directed to the reddit page (or private email).+There's also the list announcement threads on <tt>haskell-cafe</tt> and <tt>glasgow-haskell-users</tt> for general discussion, and on <tt>ghc-devs</tt> for technical.+I'll maintain a <a href="http://www.fremissant.net/seqaid/trac">casual list</a> of bugs and feature requests, and will set up a proper tracker if there's interest.++<div class="footer" style="margin-top: 40px;">+Andrew Seniuk 2014+<br>+<tt>rasfar@gmail.com</tt>+</div>++</div>++<script language="javascript">+function toggle(id1){+  var ele_s = document.getElementById(id1+"s");+  var ele_h = document.getElementById(id1+"h");+  var ele = document.getElementById(id1);+  if( ele.style.display == "inline-block" ){+    ele.style.display = "none";+    ele_s.style.display = "inline-block";+    ele_h.style.display = "none";+  }else{+    ele.style.display = "inline-block";+    ele_s.style.display = "none";+    ele_h.style.display = "block";+  }+}+</script>++</body>+</html>+
deepseq-bounded.cabal view
@@ -1,61 +1,73 @@ +-------------------------------------------------------------------------------+ name:		deepseq-bounded-version:        0.5.5+version:        0.6.0.0 synopsis:       Bounded deepseq, including support for generic deriving-homepage:       http://fremissant.net/deepseq-bounded license:	BSD3 license-file:	LICENSE author:         Andrew G. Seniuk maintainer:     Andrew Seniuk <rasfar@gmail.com>+homepage:       http://fremissant.net/deepseq-bounded bug-reports:    http://fremissant.net/deepseq-bounded/trac ---bug-reports:    Andrew Seniuk <rasfar@gmail.com> category:       Control build-type:     Simple-cabal-version:  >=1.10-tested-with:    GHC==7.6.3, GHC==7.8.1, GHC==7.8.3 stability:      provisional-extra-source-files:     README-                      , test/*.hs-                      , HTML/*.html-                      , HTML/*.css+cabal-version:  >= 1.10++-- GHC <= 7.4.2 won't work, unless you're also HASKELL98_FRAGMENT+-- (or at least USE_SOP is False).+tested-with:    GHC==7.6.3, GHC==7.8.1, GHC==7.8.3, GHC==7.8.4, GHC==7.10.1+--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\").     .-    More information is available on the project <http://www.fremissant.net/deepseq-bounded homepage>. There may be activity on this <http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/ reddit> discussion, where your comments are invited.+    More information is available on the project <http://www.fremissant.net/deepseq-bounded homepage>.+    There may be activity on this <http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/ reddit> discussion, where your comments are invited.     .     Quoting comments from the-    <https://hackage.haskell.org/package/deepseq deepseq> package:+    <http://hackage.haskell.org/package/deepseq deepseq> package:     .     \"/Artificial forcing is often used for adding strictness to a program, e.g. in order to force pending exceptions, remove space leaks, or force lazy IO to happen. It is also useful in parallel programs, to ensure work does not migrate to the wrong thread./\"     .-    Sometimes we don't want to, or cannot, force all the way.-    Any infinite recursive type is an example. Also, bounded forcing-    bridges the theoretical axis between shallow seq and full deepseq.+    Sometimes we don't want to, or cannot, force all the way, for instance+    when dealing with potentially infinite values of coinductive types.+    Also, bounded forcing bridges the theoretical axis between shallow seq+    and full deepseq.     .-    We provide two new classes "NFDataN" and "NFDataP". Instances of these-    provide bounded deep evaluation for arbitrary polytypic terms:+    We provide two new classes <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataN.html#t:NFDataN NFDataN> and <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP NFDataP>.+    Instances of these provide bounded deep evaluation for arbitrary polytypic terms:     .-    * 'rnfn' bounds the forced evaluation by depth of recursion.+    * <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataN.html#t:NFDataN rnfn> bounds the forced evaluation by depth of recursion.     .-    * 'rnfp' forces based on patterns (static or dynamic).+    * <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> forces based on patterns (static or dynamic).     .-    Instances of "NFDataN" and "NFDataP" can be automatically derived via-    "Generics.SOP", backed by the "GNFDataN" and "GNFDataP" modules.+    Instances of <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataN.html NFDataN> and <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html NFDataP> can be automatically derived via <http://hackage.haskell.org/package/generics-sop/docs/Generics-SOP.html Generics.SOP>, backed by the <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Generic-GNFDataN.html GNFDataN> and <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Generic-GNFDataP.html GNFDataP> modules.+    <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataN.html NFDataN> can optionally be derived by the standard <http://downloads.haskell.org/~ghc/7.8.3/docs/html/libraries/base-4.7.0.1/GHC-Generics.html GHC.Generics> facility (but not so for <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html NFDataP>).     .-    Another approach is "Seqable", which is similar to "NFDataN",+    Another approach is <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Seqable.html Seqable>, which is similar to <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataN.html NFDataN>,     but optimised for use as a dynamically-reconfigurable forcing harness-    in the <https://hackage.haskell.org/package/seqaid seqaid> auto-instrumentation tool.+    in the <http://hackage.haskell.org/package/seqaid seqaid> auto-instrumentation tool.     .-    Recent developments supporting parallelisation control (in "Pattern"-    and "Seqable" modules) may justify renaming this library to-    something which emcompasses both strictness and parallelism aspects.+    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. ---  "NFDataN" can optionally be derived by the standard "GHC.Generics"---  facility (but not so for "NFDataP").+extra-source-files:+      README+    , changelog.txt+    , tests/*.hs+    , HTML/*.html+    , HTML/*.css+    , deepseq-bounded-seqaid-leaky.html+    , deepseq-bounded-seqaid-leaky.css+    , cafe-and-glasgow-users-0.6.txt --- extra-source-files: changelog---  -- source-repository head --   type:     git --   location: https://www.fremissant.com/package/deepseq-bounded.git@@ -63,20 +75,71 @@ -- source-repository this --   type:     git --   location: https://www.fremissant.com/package/deepseq-bounded.git---   tag:      deepseq-bounded-0.5.0-release+--   tag:      deepseq-bounded-0.6.0-release +-------------------------------------------------------------------------------++Flag HELLO_HACKAGE_VISITOR+  Description: [Note to those reading on Hackage:] Please ignore these flags, which would be better presented in a collapsed state. The flags are mostly for development purposes.+  Default:     False+ Flag HASKELL98_FRAGMENT-  Description: Sacrifice generic deriving, the NFDataPDyn module, and a couple functions from the PatAlg module, in exchange for true Haskell98 conformance (portability). You need to set PARALLELISM_EXPERIMENT, USE_WW_DEEPSEQ, USE_SOP, and NFDATA_INSTANCE_PATTERN to False if you set HASKELL98_FRAGMENT to True. (One thing it insists on is -XPatternGuards, although this could be relieved in the obvious way...)+  Description: Sacrifice generic deriving, the NFDataPDyn module, and a couple functions from the PatUtil module, in exchange for true Haskell98 conformance (portability). (One non-H98 thing it insists on is PatternGuards, although this could be relieved in the obvious way, at the expense of code clarity.) --Default:     True   Default:     False +Flag USE_PAR_PATNODE+  Description: On match, spark recursive submatching for parallel evaluation.+  Default:     True+--Default:     False++Flag USE_PSEQ_PATNODE+  Description: On match, use Control.Parallel.pseq to order the evaluation of recursive submatching. This is done by providing a permutation argument; refer to the PatNode for additional documentation.+  Default:     True+--Default:     False++Flag USE_TRACE_PATNODE+  Description: On match, log a traceline to stderr en passant.+  Default:     True+--Default:     False++Flag USE_PING_PATNODE+  Description: On match success and/or match failure, raise an asynchronous exception en passant. This can be useful for gauging term shape relative to pattern shape, dynamically.+  Default:     True+--Default:     False++Flag USE_DIE_PATNODE+  Description: On match, kill (just this) thread immediately. To kill the whole program from a pattern node match, use USE_PING_PATNODE, catch the exception in the main thread, and respond from there as you see fit.+  Default:     True+--Default:     False++Flag USE_TIMING_PATNODE+  Description: On match, get as precise a measurement of the time of matching as possible, and optionally (depending on how you use the API) measuring and reporting (storing?) differential timestamps (relative to parent node already matched). Not sure how useable this will be (the timestamps need to be very high resolution and cheap enough to obtain), but the principle has its place here, and the flag makes it possible to exclude all this code in case it's not working out.+  Default:     True+--Default:     False++Flag USE_PAR_SEQABLE+  Description: This flag (now) only affects Seqable. (Refer to USE_PAR_PATNODE for a comparable flag affecting NFDataP.) USE_PAR_SEQABLE = True depends on parallel, and permits (dynamically configurable) sparking of Sequable recursive demand propagation.+  Default:     True+--Default:     False+ Flag PARALLELISM_EXPERIMENT-  Description: We can selectively use par instead of seq, which is interesting.+  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 --- Flag SEQUENTIALISM_EXPERIMENT---   Description: We can selectively use pseq instead of seq, which is interesting. (This is more difficult to implement (usefully) than PARALLELISM_EXPERIMENT, and was left on hold for now.)+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++Flag USE_ATTOPARSEC+  Description: When True, depend on and use attoparsec for implementing the Pattern parser. (Probably, this flag will be removed in 0.7, becoming effectively always True.) Unfortunately, attoparsec also requires text, so if you're building in a sandbox this will account for most of your initial build time, but it's a one-time cost.+  Default:     True+--Default:     False++-- Flag DEPTH_USES_INT64+--   Description: This won't be implemented for a while, probably. -- --Default:     True --   Default:     False @@ -85,6 +148,62 @@   Default:     True --Default:     False +Flag JUST_ALIAS_GNFDATAN+  Description: The SOP generic function is probably more performant, anyway! (This will be forced False if HASKELL98_FRAGMENT is True.)+--Default:     True+  Default:     False++Flag JUST_ALIAS_GNFDATAP+  Description: The SOP generic function is probably more performant, anyway! (This will be forced False if HASKELL98_FRAGMENT is True.)+--Default:     True+  Default:     False++Flag PROVIDE_DATA_FAMILY+  Description: Provide a data family comprising instances corresponding to the Seqable, NFDataN and NFDataP modules. (This will be forced False if HASKELL98_FRAGMENT is True.)+  Default:     True+--Default:     False++Flag USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+  Description: Choose grouping convention (concrete syntax) for pattern strings in the DSL. When True, you have "XX.*Y..Y" instead of the (new) default "((.*)..)". Where X=opening curly brace, and Y=closing curly brace - it seems Cabal makes it impossible to present a curly brace in a flag description, even escaped? Unless Unicode entities? &#123; \u007D &#x7d; Nope.+--Default:     True+  Default:     False++Flag NEW_SEMICOLON_TYPE_LIST+  Description: Instead of displaying # for WI and TI nodes, just show a space. Later: Prefer to let whitespace be freeform, except where parsing attribute substrings like numbers, type names, ... Definitely looks better in the HTML with the hash dimmed down, though!+  Default:     True+--Default:     False++Flag NEW_CONCRETE_WI_AND_WS+  Description: Use . instead of # for WI and TI nodes, and use ! instead of . for WS nodes. WS nodes are being considered for deprecation, but it is nice to be able to type a single character (instead of the available equivalent, *1) for them.+  Default:     True+--Default:     False++Flag ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19+  Description: So you can write "2(!53)" instead of "*2(!*5*3)". This will be unambiguous up to a depth of 19. (It may still be unambiguous for higher depths, depending on the use case.) This could be convenient if you work a lot manually with the pattern DSL, particularly for vertical alignment of pattern structures, but otherwise it should be False as ambigities can develop, for instance under (showPat . shrinkPat . compilePat) iteration.+---Default:     True+  Default:     False++Flag ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+  Description: Similar to the preceding, but use "1" instead of "!" for depth-1, and moreover, use "0" instead of "." for depth-0.  (This is such a niche-case syntax variant, that may as well go all the way!)  It makes for very tidy when you're not using a lot of other attributes. This grammar variant is unambiguous; the danger here is only that conventions get mixed in practise...+---Default:     True+  Default:     False++Flag VACANT_HASH+  Description: Instead of using # for WI and TI nodes, just show a space. (Parser continues to accept both.) Later: Prefer to let whitespace be freeform, except where parsing attribute substrings like numbers, type names, ... Definitely looks better in the HTML with the hash dimmed down, though!+--Default:     True+  Default:     False++-- This takes the cake as longest CPP name I've ever coined (even in jest!)+Flag TYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR+  Description: Quick hack; ought to be handled with NEW_IMPROVED_PATTERN_GRAMMAR, arguably. When False, the separator is a single colon character. Colon will likely become the only separator in 0.7.+--Default:     True+  Default:     False++Flag PROVIDE_OLD_SHRINK_PAT+  Description: Provide shrinkPat_old temporarily, for compatibility of seqaid demo output with documents already written. This flag (and the shrinkPat_old function) will probably be removed in 0.7.+  Default:     True+--Default:     False+ Flag USE_WW_DEEPSEQ   Description: Depend on deepseq and deepseq-generics, to provide conditional deep forcing. This is optional.   Default:     True@@ -96,7 +215,7 @@   Default:     False  Flag USE_SOP-  Description: Use the generics-sop package instead of GHC.Generics (in GNFDataN) and instead of SYB (in NFDataPDyn). If USE_SOP is False, and NFDataPDyn, GNFDataP, and GSeqable modules will not be available. Also, if USE_SOP is False, then JUST_ALIAS_GSEQABLE must be False (this is not done for you; the language of Cabal flags makes it hard to write such logic, probably by design!...).+  Description: Use the generics-sop package instead of GHC.Generics (in GNFDataN) and instead of SYB (in NFDataPDyn). If USE_SOP is False, then NFDataPDyn, GNFDataP, and GSeqable modules will not be available.   Default:     True --Default:     False @@ -105,8 +224,12 @@   Default:     True --Default:     False +-------------------------------------------------------------------------------+ library { +  build-tools: cpphs+   hs-source-dirs: src    -- This library is Haskell98 if you exclude the generics bits.@@ -118,7 +241,7 @@    default-extensions:  CPP --- If you exclude PatAlg.mkPat and PatAlg.growPat (which use SYB),+-- If you exclude PatUtil.mkPat and PatUtil.growPat (which use SYB), -- and NFDataPDyn, GNFDataN, and GNFDataP (which use GHC.Generics -- and/or Generics.SOP), none of the code depends in any essential -- way on language extensions. I use PatternGuards for convenience,@@ -136,49 +259,85 @@     , Control.DeepSeq.Bounded.Seqable     , Control.DeepSeq.Bounded.NFDataN     , Control.DeepSeq.Bounded.Pattern-    , Control.DeepSeq.Bounded.PatAlg+    , Control.DeepSeq.Bounded.Compile+    , Control.DeepSeq.Bounded.PatUtil     , Control.DeepSeq.Bounded.NFDataP   if ! flag(HASKELL98_FRAGMENT)      exposed-modules:-         Control.DeepSeq.Bounded.Generics-       , Control.DeepSeq.Bounded.Generics.GNFDataN+         Control.DeepSeq.Bounded.Generic+       , Control.DeepSeq.Bounded.Generic.GNFDataN      if flag(USE_SOP)         exposed-modules:-            Control.DeepSeq.Bounded.Generics.GNFDataP-          , Control.DeepSeq.Bounded.Generics.GSeqable+            Control.DeepSeq.Bounded.Generic.GNFDataP+          , 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+  ghc-options: -pgmPcpphs -optP--cpp+--ghc-options: -pgmP/usr/bin/cpp  --ghc-options:         -Wall -fenable-rewrite-rules    -ddump-rules -ddump-simpl-stats -ddump-rule-firings --ghc-options:         -Wall -fenable-rewrite-rules   ghc-options:         -fenable-rewrite-rules    --ghc-options:         -fenable-rewrite-rules -O2 +  ghc-options:         -fno-warn-duplicate-exports+   build-depends:        base == 4.* --- , base == 4.7.0.1 +    , cpphs >= 1.14+     , array == 0.5.*      , random == 1.1 +      -- mtl for State so can assign unique IDs to Pattern nodes,+      -- 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+   if ! flag(HASKELL98_FRAGMENT)      build-depends:-         syb <= 0.4.2+         syb < 0.5    -- deepseq not used for any legitimate reason, unless USE_WW_DEEPSEQ;   -- but it's used in some debugging and testing code (although probably   -- shouldn't be), so the dep stays for now:   build-depends:-      deepseq == 1.3.*---    deepseq >= 1.2.0.1 && < 1.4+      deepseq == 1.3.* || == 1.4.*    if flag(USE_WW_DEEPSEQ)      build-depends:-         deepseq == 1.3.*---       deepseq >= 1.2.0.1 && < 1.4+         deepseq == 1.3.* || == 1.4.*      if ! flag(HASKELL98_FRAGMENT)         build-depends:             deepseq-generics == 0.1.*@@ -186,6 +345,49 @@   else      cpp-options: -DUSE_WW_DEEPSEQ=0 +  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(NEW_SEMICOLON_TYPE_LIST)+     cpp-options: -DNEW_SEMICOLON_TYPE_LIST=1+  else+     cpp-options: -DNEW_SEMICOLON_TYPE_LIST=0++  if flag(NEW_CONCRETE_WI_AND_WS)+     cpp-options: -DNEW_CONCRETE_WI_AND_WS=1+  else+     cpp-options: -DNEW_CONCRETE_WI_AND_WS=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+  else+     cpp-options: -DABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19=0++  if flag(ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9)+     cpp-options: -DABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9=1+  else+     cpp-options: -DABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9=0++  if flag(VACANT_HASH)+     cpp-options: -DVACANT_HASH=1+  else+     cpp-options: -DVACANT_HASH=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(TYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR)+     cpp-options: -DTYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR=1+  else+     cpp-options: -DTYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR=0+   if flag(WARN_PATTERN_MATCH_FAILURE)      cpp-options: -DWARN_PATTERN_MATCH_FAILURE=1   else@@ -201,75 +403,193 @@   else       cpp-options: -DUSE_SOP=0 +  -- XXX No attoparsec parser was built (yet, anyway) for the old grammar.+  if flag(NEW_IMPROVED_PATTERN_GRAMMAR)+   if ! flag(HASKELL98_FRAGMENT)+     if flag(USE_ATTOPARSEC)+        build-depends:+            -- attoparsec also brings in text (and a few other things)...+            -- probably too tight:+            attoparsec == 0.12.*+            -- probably too tight:+          , text == 1.2.*+            -- probably too tight:+          , bytestring == 0.10.*+   if flag(HASKELL98_FRAGMENT)      cpp-options: -DHASKELL98_FRAGMENT=1   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(NEW_IMPROVED_PATTERN_GRAMMAR)+   if ! flag(HASKELL98_FRAGMENT)+     if flag(USE_ATTOPARSEC)+        cpp-options: -DUSE_ATTOPARSEC=1+     else+        cpp-options: -DUSE_ATTOPARSEC=0+   else+     cpp-options: -DUSE_ATTOPARSEC=0+  else+     cpp-options: -DUSE_ATTOPARSEC=0++--if flag(DEPTH_USE_INT64)+--   cpp-options: -DDEPTH_USE_INT64=1+--else+--   cpp-options: -DDEPTH_USE_INT64=0+   if flag(NFDATA_INSTANCE_PATTERN)      cpp-options: -DNFDATA_INSTANCE_PATTERN=1   else      cpp-options: -DNFDATA_INSTANCE_PATTERN=0 -  if flag(PARALLELISM_EXPERIMENT)-     build-depends:-         parallel == 3.2.*----if flag(SEQUENTIALISM_EXPERIMENT)---   build-depends:---       -- yes, really---       parallel == 3.2.*+  if ! flag(HASKELL98_FRAGMENT)+     if flag(USE_PAR_SEQABLE)+        build-depends:+            parallel == 3.2.*+        cpp-options: -DUSE_PAR_SEQABLE=1+     else+        cpp-options: -DUSE_PAR_SEQABLE=0+  else+     cpp-options: -DUSE_PAR_SEQABLE=0 -  if flag(PARALLELISM_EXPERIMENT)-     cpp-options: -DPARALLELISM_EXPERIMENT=1+  -- 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(SEQUENTIALISM_EXPERIMENT)---   cpp-options: -DSEQUENTIALISM_EXPERIMENT=1---else---   cpp-options: -DSEQUENTIALISM_EXPERIMENT=0+  if ! flag(HASKELL98_FRAGMENT)+     if flag(USE_PAR_PATNODE)+        build-depends:+            parallel == 3.2.*+        cpp-options: -DUSE_PAR_PATNODE=1+     else+        cpp-options: -DUSE_PAR_PATNODE=0+  else+     cpp-options: -DUSE_PAR_PATNODE=0 -  if flag(JUST_ALIAS_GSEQABLE)-     cpp-options: -DJUST_ALIAS_GSEQABLE=1+  if ! flag(HASKELL98_FRAGMENT)+     if flag(USE_PSEQ_PATNODE)+        build-depends:+            parallel == 3.2.*+        cpp-options: -DUSE_PSEQ_PATNODE=1+     else+        cpp-options: -DUSE_PSEQ_PATNODE=0   else+     cpp-options: -DUSE_PSEQ_PATNODE=0++  if flag(USE_TRACE_PATNODE)+     cpp-options: -DUSE_TRACE_PATNODE=1+  else+     cpp-options: -DUSE_TRACE_PATNODE=0+  -- (Not really H98, although Control.Concurrent is in GHC base...)+  if flag(USE_PING_PATNODE)+     cpp-options: -DUSE_PING_PATNODE=1+  else+     cpp-options: -DUSE_PING_PATNODE=0+  if flag(USE_DIE_PATNODE)+     cpp-options: -DUSE_DIE_PATNODE=1+  else+     cpp-options: -DUSE_DIE_PATNODE=0+  if flag(USE_TIMING_PATNODE)+     cpp-options: -DUSE_TIMING_PATNODE=1+  else+     cpp-options: -DUSE_TIMING_PATNODE=0++  if flag(HASKELL98_FRAGMENT)      cpp-options: -DJUST_ALIAS_GSEQABLE=0+     cpp-options: -DJUST_ALIAS_GNFDATAN=0+     cpp-options: -DJUST_ALIAS_GNFDATAP=0+     cpp-options: -DPROVIDE_DATA_FAMILY=0+  else+     if flag(PROVIDE_DATA_FAMILY)+        cpp-options: -DPROVIDE_DATA_FAMILY=1+     else+        cpp-options: -DPROVIDE_DATA_FAMILY=0+     if flag(USE_SOP)+        if flag(JUST_ALIAS_GSEQABLE)+           cpp-options: -DJUST_ALIAS_GSEQABLE=1+        else+           cpp-options: -DJUST_ALIAS_GSEQABLE=0+        if flag(JUST_ALIAS_GNFDATAN)+           cpp-options: -DJUST_ALIAS_GNFDATAN=1+        else+           cpp-options: -DJUST_ALIAS_GNFDATAN=0+        if flag(JUST_ALIAS_GNFDATAP)+           cpp-options: -DJUST_ALIAS_GNFDATAP=1+        else+           cpp-options: -DJUST_ALIAS_GNFDATAP=0+     else+        cpp-options: -DJUST_ALIAS_GSEQABLE=0+        cpp-options: -DJUST_ALIAS_GNFDATAN=0+        cpp-options: -DJUST_ALIAS_GNFDATAP=0 +--ghc-options: -O0+--ghc-options: -O2+ } +-------------------------------------------------------------------------------+ test-suite deepseq-bounded-tests { +  build-tools: cpphs+   if flag(HASKELL98_FRAGMENT)     default-language: Haskell98   else     default-language: Haskell2010    type:                exitcode-stdio-1.0-  hs-source-dirs:      test+  hs-source-dirs:      tests   main-is:             Suite.hs+  default-extensions:  CPP+   other-modules:       Tests, Foo   if flag(HASKELL98_FRAGMENT)      other-modules:       Blah98   else      other-modules:       Blah, Bottom, FooG-  default-extensions:  CPP+  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+  ghc-options: -pgmPcpphs -optP--cpp  --ghc-options:         -Wall -fenable-rewrite-rules -O -ddump-rules -ddump-simpl-stats -ddump-rule-firings --ghc-options:         -Wall -fenable-rewrite-rules -O --ghc-options:         -fenable-rewrite-rules -O-  ghc-options:         -fenable-rewrite-rules -O2+--ghc-options:         -fenable-rewrite-rules -O2    build-depends:       base == 4.* +    , cpphs >= 1.14+     , deepseq-bounded      , HUnit == 1.2.*     , random == 1.1 -    , template-haskell == 2.9.*+    , template-haskell >= 2.8 && <= 3    if ! flag(HASKELL98_FRAGMENT)      build-depends:@@ -278,19 +598,17 @@    if ! flag(HASKELL98_FRAGMENT)      build-depends:-         syb <= 0.4.2+         syb < 0.5    -- deepseq not used for any legitimate reason, unless USE_WW_DEEPSEQ;   -- but it's used in some debugging and testing code (although probably   -- shouldn't be), so the dep stays for now:   build-depends:-      deepseq == 1.3.*---    deepseq >= 1.2.0.1 && < 1.4+      deepseq == 1.3.* || == 1.4.*    if flag(USE_WW_DEEPSEQ)      build-depends:-         deepseq == 1.3.*---       deepseq >= 1.2.0.1 && < 1.4+         deepseq == 1.3.* || == 1.4.*      if ! flag(HASKELL98_FRAGMENT)          build-depends:              deepseq-generics == 0.1.*@@ -313,29 +631,141 @@   else      cpp-options: -DHASKELL98_FRAGMENT=0 -  if flag(PARALLELISM_EXPERIMENT)-     build-depends:-         parallel == 3.2.*+  if flag(WARN_PATTERN_MATCH_FAILURE)+     cpp-options: -DWARN_PATTERN_MATCH_FAILURE=1+  else+     cpp-options: -DWARN_PATTERN_MATCH_FAILURE=0 ---if flag(SEQUENTIALISM_EXPERIMENT)---   build-depends:---       -- yes, really---       parallel == 3.2.*+  if flag(NEW_IMPROVED_PATTERN_GRAMMAR)+     cpp-options: -DNEW_IMPROVED_PATTERN_GRAMMAR=1+  else+     cpp-options: -DNEW_IMPROVED_PATTERN_GRAMMAR=0 -  if flag(PARALLELISM_EXPERIMENT)-     cpp-options: -DPARALLELISM_EXPERIMENT=1+  if flag(USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS)+     cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=1   else-     cpp-options: -DPARALLELISM_EXPERIMENT=0+     cpp-options: -DUSE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS=0 ---if flag(SEQUENTIALISM_EXPERIMENT)---   cpp-options: -DSEQUENTIALISM_EXPERIMENT=1+  -- (Probably not actually referenced in the tests.)+  if flag(NEW_SEMICOLON_TYPE_LIST)+     cpp-options: -DNEW_SEMICOLON_TYPE_LIST=1+  else+     cpp-options: -DNEW_SEMICOLON_TYPE_LIST=0++  -- (Probably not actually referenced in the tests.)+  if flag(NEW_CONCRETE_WI_AND_WS)+     cpp-options: -DNEW_CONCRETE_WI_AND_WS=1+  else+     cpp-options: -DNEW_CONCRETE_WI_AND_WS=0++  -- (Probably not actually referenced in the tests.)+  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+  else+     cpp-options: -DABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19=0++  -- (Probably not actually referenced in the tests.)+  if flag(ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9)+     cpp-options: -DABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9=1+  else+     cpp-options: -DABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9=0++--if flag(DEPTH_USE_INT64)+--   cpp-options: -DDEPTH_USE_INT64=1 --else---   cpp-options: -DSEQUENTIALISM_EXPERIMENT=0+--   cpp-options: -DDEPTH_USE_INT64=0 -  if flag(JUST_ALIAS_GSEQABLE)-     cpp-options: -DJUST_ALIAS_GSEQABLE=1+  if ! flag(HASKELL98_FRAGMENT)+     if flag(USE_PAR_SEQABLE)+        build-depends:+            parallel == 3.2.*+        -- I'm not 100% sure where this has to go+        ghc-options: -threaded+        cpp-options: -DUSE_PAR_SEQABLE=1+     else+        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)+        build-depends:+            parallel == 3.2.*+        -- I'm not 100% sure where this has to go+        ghc-options: -threaded+        cpp-options: -DUSE_PAR_PATNODE=1+     else+        cpp-options: -DUSE_PAR_PATNODE=0+  else+     cpp-options: -DUSE_PAR_PATNODE=0++  if ! flag(HASKELL98_FRAGMENT)+     if flag(USE_PSEQ_PATNODE)+        build-depends:+            parallel == 3.2.*+        cpp-options: -DUSE_PSEQ_PATNODE=1+     else+        cpp-options: -DUSE_PSEQ_PATNODE=0+  else+     cpp-options: -DUSE_PSEQ_PATNODE=0++  if flag(USE_TRACE_PATNODE)+     cpp-options: -DUSE_TRACE_PATNODE=1+  else+     cpp-options: -DUSE_TRACE_PATNODE=0+  if flag(USE_PING_PATNODE)+     cpp-options: -DUSE_PING_PATNODE=1+  else+     cpp-options: -DUSE_PING_PATNODE=0+  if flag(USE_DIE_PATNODE)+     cpp-options: -DUSE_DIE_PATNODE=1+  else+     cpp-options: -DUSE_DIE_PATNODE=0+  if flag(USE_TIMING_PATNODE)+     cpp-options: -DUSE_TIMING_PATNODE=1+  else+     cpp-options: -DUSE_TIMING_PATNODE=0++  if flag(HASKELL98_FRAGMENT)      cpp-options: -DJUST_ALIAS_GSEQABLE=0+     cpp-options: -DJUST_ALIAS_GNFDATAN=0+     cpp-options: -DJUST_ALIAS_GNFDATAP=0+--   cpp-options: -DPROVIDE_DATA_FAMILY=0+  else+--   if flag(PROVIDE_DATA_FAMILY)+--      cpp-options: -DPROVIDE_DATA_FAMILY=1+--   else+--      cpp-options: -DPROVIDE_DATA_FAMILY=0+     if flag(USE_SOP)+        if flag(JUST_ALIAS_GSEQABLE)+           cpp-options: -DJUST_ALIAS_GSEQABLE=1+        else+           cpp-options: -DJUST_ALIAS_GSEQABLE=0+        if flag(JUST_ALIAS_GNFDATAN)+           cpp-options: -DJUST_ALIAS_GNFDATAN=1+        else+           cpp-options: -DJUST_ALIAS_GNFDATAN=0+        if flag(JUST_ALIAS_GNFDATAP)+           cpp-options: -DJUST_ALIAS_GNFDATAP=1+        else+           cpp-options: -DJUST_ALIAS_GNFDATAP=0+     else+        cpp-options: -DJUST_ALIAS_GSEQABLE=0+        cpp-options: -DJUST_ALIAS_GNFDATAN=0+        cpp-options: -DJUST_ALIAS_GNFDATAP=0  }++-------------------------------------------------------------------------------
src/Control/DeepSeq/Bounded.hs view
@@ -1,13 +1,23 @@  ------------------------------------------------------------------------------- -{-  LANGUAGE CPP #-}+  {-  LANGUAGE CPP #-} +#if PROVIDE_DATA_FAMILY++  {-# LANGUAGE CPP #-}+  {-# LANGUAGE TypeFamilies #-}+  {-  LANGUAGE TypeSynonymInstances #-}+  {-# LANGUAGE FlexibleInstances #-}+  {-  LANGUAGE DatatypeContexts #-}++#endif+ -------------------------------------------------------------------------------  -- | -- Module      :  Control.DeepSeq.Bounded--- Copyright   :  (c) 2014, Andrew G. Seniuk+-- Copyright   :  Andrew G. Seniuk 2014-2015 -- License     :  BSD-style (see the file LICENSE) --  -- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>@@ -21,40 +31,38 @@ -- take effect, demand must be placed on the forcing function -- itself by the course of execution. ----- A typical use of bounded forcing is to prevent resource leaks in--- lazy streaming, by forcing chunks of data of bounded but sufficient--- depth for the consumer to make progress.------ Another use is to ensure any exceptions hidden within lazy--- fields of a data structure do not leak outside the scope of the+-- Artificial forcing is most commonly used to suppress space+-- leak, but it has many uses besides.+-- Another is to ensure that exceptions hidden within lazy+-- fields of a data structure don't 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 coinductive--- data types are supported by principled bounding of deep evaluation.+-- to the wrong threads, a form of /time leak/). ----- Refer to comments in the 'deepseq' package for more information on how+-- 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.+--+-- Refer to comments in the <http://hackage.haskell.org/package/deepseq deepseq> package for more information on how -- artificial forcing can be useful. -- -- Recently, control (static or dynamic) of parallelisation has been added.--- Control of evaluation order should also be possible (using 'pseq').+-- Control of evaluation order is also supported (via <http://hackage.haskell.org/package/parallel/docs/Control-Parallel.html#v:pseq pseq>).  ------------------------------------------------------------------------------- -  module Control.DeepSeq.Bounded (+  module Control.DeepSeq.Bounded+  (       -- * Forced evaluation to an arbitrary finite depth -#if 1        module Control.DeepSeq.Bounded.NFDataN-#else-       NFDataN(..)-     , deepseqn, forcen-#endif       -- * Forced evaluation over a pattern (arbitrary finite, or dynamic)       , module Control.DeepSeq.Bounded.Pattern-     , module Control.DeepSeq.Bounded.PatAlg      -- re-exports the former+     , module Control.DeepSeq.Bounded.Compile+     , module Control.DeepSeq.Bounded.PatUtil      -- re-exports the former      , module Control.DeepSeq.Bounded.NFDataP     -- re-exports both #if USE_SOP      , module Control.DeepSeq.Bounded.NFDataPDyn  -- re-exps. all 3 above@@ -72,16 +80,18 @@       , module Control.DeepSeq.Bounded.Seqable +#if ! HASKELL98_FRAGMENT      -- * Generic deriving support via "Generics.SOP"  #if USE_SOP-     , module Control.DeepSeq.Bounded.Generics.GSeqable+     , module Control.DeepSeq.Bounded.Generic.GSeqable #endif -     , module Control.DeepSeq.Bounded.Generics.GNFDataN+     , module Control.DeepSeq.Bounded.Generic.GNFDataN #if USE_SOP-     , module Control.DeepSeq.Bounded.Generics.GNFDataP+     , module Control.DeepSeq.Bounded.Generic.GNFDataP #endif+#endif  #if USE_WW_DEEPSEQ      -- * Re-exported@@ -89,33 +99,114 @@      , module Control.DeepSeq #endif -  ) where+-- (I'm not sure what the exact bound is, but 7.6.3 is too low.)+#if __GLASGOW_HASKELL__ >= 708+#if PROVIDE_DATA_FAMILY+     -- * \"I can has data family?...\" +     , FF(..)+#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!+  import Generics.SOP ( Generic )+#endif+   import Control.DeepSeq.Bounded.Seqable    import Control.DeepSeq.Bounded.NFDataN    import Control.DeepSeq.Bounded.Pattern-  import Control.DeepSeq.Bounded.PatAlg+  import Control.DeepSeq.Bounded.Compile+  import Control.DeepSeq.Bounded.PatUtil   import Control.DeepSeq.Bounded.NFDataP #if USE_SOP   import Control.DeepSeq.Bounded.NFDataPDyn #endif +#if ! HASKELL98_FRAGMENT   -- In its own category, relative to GNFDataN and GNFDataP. #if USE_SOP-  import Control.DeepSeq.Bounded.Generics.GSeqable+  import Control.DeepSeq.Bounded.Generic.GSeqable #endif -  import Control.DeepSeq.Bounded.Generics.GNFDataN+  import Control.DeepSeq.Bounded.Generic.GNFDataN #if USE_SOP-  import Control.DeepSeq.Bounded.Generics.GNFDataP+  import Control.DeepSeq.Bounded.Generic.GNFDataP #endif+#endif  #if USE_WW_DEEPSEQ   import Control.DeepSeq+#endif++-------------------------------------------------------------------------------++-- Lest I forget WHY -- now, you can express+--+--   "composition of partially-applied forcing functions commutes"+--+-- directly in Haskell (and compute with it, etc)!...++-- (I'm not sure what the exact bound is, but 7.6.3 is too low.)+#if __GLASGOW_HASKELL__ >= 708++#if PROVIDE_DATA_FAMILY++-- I do believe this came out as a nice first attempt+-- at using any type extensions! After 25 years of+-- functional programming, and 15 in Haskell, I've+-- never used anything non-H98 in my own code, unless+-- a library I used forced me to.  Never in my own code!+-- Until today... / I can see why people get excited+-- about this stuff, it's definitely "elegant"!++  class FF k where+    data F k :: * -> *+    -- | The constraints could probably shrink to just 'Generic' with+    -- a bit of work...  In fact, trying it now -- to do away with NFDataN+    -- and NFDataP classes, and just "alias the SOP generic functions",+    -- as did in Seqable... [Fail. for now]+    phi :: (+#if JUST_ALIAS_GSEQABLE+               Generic v+#else+               Seqable v+#endif+             , NFDataN v+             , NFDataP v+           ) => k -> F k v -> v++  instance FF SeqNode where            -- Seqable[/Generic]+    data F SeqNode v = FSeqNode v+    phi k (FSeqNode m) = force_ k m++  instance FF Int where                -- NFDataN+    data F Int v = FInt v+    phi k (FInt m) = forcen k m++  instance FF Pattern where            -- NFDataP+    data F Pattern v = FPattern v+    phi k (FPattern m) = forcep_ k m++#if 0+  instance (FF Pattern, FF a) => FF (Pattern,a) where+    data F (Pattern, a) = FPattern v+    phi (pat,a) (FPattern m) = forcep k m+#endif+    +#endif+ #endif  -------------------------------------------------------------------------------
+ src/Control/DeepSeq/Bounded/Compile.hs view
@@ -0,0 +1,36 @@++-------------------------------------------------------------------------------++  {-  LANGUAGE CPP #-}++-------------------------------------------------------------------------------++-- |+-- Module      :  Control.DeepSeq.Bounded.Compile+-- Copyright   :  Andrew G. Seniuk 2014-2015+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- 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.*.++-------------------------------------------------------------------------------++  module Control.DeepSeq.Bounded.Compile+  (++      compilePat+    , showPat++  )+  where++-------------------------------------------------------------------------------++  import Control.DeepSeq.Bounded.Compile_shared_utils2 ( compilePat, showPat )++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Compile_new_grammar.hs view
@@ -0,0 +1,1188 @@++-------------------------------------------------------------------------------++  {-  LANGUAGE CPP #-}++-- Promoted to .cabal flag, as showPat (which presently lives elsewhere,+-- although that is temporary!) needs to know, too.+--- #define NEW_SEMICOLON_TYPE_LIST 1++#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++-- Changed my mind again -- we won't allow mixed nomenclature,+-- but we WILL auto-detect, within a given pattern string,+-- which convention is in use ... ah, but then what if you+-- want to concatenate pattern strings to build patterns+-- at the String DSL level, and these source strings don't+-- originate in the same convention? Nah! Forget it, the+-- toggle switch here is fine. [Now promoted to cabal flag+-- so can use in showPat as well as tests.]+------+-- We cannot allow "{(})"!... And I'm not into playing matching+-- games at this juncture.+--- #define USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS 0+----- #define ACCEPT_CURLY_BRACE_OR_PAREN_SUBPATTERNS 0++-- This /is/ important, and is /almost/ working.+-- I really don't like struggling with libraries like parsec/atto.+-- Or HXT and arrows. Honestly, just give me a solid combinator+-- language with clean syntax, and a quality compiler, and we're+-- off to the races. Grrrr.......+-- Later: Oh, pshaw!!...+#define ALLOW_ESCAPED_TYPE_LIST_SEPARATOR 1++#define SAVE_ME_HERE 1++#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++-------------------------------------------------------------------------------++  {-  LANGUAGE PatternSignatures #-}  -- debugging only+  {-# LANGUAGE ScopedTypeVariables #-}  -- debugging only++#if USE_ATTOPARSEC+  {-# LANGUAGE OverloadedStrings #-}+  {-# LANGUAGE BangPatterns #-}  -- for forcing tracelines in monadic code+#endif++#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_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+--++-------------------------------------------------------------------------------++  module Control.DeepSeq.Bounded.Compile_new_grammar++-- XXX If commented out, it's for debugging only!+#if 1++--- {-# DEPRECATED "Use Wobble instead" #-}+  (++#if USE_ATTOPARSEC+#if HASKELL98_FRAGMENT+#error Sorry, HASKELL98_FRAGMENT incompatible with NEW_IMPROVED_PATTERN_GRAMMAR, because only USE_ATTOPARSEC parser is working. With some artful CPP you could cut out the Pattern parser/compiler, and then resort to the bare PatNode constructors...+#endif+      compileUsingAttoparsec  ,+--    parsePat  ,+#else+      compilePat'  ,+#endif++  )++#endif++  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 USE_ATTOPARSEC++#if 0++  -- This attoparsec module is intended for parsing text that is+  -- represented using an 8-bit character set, e.g. ASCII or ISO-8859-15.+  -- XXX Since this is to include type names,+  -- the character set should be bigger...+#if 1+  import Data.Attoparsec.Text+  import qualified Data.Text as T+#else+  import Data.Attoparsec.Char8+  import qualified Data.ByteString.Char8 as B+#endif+  import Control.Applicative ( (<*), (<|>) )++#endif++  import Control.Applicative++--------------++  -- Data.Aeson.Parser.Internal.hs imports:+#if 0+  import Data.ByteString.Builder+    (Builder, byteString, toLazyByteString, charUtf8, word8)+#endif+  import Control.Applicative ((*>), (<$>), (<*), liftA2, pure)+  import Control.Applicative ( (<|>) )  -- not in aeson+--import Data.Aeson.Types (Result(..), Value(..))+#if 0+  import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,+                                           skipSpace, string)+  import Data.Bits ((.|.), shiftL)+  import Data.ByteString (ByteString)+  import Data.Char (chr)+  import Data.Monoid (mappend, mempty)+  import Data.Text (Text)+  import Data.Text.Encoding (decodeUtf8')+#endif+  import qualified Data.Text as T  -- not in aeson+--import qualified Data.Text.Lazy as T  -- not in aeson+#if 0+--import Data.Vector as Vector (Vector, fromList)+  import Data.Word (Word8)+#endif+#if 0+  import qualified Data.Attoparsec.ByteString as A+  import qualified Data.Attoparsec.Lazy as AL+  import qualified Data.Attoparsec.Zepto as Z+  import qualified Data.ByteString as B+  import qualified Data.ByteString.Lazy as BL+  import qualified Data.ByteString.Unsafe as B+--import qualified Data.HashMap.Strict as H+#endif+  import qualified Data.Attoparsec.Text as AT  -- not in aeson+--import qualified Data.Attoparsec.Text.Lazy as AT  -- not in aeson++--import qualified Data.Attoparsec.Text as AT+--                   (Parser, char, endOfInput, scientific,+--                    skipSpace, string)++  import Data.Char ( isLetter )+  import Data.Char ( isDigit )++  import Control.Monad ( liftM )+--import Control.Monad ( foldM )+--import Data.Foldable ( fold )+--import Control.Monad ( mzero )+  import Data.Monoid ( mempty )++  import Data.Char ( ord )++  import Control.Monad ( mzero )++#endif++-------------------------------------------------------------------------------++#if DO_TRACE+  mytrace = trace+#else+  mytrace _ = id+#endif++#if USE_ATTOPARSEC++-------------------------------------------------------------------------------++  -- Although this accepts zero or more Pattern, the caller+  -- will fail the parse unless the list contains exactly+  -- one Pattern.  Later: That's not true. Now, the callers+  -- (or someone up there) uses liftPat if multiple patterns+  -- are parsed (adds new common root).+  parsePatsTop :: AT.Parser [Pattern]+  parsePatsTop = do+    !_ <- mytrace ("parsePatsTop.") $ return ()+    let as = emptyPatNodeAttrs+    AT.many' (AT.skipSpace *> parsePat as <* AT.skipSpace)+  -- I'm not sure why this particular skipSpace is necessary, but+  -- the pattern " ." will fail to parse without it, even though+  -- "( .)" is fine.+--parsePatsTop = AT.skipSpace *> AT.many' (parsePat emptyPatNodeAttrs)++-------------------------------------------------------------------------------++  -- This differs from parsePatsTop in that it assumes an+  -- opening grouping token has been consumed (so will be+  -- expecting a corresponding closing token).+  parsePats :: AT.Parser [Pattern]+#if 1+  parsePats = do+        !_ <- mytrace "parsePats." $ return ()+        (AT.endOfInput *> pure [])+    <|> (do+            c <- AT.peekChar'+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+            if c == '}'+#else+            if c == ')'+#endif+              then pure []+---           then AT.char '}' >> pure []+              else let as = emptyPatNodeAttrs in+                   AT.many' (AT.skipSpace *> parsePat as <* AT.skipSpace))+#else+  -- XXX Why does this work so badly?+  parsePats = AT.manyTill'+                   (AT.skipSpace *> parsePat emptyPatNodeAttrs)+                   (AT.endOfInput <|> (AT.char ')' *> return ()))+#endif++-------------------------------------------------------------------------------++  -- Deal with all /prefix/ PatNode attributes (PatNodeAttrs).+  -- These are all except the two /postfix/ attrs, *n and :[:]types.+  -- Later: Now, all except *n -- the :...: type constraints+  -- are treated as just another prefix modifier, but the T*+  -- PatNode's still exist (probably they will be absorbed in 0.7).+  parsePat :: PatNodeAttrs -> AT.Parser Pattern+  parsePat as = do+-- XXX Should test if next character is non-attribute, up front,+-- and skip all this attribute stuff in that case!...+    !_ <- mytrace "parsePat." $ return ()+#if 1+    foldr (<|>) mempty $+--  foldM (<|>) mempty $+--  fold (<|>) mempty $+--  fold (<|>) mzero $+      ( map+          (\ (c,s,p,b,a) -> do +            let q = (c,s,b,a)+#if SAVE_ME_HERE+            if c == '\0'+            then fail ""+            else do+#endif+#if 0+                  mempty+              -- Not very efficient to be doing the first two every time!+              -- With one more bit of abstraction, we could get it all snug.+              <|> (parsePat1''' as)  --- @:tys: : tys are typeConstraints+              <|> (parsePat1' as)    --- @n : n is threadDelay in microsec.+#if USE_PSEQ_PATNODE+              <|> (parsePat1'' as)   --- >p : p is a permutation, eg. cdba+#endif+              <|> ( AT.char c <* AT.skipSpace )+#endif+                  ( p c b a s <* AT.skipSpace )+          )+#if SAVE_ME_HERE+          [+            ( '\0' , ""       , dud_parser    , const False     , as )+          , ( ':'  , "types"  , types_parser  , doConstrainType , as_types  )+          , ( '@'  , "delay"  , delay_parser  , doDelay         , as_delay  )+#if USE_PAR_PATNODE+          , ( '='  , "spark"  , no_arg_parser , doSpark         , as_spark  )+#endif+#if USE_PSEQ_PATNODE+          , ( '>'  , "pseq"   , pseq_parser   , doPseq          , as_pseq   )+#endif+#if USE_TRACE_PATNODE+          , ( '+'  , "trace"  , no_arg_parser , doTrace         , as_trace  )+#endif+#if USE_PING_PATNODE+          , ( '^'  , "ping"   , no_arg_parser , doPing          , as_ping   )+#endif+#if USE_DIE_PATNODE+          , ( '/'  , "die"    , no_arg_parser , doDie           , as_die    )+#endif+#if USE_TIMING_PATNODE+          , ( '%'  , "timing" , no_arg_parser , doTiming        , as_timing )+#endif+          ]+      ) ++ [ parsePat3 as ]+---   ) ++ [ parsePat2 as ]+#else+-- (Later: bitrotten now.)+-- I could comment, but this speaks for itself.+          [+#if USE_PAR_PATNODE+             {-,-}  ( '=' , "spark" , doSpark , as_spark )+#endif+#if USE_PSEQ_PATNODE+#if USE_PAR_PATNODE+               ,    ( '+' , "trace" , doTrace , as_trace )+#else+             {-,-}  ( '>' , "pseq"  , doPseq  , as_pseq  )+#endif+#endif+#if USE_TRACE_PATNODE+               ,    ( '+' , "trace" , doTrace , as_trace )+#endif+#if USE_PING_PATNODE+               ,    ( '^' , "ping"  , doPing  , as_ping  )+#endif+#if USE_DIE_PATNODE+               ,    ( '/' , "die"   , doDie   , as_die   )+#endif+          ]+      ) ++ [ parsePat2 as ]+#endif+#else+-- XXX This has fallen into obsolescence.+-- XXX It looks more orderly, and is easier to understand,+-- but it's actually harder to maintain, so I guess that+-- would argue overall for using the fold, above...+         (    AT.char '='+           >> if doSpark as+                then fail "compilePat: duplicate '=' (spark) node attribute"+                else parsePat as_spark)+     <|> (    AT.char '+'+           >> if doTrace as+                then fail "compilePat: duplicate '+' (trace) node attribute"+                else parsePat as_trace)+     <|> (    AT.char '^'+           >> if doPing  as+                then fail "compilePat: duplicate '^' (ping) node attribute"+                else parsePat as_ping)+     <|> (parsePat2 as)+#endif+   where+    dud_parser _ _ _ _ = fail "dud_parser"  -- (it is never run; should use Proxy)+    no_arg_parser c b a s = do+         ( (AT.char c) <* AT.skipSpace )+      >> (+          if b as+            then fail $    "compilePat: duplicate "+                        ++ show c ++ " (" ++ s ++ ") "+                        ++ "node attribute"+            else parsePat a)+    types_parser _ _ a _ = parsePat1''' a+    delay_parser _ _ a _ = parsePat1' a+    pseq_parser _ _ a _ = parsePat1'' a+-- (doConstrainType, doDelay, and doPseq handled separately,+-- due to their taking arguments.)+    as_types   = as { doConstrainType  = True }+    as_delay   = as { doDelay          = True }+#if USE_PAR_PATNODE+    as_spark   = as { doSpark          = True }+#endif+#if USE_PSEQ_PATNODE+    as_pseq    = as { doPseq           = True }+#endif+#if USE_TRACE_PATNODE+    as_trace   = as { doTrace          = True }+#endif+#if USE_PING_PATNODE+    as_ping    = as { doPing           = True }+#endif+#if USE_DIE_PATNODE+    as_die     = as { doDie            = True }+#endif+#if USE_TIMING_PATNODE+    as_timing  = as { doTiming         = True }+#endif++  -- Parse the ":Int;Maybe Float:" typeConstraints attribute, if present.+--parsePat1''' :: PatNodeAttrs -> AT.Parser PatNodeAttrs+  parsePat1''' :: PatNodeAttrs -> AT.Parser Pattern+  parsePat1''' as = do+          !_ <- mytrace "parsePat1'''." $ return ()+          AT.char ':'+          >> ( ( parse_type_constraints True <* AT.skipSpace )+               >>= \ (tcs,ncol)+                       -> let as' = as { doConstrainType = True+                                       , typeConstraints = map T.unpack tcs }+#if 0+                          in return as' )+#else+                          in do+-- This continues to look fine.+#if 0+                                roi <- AT.takeText+                                error $ "DEVEXIT: " ++ show tcs ++ "  " ++ show roi ++ "\n" ++ show as'+#endif+                                parsePat as' )+--                        in parsePat as' )+#endif++  -- Parse the "@50000" delayus attribute, if present.+--parsePat1' :: PatNodeAttrs -> AT.Parser PatNodeAttrs+  parsePat1' :: PatNodeAttrs -> AT.Parser Pattern+  parsePat1' as = do+          !_ <- mytrace "parsePat1'." $ return ()+          AT.char '@'+          >> ( ( AT.decimal <* AT.skipSpace )+               >>= \ dly -> let as' = as { doDelay = True+                                         , delayus = dly }+#if 0+                            in return as' )+#else+                            in parsePat as' )+#endif++#if USE_PSEQ_PATNODE+  -- Parse the ">cdba" pseqPerm attribute, if present.+--parsePat1'' :: PatNodeAttrs -> AT.Parser PatNodeAttrs+  parsePat1'' :: PatNodeAttrs -> AT.Parser Pattern+  parsePat1'' as = do+          !_ <- mytrace "parsePat1''." $ return ()+          AT.char '>'+          >> ( ( AT.many1' AT.letter ) <* AT.skipSpace+               >>= \ perm -> let perm' = map (\c -> ord c - ord 'a') perm+                                 as' = as { doPseq = True+                                          , pseqPerm = Just perm' }+#if 0+                             in return as' )+#else+                             in parsePat as' )+#endif+#endif++-------------------------------------------------------------------------------++#if 0++  -- Now we're past the prefix attributes; next, test if this+  -- as a TR node (signalled by ':' being the next character),+  -- and branch accordingly.  (There is still TI, TN and TW+  -- cases to handle, see parsePat4*.)+  parsePat2 :: PatNodeAttrs -> AT.Parser Pattern+  parsePat2 as = do+        !_ <- mytrace "parsePat2." $ return ()+        (AT.char ':' >> parsePat2_t as)+    <|> (parsePat3 as)++  -- Parse the type constraints which must follow TR's opening ':'.+  parsePat2_t :: PatNodeAttrs -> AT.Parser Pattern+  parsePat2_t as = do+    !_ <- mytrace "parsePat2_t." $ return ()+    (tcs,ncol) <- parse_type_constraints True+--  (tcs,ncol) <- spaceSeparated parseTypeName '{'+--  error $ show tcs+    !_ <- mytrace ("(ncol,tcs)=("++show ncol ++ "," ++ (T.unpack $ T.intercalate " " tcs)) $ return ()+    if ncol > 0+      then fail "compilePat: unexpected \"::\""+      else do+        let as_t = as { typeConstraints = map T.unpack tcs }+        parsePat_TR_tail 'x' as_t++#endif++-------------------------------------------------------------------------------++  -- Handle "*23"-style (WN and TN) nodes.+  -- (The integer depth attribute always precedes any type constraint;+  -- in contrast to the prefix attributes, which can occur in any order.)+  parsePat3 :: PatNodeAttrs -> AT.Parser Pattern+  parsePat3 as = do+    !_ <- mytrace "parsePat3." $ return ()+    b <- AT.peekChar'+#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 )+    AT.anyChar+#endif+    !_ <- mytrace ("boo-0: "++show b) $ return ()+#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 )+    !_ <- mytrace ("boo-1: "++show b) $ return ()+    if b == '*'+#else+    !_ <- mytrace ("boo-1-_19__9: "++show b) $ return ()+    if isDigit b+#endif+      then do (     (parsePat3_aux b as)+                <|> (do+#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+#if 1+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+                        AT.anyChar+                        (case b of+#if 1+                          '0' -> parsePat4 '0' Nothing as+                          '1' -> parsePat4 '1' Nothing as+#else+#if NEW_CONCRETE_WI_AND_WS+                          '0' -> parsePat4 '.' Nothing as+                          '1' -> parsePat4 '!' Nothing as+#else+                          '0' -> parsePat4 '#' Nothing as+                          '1' -> parsePat4 '.' Nothing as+#endif+#endif+                          _   -> parsePat4 '*' Nothing as+                            ) ) )+#else+                        (parsePat4 '*' Nothing as) ) )+#endif+#else+                        !_ <- mytrace ("parsePat3: unexpected digit " ++ [b]) $ return ()+                        fail $ "parsePat3: unexpected digit " ++ [b] ) )+#endif+#else+                        (parsePat4 '*' Nothing as) ) )+#endif+      else do+#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+--      fail $ "parsePat3: #2 unexpected digit " ++ [b]+        AT.anyChar+#endif+        parsePat4 b Nothing as+--    else fail "compilePat: unexpected char not in \"#.*\""++  -- Actual handler, in case it /was/ WN or TN node.+  parsePat3_aux :: Char -> PatNodeAttrs -> AT.Parser Pattern+  parsePat3_aux b as = do+    !_ <- mytrace "parsePat3_aux." $ return ()+    !_ <- mytrace ("boo-2: "++show b) $ return ()+-- 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+---    if length n_integer_str > 19  = fail $ "compilePat: *" ++ n_integer_str ++ " is too large"+    !_ <- mytrace ("boo-3: "++show b) $ return ()+#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 )+    AT.skipSpace+#endif+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19+    n_integer_cs <- if b == '1'+                      then AT.anyChar *> AT.option "1" (AT.digit >>= \ c -> return ('1':[c]))+                      else AT.anyChar *> return [b]+    !_ <- mytrace ("boo-3.2: n_integer_ns="++n_integer_cs) $ return ()+    let n_integer = read n_integer_cs :: Integer+#elif ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+    n_integer_c <- AT.anyChar :: AT.Parser Char+    !_ <- mytrace ("n_integer_c="++show n_integer_c) $ return ()+    n_integer <- case n_integer_c of+                     '0' -> mytrace ("ANDDD...(0):") $ fail ""+                     '1' -> mytrace ("ANDDD...(1):") $ fail ""+                     _   -> parsePat4 '*' Nothing as+    !_ <- mytrace "oops!!!!" $ return ()+    let n_integer = read [n_integer_c] :: Integer+#else+    n_integer <- AT.decimal :: AT.Parser Integer+#endif+    !_ <- mytrace ("boo-3.5: "++show b) $ return ()+    let n_integer_str = show n_integer+    !_ <- mytrace ("boo-4: "++show b++" "++n_integer_str) $ return ()+    if length n_integer_str > 9+      then fail $ "compilePat: *" ++ n_integer_str ++ " is too large"+      else parsePat4 '*' (Just (read n_integer_str :: Int)) as++-------------------------------------------------------------------------------++#if 1++  -- This handles whether or not it's a type-constrainted node.+  -- (The constraints themselves will have already been parsed.)+  parsePat4 :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern+  parsePat4 b mdepth as = do+    !_ <- mytrace "parsePat4." $ return ()+    !_ <- mytrace ("GOO-1: "++show b++" "++show (doConstrainType as)) $ return ()+    if doConstrainType as+      then parsePat4_t b mdepth 0 as+      else parsePat4_w b mdepth as++#else++  -- This handles whether or not it's a type-constrainted node,+  -- not including TR nodes which were handled earlier.+  parsePat4 :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern+  parsePat4 b mdepth as = do+    !_ <- mytrace "parsePat4." $ return ()+    !_ <- mytrace ("GOO-1: "++show b) $ return ()+    parsePat4_aux b mdepth as <|> parsePat4_w b mdepth as++  -- Actual handler, in case it /was/ a type-constrained node (TI, TN or TW).+  parsePat4_aux :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern+  parsePat4_aux b mdepth as = do+#if 0+    roi <- AT.takeText+    error $ "DEVEXIT -- " ++ T.unpack roi+#endif+    !_ <- mytrace "parsePat4_aux." $ return ()+    !_ <- mytrace ("GOO-2.1: b="++show b++" mdepth="++show mdepth) $ return ()+    c <- AT.peekChar'+    !_ <- mytrace ("GOO-2.2: c="++show c) $ return ()+    if c == ':'+    then do+      !_ <- mytrace ("GOO-2.3.1: "++show b) $ return ()+      (tcs,ncol) <- parse_type_constraints False+--    (tcs,ncol) <- spaceSeparated parseTypeName '{'+      !_ <- mytrace ("GOO-2.3.2: "++show (tcs,ncol)) $ return ()+      let as_t = as { typeConstraints = map T.unpack tcs }+      !_ <- mytrace ("GOO-2.3.3: "++show (typeConstraints as_t)) $ return ()+      parsePat4_t b mdepth ncol as_t+    else do+      !_ <- mytrace ("GOO-2.4: "++show b) $ return ()+      parsePat4_w b mdepth      as+--    fail "compilePat: expected ':'"++#endif++  -- Actual handler, in case it was /NOT/ a type-constrained node;+  -- i.e. a WI, WR, WS (if still exists), WN or WW node.+  parsePat4_w :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern+  parsePat4_w b mdepth as = do+    !_ <- mytrace "parsePat4_w." $ return ()+    !_ <- mytrace ("GOO-3: "++show b) $ return ()+    case b of+#if VACANT_HASH+     ' ' -> return (Node (WI as) [])+     '#' -> return (Node (WI as) [])  -- still accept actual #, too+#else+#if NEW_CONCRETE_WI_AND_WS+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+     '0' -> return (Node (WI as) [])+#else+     '.' -> return (Node (WI as) [])+#endif+#else+     '#' -> return (Node (WI as) [])+#endif+#endif+#if NEW_CONCRETE_WI_AND_WS+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+     '1' -> return (Node (WS as) [])+#else+     '!' -> return (Node (WS as) [])+#endif+#else+     '.' -> return (Node (WS as) [])+#endif+     '*' -> if isNothing mdepth+              then return (Node (WW as) [])+              else return (Node (WN as_n) [])+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+     '{' -> parsePat_WR_tail b as+#else+     '(' -> parsePat_WR_tail b as+#endif+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+     _ -> fail $ "compilePat: expected one of \"#.*{\" (got " ++ show b ++ ")"+#else+     _ -> fail $ "compilePat: expected one of \"#.*(\" (got " ++ show b ++ ")"+#endif+   where+    as_n = as { depth = fromJust mdepth }++  -- This is a helper of patsePat4_aux.+  parsePat4_t :: Char -> Maybe Int -> Int -> PatNodeAttrs -> AT.Parser Pattern+  parsePat4_t b mdepth ncol as_t = do+    !_ <- mytrace "parsePat4_t." $ return ()+#if 1+#if 0+    !_ <- mytrace "parsePat4_t: trying to eat ':'..." $ return ()+    AT.char ':'+    !_ <- mytrace "parsePat4_t: ate ':'!" $ return ()+#endif+    if False+       then fail "dummy"  -- will never run+#else+    if ncol /= 2+       then do+               c <- AT.peekChar'+               fail $ "compilePat: after \"" ++ [c] ++ "\", expect \"::\" not \":\""+#endif+       else do+#if NEW_SEMICOLON_TYPE_LIST+         !_ <- mytrace ("parsePat4_t: b="++show b) $ return ()+         case b of+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+          '{' -> do+#else+          '(' -> do+#endif+                    !_ <- mytrace "parsePat4_t: entering TR_tail..." $ return ()+                    parsePat_TR_tail 'x' as_t+---                 !_ <- mytrace "parsePat4_t: exited TR_tail!" $ return ()+#if VACANT_HASH+          ' ' -> return (Node (TI as_t) [])+          '#' -> return (Node (TI as_t) [])  -- still accept actual #, too+#else+#if NEW_CONCRETE_WI_AND_WS+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+          '0' -> return (Node (TI as_t) [])+#else+          '.' -> return (Node (TI as_t) [])+#endif+#else+          '#' -> return (Node (TI as_t) [])+#endif+#endif+          '*' -> if isNothing mdepth+                   then return (Node (TW as_t) [])+                   else return (Node (TN as_t_n) [])+#else+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+         let endch = '}'+#else+         let endch = ')'+#endif+         case b of+#if VACANT_HASH+          ' ' -> AT.char endch >> return (Node (TI as_t) [])+          '#' -> AT.char endch >> return (Node (TI as_t) [])  -- still accept actual #, too+#else+#if NEW_CONCRETE_WI_AND_WS+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+          '0' -> AT.char endch >> return (Node (TI as_t) [])+#else+          '.' -> AT.char endch >> return (Node (TI as_t) [])+#endif+#else+          '#' -> AT.char endch >> return (Node (TI as_t) [])+#endif+#endif+          '*' -> AT.char endch >> if isNothing mdepth+                                    then return (Node (TW as_t) [])+                                    else return (Node (TN as_t_n) [])+#endif+#if NEW_CONCRETE_WI_AND_WS+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+          _ -> fail $ "compilePat: expected '*' or digit (got " ++ show b ++ ")"+#elif ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__SAFE_DOWN_TO_DEPTH_19+          _ -> fail $ "compilePat: expected '.' or '*' or digit (got " ++ show b ++ ")"+#else+          _ -> fail $ "compilePat: expected '.' or '*' (got " ++ show b ++ ")"+#endif+#else+          _ -> fail $ "compilePat: expected '#' or '*' (got " ++ show b ++ ")"+#endif+   where+    as_t_n = as_t { depth = fromJust mdepth }++-------------------------------------------------------------------------------++  -- XXX I hesitate to document these ... they're both concerned+  -- with parsing grouped subpatterns, but it's still not clear+  -- whether the opening '(' (or '{') is expected to have been+  -- previously consumed or not, and I think the convention+  -- is different in each of these -- if it were the same, there+  -- would be no need for two functions!++#if 0+  parsePat_WR :: PatNodeAttrs -> AT.Parser Pattern+  parsePat_WR as = AT.char '{' *> parsePat_WR_tail as+#endif++  parsePat_WR_tail :: Char -> PatNodeAttrs -> AT.Parser Pattern+  parsePat_WR_tail x as+   = do+        !_ <- mytrace "parsePat_WR_tail." $ return ()+        !_ <- mytrace ("**HWR1**: "++show x) $ return ()+#if 0+#if NEW_SEMICOLON_TYPE_LIST+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+        AT.skipSpace *> AT.char '{'+#else+        AT.skipSpace *> AT.char '('+#endif+#endif+#endif+        !_ <- mytrace ("**HWR1.5**: "++show x) $ return ()+        pats <- parsePats <|> pure []+        !_ <- mytrace ("**HWR2**: "++show x) $ return ()+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+        AT.char '}'+#else+        AT.char ')'+#endif+        !_ <- mytrace ("**HWR3**: "++show x) $ return ()+        return (Node (WR as) pats)++#if 0+  parsePat_TR :: PatNodeAttrs -> AT.Parser Pattern+  parsePat_TR as = AT.char '{' *> parsePat_TR_tail as+#endif++  parsePat_TR_tail :: Char -> PatNodeAttrs -> AT.Parser Pattern+  parsePat_TR_tail x as_t+   = do+        !_ <- mytrace "parsePat_TR_tail." $ return ()+        !_ <- mytrace ("**HTR1**: "++show x) $ return ()+#if 0+        roi <- AT.takeText+        error $ "DEVEXIT: " ++ show roi+#endif+#if 0+#if NEW_SEMICOLON_TYPE_LIST+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+        AT.skipSpace *> AT.char '{'+#else+        AT.skipSpace *> AT.char '('+#endif+#endif+#endif+        !_ <- mytrace ("**HTR1.5**: "++show x) $ return ()+        pats <- parsePats <|> pure []+        !_ <- mytrace ("**HTR2**: "++show x) $ return ()+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+        AT.char '}'+#else+        AT.char ')'+#endif+        !_ <- mytrace ("**HTR3**: "++show x) $ return ()+        return (Node (TR as_t) pats)++-------------------------------------------------------------------------------++-- XXX In isTR case, it seems the (single) colon has already been consumed;+-- whereas in non-isTR case, neither of the (double) colons have been.++  -- It's important to note that this parser begins+  -- by consuming initial [whitespace, and] colons.+  -- It also counts them, and returns the count.+  parse_type_constraints :: Bool -> AT.Parser ( [T.Text], Int )+  parse_type_constraints isTR = do++--  AT.take 3 >>= \ test -> error $ "test="++show test++    !_ <- mytrace "parse_type_constraints." $ return ()+#if NEW_SEMICOLON_TYPE_LIST+    let endchar = ':'+#else+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+    let endchar = '{'+#else+    let endchar = '('+#endif+#endif++#if TYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR+    let sepchar = ' '+#else+#if NEW_SEMICOLON_TYPE_LIST+    let sepchar = ';'+#else+    let sepchar = ':'+#endif+#endif++#if NEW_SEMICOLON_TYPE_LIST+    ncs <- if isTR+             then pure 0+             else AT.string "::" *> pure 2+#endif++#if NEW_SEMICOLON_TYPE_LIST+    -- (1) Grab (or be ready to grab) input up to the next unescaped ':'+    --     character, which must exist.  We might as well do this up front,+    --     since we /will/ actually consume all of it.+-- XXX I'll finish this using peekChar, but I think in atto you are+-- supposed to just use <|>, it is backtracking by default, so try such+-- a variant and see if it works (after), it would be way more compact!+    let loop = do+          seg <- AT.takeWhile (\c->c/=endchar&&c/='\\') :: AT.Parser T.Text+          !_ <- mytrace ("loop: seg="++T.unpack seg) $ return ()+          if T.null seg+           then do+            !_ <- mytrace "loop: T.null seg" $ return ()+            return []+           else do+            mnc <- AT.peekChar+            !_ <- mytrace ("loop: mnc="++show mnc) $ return ()+            let nc = fromJust mnc+            if isNothing mnc+             then do+              !_ <- mytrace "trace: \"parse_type_constraints: unexpected end of input #1\"" $ return ()+              fail "parse_type_constraints: unexpected end of input"+             else do+              AT.take 1+              if nc == '\\'+              then do+                mnc' <- AT.peekChar+                !_ <- mytrace ("loop: mnc'="++show mnc') $ return ()+                let nc' = fromJust mnc'+                if isNothing mnc'+                  then do+                   !_ <- mytrace "trace: \"parse_type_constraints: unexpected end of input #2\"" $ return ()+                   fail "parse_type_constraints: unexpected end of input"+                  else do+                   -- We don't care if it was : or not.  If the character+                   -- after '\\' (i.e. nc') was not ':', the result is+                   -- no different ("\\c" in all cases); however, we+                   -- distinguish ':' conceptually because, by passing it+                   -- through, we affect the termination properties of loop.+                   !_ <- mytrace "loop: <appending backslash>" $ return ()+                   AT.take 1 *> ( ( ( T.snoc seg '\\' `T.snoc` nc' ) : ) <$> loop )+---                AT.anyChar >>= \ c -> ( T.snoc seg c : ) <$> loop+              else do+                !_ <- mytrace ("loop: [seg]="++show [seg]) $ return ()+                return [seg]  -- we know it was endchar+    segs <- loop+    !_ <- mytrace ("segs="++show segs) $ return ()+    let seg = T.concat segs+    !_ <- mytrace ("seg="++T.unpack seg) $ return ()+#else+    -- (1) Grab (or be ready to grab) input up to the first '(' (or '{')+    --     character, which must exist.  We might as well do this up front,+    --     since we /will/ actually consume all of it.+    seg' <- AT.takeWhile (/=endchar) :: AT.Parser T.Text+    !_ <- mytrace ("seg'="++T.unpack seg') $ return ()+#endif++#if NEW_SEMICOLON_TYPE_LIST+    -- (1.5) I guess we're supposed to consume the closing ':' as well:+    -- Later: And it looks like we did already, although I don't see why...+--  do { x <- AT.take 2 ; !_ <- mytrace ("x="++show x) $ return () ; fail "" }+    if isTR+        -- For TR case, we need a parse error if see a second closing colon.+        -- This should happen in the normal course of parsing; we don't+        -- need to do anything here (and it would be difficult to do so,+        -- but according to my analysis the parse should eventually fail).+        -- (But a later note says, "no!", we should/must do it here?...)+        then do+         !_ <- mytrace "HERE isTR" $ return ()+         mnc <- AT.peekChar+         !_ <- mytrace ("isTR: mnc="++show mnc) $ return ()+         let nc = fromJust mnc+         if isNothing mnc+          then do+           !_ <- mytrace "isTR: \"parse_type_constraints: unexpected end of input\"" $ return ()+           fail "parse_type_constraints: unexpected end of input"+          else do+           !_ <- mytrace ("isTR: nc="++show nc) $ return ()+           if nc == ':'+            then do+             !_ <- mytrace "isTR: \"parse_type_constraints: unexpected end of input\"" $ return ()+             fail "parse_type_constraints: unexpected end of input"+            else do+             AT.take 0+---        else AT.anyChar *> AT.anyChar >>= \ c -> ( ( seg `T.snoc` nc `T.snoc` c ) : ) <$> loop+        -- If there are two (or more) contiguous colons closing, then+        -- see if can get an accept by taking the (leading) pair as+        -- a single close token; otherwise, the second (and subsequent)+        -- colons must be part of the next pattern.+        -- XXX Later: Hopefully AT.option will give me what I think it will...+        -- (Still debugging numerous sites since added this code, so untested.)+        else do+          AT.take 0+--        ( AT.option T.empty (pure (T.singleton endchar)) ) *> AT.take 0+---       ( AT.option T.empty (AT.char endchar *> pure (T.singleton endchar)) ) *> ( ( ( T.singleton endchar ) : ) <$> loop )+----      ( ( AT.option T.empty (AT.char endchar) ) *> ( ( T.singleton endchar ) : ) ) <$> loop+----      ( AT.option T.empty (AT.char endchar) ) >>= \ c-> ( ( T.singleton c ) : )<$> loop+----      ( AT.option T.empty (AT.char endchar) ) <$> loop+-----     AT.option T.empty (pure $ T.singleton endchar)+-----     AT.option T.empty (AT.takeWhile (==endchar))+#else+    -- (1.5) I guess we're supposed to consume the '(' as well:+    AT.take 1+#endif++    !_ <- mytrace ("HERE!") $ return ()++#if ! NEW_SEMICOLON_TYPE_LIST+    -- (2) Prefix colons: Have different syntax and semantics than+    --     the separator colons.  We must eat them now, and keep+    --     count since we return that figure as part of the result.+    let (ecs :: Either String T.Text) = AT.parseOnly ((AT.takeWhile (==':')) :: AT.Parser T.Text) seg+    !_ <- mytrace ("ecs="++show ecs) $ return ()+#endif++#if NEW_SEMICOLON_TYPE_LIST+    let (eblocksncs :: Either String ([T.Text],Int)) =+                      AT.parseOnly+                           ( ( AT.sepBy1'+                                 (AT.takeWhile (/=';'))+                                 (AT.char ';')+                             )+                             >>= \ y -> return (y,ncs)+                           )+                           seg+    !_ <- mytrace ("eblocksncs="++show eblocksncs) $ return ()+    let (blocks,ncs) = case eblocksncs of+         Left msg -> error $ "parse_type_constraints: eblocks parse failure: " ++ msg+         Right (blocks,ncs) -> (blocks,ncs) :: ([T.Text],Int)+    !_ <- mytrace ("(blocks,ncs)="++show (blocks,ncs)) $ return ()+    let blocks' = map (helper False) blocks  -- (so get "\\c" not "\c" in names)+    return (blocks',ncs)+#else+    let (eblocksncs :: Either String ([T.Text],Int)) =+         case ecs of+          Left msg -> fail $ "parse_type_constraints: expected colon: " ++ msg+    -- (3) Split the remaining pre-( fragment at all colon characters.+    --     (Never mind escapes whatsoever; leave the '\\' chars alone,+    --     but split on every ':' regardless if it was preceded by '\\'.)+          Right cs -> let ncs = T.length cs+                          seg' = T.drop ncs seg+                      in+#if 0+#if 0+#elif 1+                   AT.sepBy1' (AT.many1' AT.anyChar) (AT.string $ T.singleton sepchar)+                                   >>= (\x -> return (x,ncs))+#elif 0+                   AT.sepBy1' (liftM T.concat $ AT.many1' AT.anyChar) (AT.string $ T.singleton sepchar)+                                   >>= (\x -> return (x,ncs))+#elif 0+                   AT.sepBy1' (liftM T.concat $ AT.many1' AT.anyChar) (AT.char sepchar)+                                   >>= (\x -> return (x,ncs))+#endif+#else+                      AT.parseOnly+                           ( ( AT.sepBy1'+#if 1+                                 (AT.takeWhile (/=':'))+                                 (AT.char ':')+#else+                                 (AT.many1' AT.anyChar)+                                 (AT.symbol ":")+--                               (AT.string $ T.singleton sepchar)+#endif+                             )+                             >>= \ x -> return x+--                           >>= \ x -> return $ liftM T.pack x+                             >>= \ y -> return (y,ncs)+                           )+                           seg'+#endif+    !_ <- mytrace ("eblocksncs="++show eblocksncs) $ return ()++#if 0+    let blocks = map T.pack eblocks :: [T.Text]  -- debugging sig.+--  let blocks = map T.concat eblocks :: [T.Text]  -- debugging sig.+--  let blocks = eblocks :: [T.Text]  -- debugging sig.+--  let blocks = eblocks+#else+    let (blocks,ncs) = case eblocksncs of+         Left msg -> error $ "parse_type_constraints: eblocks parse failure: " ++ msg+--       Left msg -> fail $ "parse_type_constraints: eblocks parse failure: " ++ msg  -- XXX No instance for (Monad ((,) [T.Text])) arising from a use of fail!! Why just this fail call, and not the similar others above??...+         Right (blocks,ncs) -> (blocks,ncs) :: ([T.Text],Int)+--       Right blocks -> map T.pack blocks :: [T.Text]+--       Right blocks -> AT.parseOnly ( do ...+#endif+    !_ <- mytrace ("(blocks,ncs)="++show (blocks,ncs)) $ return ()++#if ! ALLOW_ESCAPED_TYPE_LIST_SEPARATOR+    let blocks' = map (helper False) blocks  -- (so get "\\c" not "\c" in names)+    return (blocks',ncs)+#else+-- XXX I do believe this is still broken in the case of "\\\\:".+-- No.     String    Pattern                Blocks+-- 1         :A()    Node TR (A) []         ["A"]             -- correct+-- 2       :A:B()    Node TR (A:B) []       ["A", "B"]        -- correct+-- 3      :A\:B()    "lex error at ':'"                       -- correct+-- 4     :A\\:B()    Node TR (A\:B) []      ["A\\:B"]         -- correct+-- 5    :A\\\:B()    "lex error at ':'"                       -- correct+-- 6   :A\\\\:B()    Node TR (A\\:B) []     ["A\\\\:B"]       -- WRONG!+----------+-- Should be:+-- 6   :A\\\\:B()    Node TR (A\\:B) []     ["A\\\\","B"]+-- (As it happens, the show output looks the same either way, since I'm+-- using : as separator there; if you change separator in the show, it's+-- easier to debug such stuff as this.)+------+-- So, which semantics do we want? Should "A\\\\:B" become ["A\\","B"]?+-- And the "A\\\\\\:B" would become ["A\\\:B"] (sic!).+-- (We allow "[^\]\:" as a pattern, not for typing in patterns, but+-- in the showing of them -- this is wrong actually, I think it should+-- be a double-backslash...).+    -- (4) Now post-process this [Text]: For every block (except the first),+    --     if it begins ':' -- they all do, oops.+    --     So, rather, for every block (except the last), if the final+    --     character is '\\', then fuse this block to its successor.+    --     As to whether or not to elide the (rightmost) '\\' preceding+    --     the colon in the fused pair, is a matter of policy and easily+    --     settled later.+    let blocks' = (map (helper True) . dealWithEscapedSeparators) blocks+--  let blocks' = dealWithEscapedSeparators blocks+    !_ <- mytrace ("blocks'="++show blocks') $ return ()+    return (blocks',ncs)+#endif+#endif+   where+    helper :: Bool -> T.Text -> T.Text+    helper b t+     | T.null t          = t+---  | T.head t == '\\'  = T.concat ["\\\\", helper b $ T.tail t]+     | otherwise         = T.cons (T.head t) $ helper b $ T.tail t+#if ALLOW_ESCAPED_TYPE_LIST_SEPARATOR+    dealWithEscapedSeparators :: [T.Text] -> [T.Text]+    dealWithEscapedSeparators (t1:t2:ts)+     | dofuse     = t' : dealWithEscapedSeparators     ts+     | otherwise  = t' : dealWithEscapedSeparators (t2:ts)+     where+      dofuse+       | T.null t1 || T.null t2      = True+       | T.last (T.init t1) == '\\'  = False  -- sic+       | otherwise                   = T.last t1 == '\\'+---    | otherwise                   = T.last t1 == '\\' && T.head t2 == ':'+      t' | dofuse     = T.concat [t1,':' `T.cons` t2]+         | otherwise  = t1+    dealWithEscapedSeparators x = x+#endif+  {-# INLINE parse_type_constraints #-}++-------------------------------------------------------------------------------++  -- Try attoparsec.++-- XXX If you toggle this, don't forget to also toggle+-- the one in Compile_shared_utils2.hs (compilePat_).+#if 1++--compileUsingAttoparsec :: String -> AT.Result [Pattern]+--compileUsingAttoparsec :: T.Text -> AT.Result [Pattern]+--compileUsingAttoparsec :: BL.ByteString -> AL.Result [Pattern]+  compileUsingAttoparsec input+--  = let rslt = AT.parse (parsePatsTop input) input) T.empty+--let A.Partial f = A.parse (someWithSep A.skipSpace A.decimal) $ B.pack "123 45  67 89" in f B.empty+--Done "" [123,45,67,89]+   = AT.feed (AT.parse parsePatsTop input) T.empty+-- = AT.parse parsePatsTop input+-- = AT.parse (AT.many' $ parsePat emptyPatNodeAttrs) input+-- = AL.parse (AL.many' $ parsePat emptyPatNodeAttrs) input+-- = AL.parse (AL.many' $ parsePat emptyPatNodeAttrs) $ BL.pack input++#else++--compileUsingAttoparsec :: T.Text -> Either String [Pattern]+--compileUsingAttoparsec :: String -> Either String Pattern+  compileUsingAttoparsec :: T.Text -> Either String [Pattern]+  compileUsingAttoparsec input+   = AT.parseOnly parsePatsTop input+-- = AT.parseOnly (AT.many' $ parsePat emptyPatNodeAttrs) $ T.pack input+-- = AT.parseOnly (parsePat emptyPatNodeAttrs <* endOfInput) $ T.pack input+-- = AT.parseOnly (AT.many' $ parsePat emptyPatNodeAttrs) $ B.pack input+-- = AT.parseOnly (AT.many' $ parsePat emptyPatNodeAttrs <* endOfInput) $ B.pack input -- no!++#endif++-------------------------------------------------------------------------------++#else++--- #error NOTE TO SELF: Change CPP so if new grammar and h98_frag, allow it but omit compilePat from the API (with a warning, and with suitable alternate Haddock comments).++  compilePat' :: String -> Pattern+  compilePat' _ = error "\nSorry, at this time (version 0.6.0.*) there is no non-attoparsec parser\nfor the new pattern grammar.  This also implies that HASKELL98_FRAGMENT\nhas no pattern DSL facilities (except for showPat), and it is necessary\nto work with the PatNode constructors directly.  The situation should\nbe remedied by version 0.6.1."++#endif++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Compile_old_grammar.hs view
@@ -0,0 +1,260 @@++-------------------------------------------------------------------------------++  {-  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++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Compile_shared_utils.hs view
@@ -0,0 +1,174 @@++-------------------------------------------------------------------------------++  {-  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]++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Compile_shared_utils2.hs view
@@ -0,0 +1,505 @@++-------------------------------------------------------------------------------++  {-  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 USE_ATTOPARSEC+  {-# LANGUAGE OverloadedStrings #-}+#endif++#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 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++  import Data.List ( intercalate )+  import Data.Char ( isDigit )+  import Data.Maybe ( isNothing, fromJust )+  import Data.Maybe ( isJust )++  import Debug.Trace ( trace )+#if USE_WW_DEEPSEQ+  -- 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 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+#if USE_ATTOPARSEC+  import qualified Data.Attoparsec.Text as AT ( IResult(..) )+--import qualified Data.Attoparsec.ByteString as AB ( IResult(..) )+--import Data.Attoparsec.ByteString.Lazy+  import qualified Data.Text as T+  import qualified Data.ByteString.Lazy as BL+  import Control.DeepSeq.Bounded.Compile_new_grammar ( compileUsingAttoparsec )+#else+  import Control.DeepSeq.Bounded.Compile_new_grammar ( compilePat' )+#endif+#else+  import Control.DeepSeq.Bounded.Compile_old_grammar ( compilePat' )+#endif++-------------------------------------------------------------------------------++#if DO_TRACE+  mytrace = trace+#else+  mytrace _ = id+#endif++-------------------------------------------------------------------------------++  -- XXX I realise this should use attoparsec or something...++  -- 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++#if USE_ATTOPARSEC++  compilePat_ :: String -> Pattern+  compilePat_ str+   | null plst        = error "compilePat: syntax error"+--- | null plst         = error "compilePat: empty pattern (syntax error)"+#if 1+   | length plst > 1  = setPatternPatNodeUniqueIDs 0 $ liftPats plst+#else+   | length plst > 1  = error $ "compilePat: disconnected pattern (not rooted)"+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+                                ++ "\nPerhaps you used parentheses instead of braces?"+#else+                                ++ ""+#endif+#endif+--- | not $ null s'     = error $ "compilePat: parse error: not all input consumed\nRemaining: " ++ s'+   | otherwise         = setPatternPatNodeUniqueIDs 0 $ head plst+--- | otherwise         = head plst+   where++-- XXX If you toggle this, don't forget to also toggle the+-- one in Compile_new_grammar.hs (compileUsingAttoparsec).+#if 1++#if 1+#if 0+    plst = ff (compileUsingAttoparsec $ str)+--  plst = ff (compileUsingAttoparsec $ BL.pack str)+    ff :: AT.IResult BL.ByteString [Pattern] -> [Pattern]+#else+    plst = ff (compileUsingAttoparsec $ T.pack str)+    ff :: AT.IResult T.Text [Pattern] -> [Pattern]+#endif+    ff rslt = plst+     where+      plst = case rslt of+              AT.Fail leftovers ctxs msg+               -> error $ "compilePat: " ++ msg ++ "\nInput remaining: " ++ T.unpack leftovers+              AT.Partial f_leftovers+               -> ff $ f_leftovers ""+---            -> error $ "compilePat: parser demands more input"+---            -> error_leftovers leftovers r+              AT.Done leftovers r+               -> if T.null leftovers then r+                  else error_leftovers leftovers r+#else+    rslt = compileUsingAttoparsec str+    plst = case rslt of+            Fail leftovers ctxs msg+             -> error $ "compilePat: " ++ msg ++ "\nInput remaining: " ++ T.unpack leftovers+            Partial f_leftovers+             -> f_leftovers ""+---          -> error $ "compilePat: parser demands more input"+---          -> error_leftovers leftovers r+            Done leftovers r+             -> if T.null leftovers then r+                else error_leftovers leftovers r+#endif+    error_leftovers s r = error $ "compilePat: input not completely consumed\nInput remaining: " ++ T.unpack s ++ "\nPatterns so far parsed: " ++ show r++#else++    esp = compileUsingAttoparsec $ T.pack str+    plst = case esp of+            Left s -> error $ "compilePat: parse error: " ++ s+            Right plst -> plst++#endif++#else+-- else ! USE_ATTOPARSEC++  compilePat_ :: String -> Pattern+  compilePat_ str = compilePat' str++#endif++#else+-- else ! NEW_IMPROVED_PATTERN_GRAMMAR++  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)++    | WR{} <- pas  = ""    ++ descend chs ++ perhapsEmptySubpatterns+#if NEW_CONCRETE_WI_AND_WS+#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+#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 VACANT_HASH+    | WI{} <- pas  = " "   ++ descend chs+#else+#if NEW_CONCRETE_WI_AND_WS+#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+#else+    | WI{} <- pas  = "#"   ++ descend chs+#endif+#endif+#if USE_WW_DEEPSEQ+    | WW{} <- pas  = "*"   ++ descend chs+#endif++#if 1++    | TR{} <- pas  = ""    ++ descend chs ++ perhapsEmptySubpatterns+--- #if NEW_CONCRETE_WI_AND_WS+--- #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+--- #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 VACANT_HASH+    | TI{} <- pas  = " "   ++ descend chs+#else+#if NEW_CONCRETE_WI_AND_WS+#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+#else+    | TI{} <- pas  = "#"   ++ descend chs+#endif+#endif+#if USE_WW_DEEPSEQ+    | TW{} <- pas  = "*"   ++ descend chs+#endif++#else++    | TR{} <- pas  = ":"   ++ treps_str ++ descend chs ++ perhapsEmptySubpatterns+#if VACANT_HASH+    | TI{} <- pas  = " ::" ++ treps_str ++ closeTINW+#else+#if NEW_CONCRETE_WI_AND_WS+#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+    | TI{} <- pas  = "0::" ++ treps_str ++ closeTINW+#else+    | TI{} <- pas  = ".::" ++ treps_str ++ closeTINW+#endif+#else+    | TI{} <- pas  = "#::" ++ treps_str ++ closeTINW+#endif+#endif+--- #if NEW_CONCRETE_WI_AND_WS+---- #if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9+---- | TS{} <- pas  = "1:" ++ treps_str ++ closeTINW+---- #else+---- | TS{} <- pas  = "!:" ++ treps_str ++ closeTINW+---- #endif+--- #else+---- | TS{} <- pas  = ".:" ++ treps_str ++ closeTINW+--- #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 ++ "::" ++ treps_str ++ closeTINW+#else+    | TN{} <- pas  = "*"   ++ show n ++ "::" ++ treps_str ++ closeTINW+#endif+#if USE_WW_DEEPSEQ+    | TW{} <- pas  = "*::" ++ treps_str ++ closeTINW+#endif++#endif++   where+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+    emptySubpatterns = "{}"+#else+    emptySubpatterns = "()"+#endif+#if NEW_SEMICOLON_TYPE_LIST+    closeTINW = ""+#else+    closeTINW = emptySubpatterns+#endif+    perhapsEmptySubpatterns = if null chs then emptySubpatterns else ""+    as = getPatNodeAttrs pas+    n = depth as+    treps = typeConstraints as+#if TYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR+    treps_str = intercalate " " treps+#else+#if NEW_SEMICOLON_TYPE_LIST+    treps_str = intercalate ";" treps ++ ":"+#else+    treps_str = intercalate ":" treps+#endif+#endif++#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++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Flags.hs view
@@ -0,0 +1,116 @@++-------------------------------------------------------------------------------++  {-  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++------------------------------------------------------------------++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Generic.hs view
@@ -0,0 +1,131 @@++-------------------------------------------------------------------------------++-- |+-- Module      :  Control.DeepSeq.Bounded.Generic+-- Copyright   :  Andrew G. Seniuk 2014-2015+-- License     :  BSD-style (see the LICENSE file)+--+-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>+-- Stability   :  provisional+-- Portability :  GHC+--+-- Support for generic deriving (via <http://hackage.haskell.org/package/generics-sop/docs/Generics-SOP.html Generics.SOP>) of+-- <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataN.html#t:NFDataN NFDataN> and+-- <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP NFDataP> instances.+-- Also, @SOP@ generic functions implementing <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Seqable.html Seqable> without a class and instances.+--+-- This metaboilerplate is standard for using the generic deriving facilities of <http://downloads.haskell.org/~ghc/latest/docs/html/libraries/base/GHC-Generics.html 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 ( NFDataN(..), grnfn, NFDataP(..), grnfp )+-- > import Control.DeepSeq.Generic ( NFData(..), genericRnf )+-- > import GHC.Generics ( Generic )    -- for deriving NFData+-- > import Data.Typeable ( Typeable )  -- for name-constrained pattern nodes+-- > import Control.DeepSeq.Bounded ( forcen, 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 = mainP+-- > mainN = return $! forcen 3         (A1 (B2 undefined) A2) :: IO TA+-- > mainP = return $! forcep "((!).)"  (A1 (B2 undefined) A2) :: IO TA+-- > mainS = return $! force_ Propagate (A1 (force_ Propagate (B2 undefined)) A2) :: IO TA++-------------------------------------------------------------------------------++-- GHC 7.10.1-rc1 : for some reason with this compiler, Cabal 1.22+-- (the earliest Cabal that works with GHC 7.10) does not properly+-- initialise the USE_SOP flag to True, despite .cabal file default.+-- Some flags seem fine, but not this one! [I would report a bug+-- but things are so in flux over here that usually it turns out+-- to be my fault...].+--- #if USE_SOP+--- #error USE_SOP HERE+--- #endif++  module Control.DeepSeq.Bounded.Generic+  (++      -- * Stratified Generic Forcing++#if USE_SOP+      grnfn   ,+#else+      genericRnfn   ,+--    genericRnfnV1   ,+#endif++      -- * Pattern-based Generic Forcing++#if USE_SOP+#if USE_SOP+      grnfp   ,+#else+#if 1+      genericRnfp   ,+#if 0+      genericRnfpV1   ,+#endif+#endif+#endif+#endif++      -- * \"Molecular\" Generic Forcing++#if USE_SOP+      grnf_   ,+      gseq_   ,+      gforce_   ,+#endif++#if 0+      -- * "Control.DeepSeq" re-exports+      deepseq   ,+      force   ,+      NFData(rnf)   ,+      ($!!)   ,+#endif++  )+  where++-------------------------------------------------------------------------------++  -- In its own category, relative to GNFDataN and GNFDataP.+  -- A GHC.Generics alternative is also quite possible?+  -- Both these still require SOP instances to be derived+  -- for user data types, however, which ... well, so does+  -- the current version of Seqable (require NFDataN instances)...+#if USE_SOP+  import Control.DeepSeq.Bounded.Generic.GSeqable+#endif++  import Control.DeepSeq.Bounded.Generic.GNFDataN+#if USE_SOP+  import Control.DeepSeq.Bounded.Generic.GNFDataP+#endif++--import Control.DeepSeq.Bounded+--import Control.DeepSeq  -- needed?+--import GHC.Generics++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Generic/GNFDataN.hs view
@@ -0,0 +1,327 @@++-------------------------------------------------------------------------------++  {-  LANGUAGE CPP #-}++#define USE_TRACE 1++-------------------------------------------------------------------------------++#if USE_SOP+  {-# LANGUAGE DataKinds #-}+  {-# LANGUAGE TypeFamilies #-}+  {-# LANGUAGE ConstraintKinds #-}+#if __GLASGOW_HASKELL__ < 708+  {-# LANGUAGE GADTs #-}+#endif+  {-# LANGUAGE TemplateHaskell #-}+#else+  {-# LANGUAGE BangPatterns #-}+  {-# LANGUAGE TypeOperators #-}+  {-# LANGUAGE FlexibleContexts #-}+  {-  LANGUAGE MultiParamTypeClasses #-}+  {-  LANGUAGE Rank2Types #-}+#endif++  {-  LANGUAGE AllowAmbiguousTypes #-}++  {-# LANGUAGE ScopedTypeVariables #-}++-------------------------------------------------------------------------------++-- |+-- Module      :  Control.DeepSeq.Bounded.Generic.GNFDataN+-- Copyright   :  Andrew G. Seniuk 2014-2015+-- License     :  BSD-style (see the LICENSE file)+--+-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>+-- Stability   :  provisional+-- Portability :  GHC+--+-- Support for generic deriving (via <http://hackage.haskell.org/package/generics-sop/docs/Generics-SOP.html Generics.SOP>) of 'NFDataN' instances.+--+-- 'NFDataN' does not have any superclasses.+--+-- It is also possible to derive instances using "GHC.Generics", which+-- avoids SOP and TH, but if you plan to use 'NFDataP' then SOP is required.+-- (SOP can be used without TH if necessary; the interested reader is+-- referred to SOP documentation.)+--+-- 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 GADTs #-}  -- for GHC < 7.8 (== 7.6.3)+-- > +-- > import Generics.SOP.TH+-- > import Control.DeepSeq.Bounded ( NFDataN(..), grnfn )+-- > import GHC.Generics ( Generic )+-- >+-- > import Control.DeepSeq.Bounded ( forcen )+-- > +-- > data TA = A1 TB TA | A2  deriving ( Generic )+-- > instance NFDataN TA where rnfn = grnfn+-- > +-- > data TB = B1 Int | B2 TA  deriving ( Generic )+-- > instance NFDataN TB where rnfn = grnfn+-- > +-- > deriveGeneric ''TA+-- > deriveGeneric ''TB+-- >+-- > main = return $! forcen 3 (A1 (B2 undefined) A2)++-------------------------------------------------------------------------------++  module Control.DeepSeq.Bounded.Generic.GNFDataN+  (++#if USE_SOP+      grnfn+#else+      genericRnfn+--  , genericRnfnV1+#endif++#if 0+      -- * "Control.DeepSeq" re-exports+    , deepseq+    , force+    , NFData(rnf)+    , ($!!)+#endif++  )+  where++-------------------------------------------------------------------------------++#if ! JUST_ALIAS_GNFDATAN+  import Control.DeepSeq.Bounded.NFDataN+#endif++#if USE_SOP+  import Generics.SOP+--import Generics.SOP.TH  -- not here, but rather in the module needing to generically derive an NFDataN instance+#else+  import GHC.Generics+#endif++#if 0+  -- actually can be used in the SOP implementation (and is in the+  -- example in the paper as well as the API docs), not that we nec.+  -- want this; but there's no n=infinity rnfn, so I don't see how+  -- else to manage it... after the "collapse"...+  import Control.DeepSeq ( NFData, deepseq )+--import Control.DeepSeq ( rnf )  -- actually can be used in the SOP implementation, not that we necessarily want this; but there's no n=infinity rnfn, so I don't see how else to manage it... after the "collapse"...+#if 0+  import Control.DeepSeq  -- needed?+#endif+#endif++  import Debug.Trace ( trace )++-------------------------------------------------------------------------------++#if USE_SOP++#if JUST_ALIAS_GNFDATAN++  grnfn :: (Generic a, All2 Generic (Code a)) => Int -> a -> ()+  grnfn n x = grnfnS n (from x)++  grnfnS :: forall yss y. (All2 Generic yss, All2 Generic (Code y)) => Int -> SOP I yss -> ()+--grnfnS :: Int -> SOP I xss -> ()+  grnfnS n (SOP (S xss)) = grnfnS n (SOP xss)+  grnfnS n (SOP (Z xs))  = grnfnP (-1+n) xs+   where+    grnfnP :: forall ys. (All Generic ys) => Int -> NP I ys -> ()+--  grnfnP :: forall ys. (All Generic ys, All2 Generic (Code y)) => Int -> NP I ys -> ()+--  grnfnP :: (All Generic xs) => Int -> NP I xs -> ()+--  grnfnP :: Int -> NP I xs -> ()+    grnfnP n Nil          = ()+    grnfnP n (I x :* xs)+     | n <= 0             = ()+     | otherwise          = rnfn n x `seq` grnfnP n xs++  rnfn :: (Generic a, All2 Generic (Code a)) => Int -> a -> ()+--rnfn :: Generic a => Int -> a -> ()+  rnfn n x = grnfn n x++#else++#if 1++  grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()+  grnfn n x = grnfnS n (from x)++  grnfnS :: (All2 NFDataN xss) => Int -> SOP I xss -> ()+  grnfnS n (SOP (Z xs))  = grnfnP (-1+n) xs+  grnfnS n (SOP (S xss)) = grnfnS n (SOP xss)++  grnfnP :: (All NFDataN xs) => Int -> NP I xs -> ()+  grnfnP n Nil          = ()+  grnfnP n (I x :* xs)+   | n <= 0             = ()+   | otherwise          = rnfn n x `seq` grnfnP n xs++#else++  -- XXX NOPE! This causes decrementing as traverse ctor args!+  -- However, the above explicit recursive version works!+  grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()+-- Ah-hah!+  grnfn n = rnfn n . hcollapse . hcliftA p (K . (if n <= 0 then const () else rnfn (-1+n)) . unI) . from+-- This doesn't help:+--grnfn n = let n_ = (-1+n) in+--          rnfn n . hcollapse . hcliftA p (K . rnfn n_ . unI) . from+-- So this is the closest I have so far, but it's broken b/c it+-- seems to add to the requisite depth, the index of the (leftmost?)+-- sibling bearing "undefined".+--grnfn n = rnfn n . hcollapse . hcliftA p (K . rnfn (-1+n) . unI) . from+-- This just delays everything by one more.+--grnfn n = rnfn (-1+n) . hcollapse . hcliftA p (K . rnfn (-1+n) . unI) . from+-- I don't think this was my problem anyhow, as arities aren't+-- high enough to expect it to affect depth of n [??...]+-- (And it doesn't work anyhow -- way too much stuff gets forced!)+--grnfn n = rnf    . hcollapse . hcliftA p (K . rnfn (-1+n) . unI) . from+    where p = Proxy :: Proxy NFDataN+-- From the SOP paper:+--   grnfn :: (Generic a, All2 NFDataN (Code a)) => a -> ()+--   grnfn = rnfn . hcollapse . hcliftA p (K . rnf . unI) . from+--     where p = Proxy :: Proxy NFDataN+-- "We can understand this function by tracking the types. First+-- we use from to translate from a to the generic representation+-- SOP I (Code a). We then map rnf (modulo newtype wrapping and+-- unwrapping) across this sum of products to get a value of type+-- SOP (K ()) (Code a), which we can collapse to a list of type [()].+-- Finally, we can reduce that list to a single unit value through one+-- more application of rnf.  We use All2 in the type of grnf to require+-- that the types of the leaves must all satisfy NFData."++#endif++#endif++-------------------------------------------------------------------------------++#else++  genericRnfn :: (Generic a, GNFDataN (Rep a)) => Int -> a -> ()+  genericRnfn n = grnfn_ n . from+--genericRnfn n = grnfn_ (-1+n) . from+  {-# INLINE genericRnfn #-}++--  Hidden internal type-class+--+-- Note: the 'V1' instance is not provided for 'GNFDataN' in order to+-- trigger a compile-time error; see 'GNFDataNV1' which defers this to+-- a runtime error.+  class GNFDataN f where+    grnfn_ :: Int -> f a -> ()+#if 1 || USE_TRACE+    grnfn_ n x = trace "HH-0" $ ()  -- never seen, so far...+#else+    grnfn_ n x = ()+#endif+--  grnfn_ n x = rnfn n $ to x+--  grnfn_ n x = rnfn n x++  instance GNFDataN U1 where+#if USE_TRACE+    grnfn_ _ !U1 = trace "HH-U1" $ ()+#else+    grnfn_ _ !U1 = ()+#endif+    {-# INLINE grnfn_ #-}++  instance NFDataN a => GNFDataN (K1 i a) where+#if USE_TRACE+#if 1+    grnfn_ n k@(K1 x) | n <= 0     = trace "()-K1" $ ()+--                    | otherwise  = trace "HH-K1" $ k `seq` rnfn (-1+n) x+--                    | otherwise  = trace "HH-K1" $ x `seq` rnfn (-1+n) x+                      | otherwise  = trace "HH-K1" $ rnfn (-1+n) x+#else+    grnfn_ n | n <= 0     = const ()+             | otherwise  = trace "HH-2" $ rnfn (-1+n) . unK1+#endif+#else+    grnfn_ n (K1 x) | n <= 0     = ()+                    | otherwise  = rnfn (-1+n) x+#endif+    {-# INLINE grnfn_ #-}++  instance GNFDataN a => GNFDataN (M1 i c a) where+#if USE_TRACE+#if 0+#elif 1+    grnfn_ n (M1 x) | n <= 0     = trace "()-M1" $ ()  -- prob. unnec.+                    | otherwise  = trace "HH-M1" $ grnfn_ n x+#elif 0+    grnfn_ n (M1 x) | n <= 0     = trace "()-M1" $ ()+                    | otherwise  = trace "HH-M1" $ grnfn_ (-1+n) x+#elif 0+    grnfn_ n | n <= 0     = const ()+             | otherwise  = trace "HH-3" $ grnfn_ (-1+n) . unM1+#endif+#else+    grnfn_ n (M1 x) | n <= 0     = ()  -- prob. unnec.+                    | otherwise  = grnfn_ n x+#endif+    {-# INLINE grnfn_ #-}++  instance (GNFDataN a, GNFDataN b) => GNFDataN (a :*: b) where+#if USE_TRACE+#if 0+#elif 1+    grnfn_ n (x :*: y) | n <= 0     = trace "()-:*:" $ ()  -- prob. unnec.+                       | otherwise  = trace "HH-:*:" $ let n' = n in grnfn_ n' x `seq` grnfn_ n' y+#elif 0+    grnfn_ n (x :*: y) | n <= 0     = trace "()-:*:" $ ()+                       | otherwise  = trace "HH-:*:" $ let n' = -1+n in grnfn_ n' x `seq` grnfn_ n' y+#elif 0+    grnfn_ n (x :*: y) | n <= 0     = ()+                       | otherwise  = trace "HH-4" $ let n' = -1+n in grnfn_ n' x `seq` grnfn_ n' y+#endif+#else+    grnfn_ n (x :*: y) | n <= 0     = ()  -- prob. unnec.+                       | otherwise  = let n' = n in grnfn_ n' x `seq` grnfn_ n' y+#endif+    {-# INLINE grnfn_ #-}++  instance (GNFDataN a, GNFDataN b) => GNFDataN (a :+: b) where+#if USE_TRACE+#if 0+#elif 1+    grnfn_ n (L1 x) | n <= 0     = trace "()-L1" $ ()  -- prob. unnec.+                    | otherwise  = trace "HH-L1" $ grnfn_ n x+    grnfn_ n (R1 x) | n <= 0     = trace "()-L2" $ ()  -- prob. unnec.+                    | otherwise  = trace "HH-L2" $ grnfn_ n x+#elif 0+    grnfn_ n (L1 x) | n <= 0     = trace "()-L1" $ ()+                    | otherwise  = trace "HH-L1" $ grnfn_ (-1+n) x+    grnfn_ n (R1 x) | n <= 0     = trace "()-L2" $ ()+                    | otherwise  = trace "HH-L2" $ grnfn_ (-1+n) x+#elif 0+    grnfn_ n (L1 x) | n <= 0     = ()+                    | otherwise  = trace "HH-5L" $ grnfn_ (-1+n) x+    grnfn_ n (R1 x) | n <= 0     = ()+                    | otherwise  = trace "HH-5R" $ grnfn_ (-1+n) x+#endif+#else+    grnfn_ n (L1 x) | n <= 0     = ()  -- prob. unnec.+                    | otherwise  = grnfn_ n x+    grnfn_ n (R1 x) | n <= 0     = ()  -- prob. unnec.+                    | otherwise  = grnfn_ n x+#endif+    {-# INLINE grnfn_ #-}++#endif++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Generic/GNFDataP.hs view
@@ -0,0 +1,86 @@++-------------------------------------------------------------------------------++{-  LANGUAGE CPP #-}++-------------------------------------------------------------------------------++-- |+-- Module      :  Control.DeepSeq.Bounded.Generic.GNFDataP+-- 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+  (++#if NEW_IMPROVED_PATTERN_GRAMMAR+    module Control.DeepSeq.Bounded.Generic.GNFDataP_new_grammar  ,+#else+    module Control.DeepSeq.Bounded.Generic.GNFDataP_old_grammar  ,+#endif++  )+  where++-------------------------------------------------------------------------------++  -- for Haddock!+  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+#else+  import Control.DeepSeq.Bounded.Generic.GNFDataP_old_grammar+#endif++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Generic/GNFDataP_new_grammar.hs view
@@ -0,0 +1,454 @@++-------------------------------------------------------------------------------++{-  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++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Generic/GNFDataP_old_grammar.hs view
@@ -0,0 +1,411 @@++-------------------------------------------------------------------------------++{-  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++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Generic/GSeqable.hs view
@@ -0,0 +1,294 @@++-------------------------------------------------------------------------------++  {-  LANGUAGE CPP #-}++#define USE_TRACE 1++#define SEQHARN_WRAP_PARENT 1++-------------------------------------------------------------------------------++#if USE_SOP+  {-# LANGUAGE DataKinds #-}+  {-# LANGUAGE TypeFamilies #-}+  {-# LANGUAGE ConstraintKinds #-}+#if __GLASGOW_HASKELL__ < 708+  {-# LANGUAGE GADTs #-}+#endif+  {-# LANGUAGE TemplateHaskell #-}+#else+  {-# LANGUAGE BangPatterns #-}+  {-# LANGUAGE TypeOperators #-}+  {-# LANGUAGE FlexibleContexts #-}+  {-  LANGUAGE MultiParamTypeClasses #-}+  {-  LANGUAGE Rank2Types #-}+#endif++  {-# LANGUAGE ScopedTypeVariables #-}+  {-  LANGUAGE AllowAmbiguousTypes #-}++-------------------------------------------------------------------------------++-- |+-- Module      :  Control.DeepSeq.Bounded.Generic.GSeqable+-- Copyright   :  Andrew G. Seniuk 2014-2015+-- License     :  BSD-style (see the LICENSE file)+--+-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>+-- Stability   :  provisional+-- Portability :  GHC+--+-- Generic function version of <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-Seqable.html Seqable> (via <http://hackage.haskell.org/package/generics-sop/docs/Generics-SOP.html Generics.SOP>).+--+-- Probably, a "GHC.Generics" variant would also be possible.+--+-- This metaboilerplate is standard for using the generic deriving+-- facilities of <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 DeriveDataTypeable #-}+-- > {-# LANGUAGE GADTs #-}  -- for GHC < 7.8 (== 7.6.3)+-- > +-- > import Generics.SOP.TH+-- > import Control.DeepSeq.Bounded.Seqable+-- > +-- > data TA = A1 TB TA | A2+-- > data TB = B1 Int | B2 TA+-- > +-- > deriveGeneric ''TA+-- > deriveGeneric ''TB+-- > +-- > main = return $! force_ Propagate (A1 (force_ Propagate (B2 undefined)) A2)++-------------------------------------------------------------------------------++  module Control.DeepSeq.Bounded.Generic.GSeqable+  (++#if USE_SOP+      grnf_+    , gseq_+    , gforce_+#else+      genericSeq_+--  , genericSeq_V1+#endif++    , seqharn++  )+  where++-------------------------------------------------------------------------------++  import Control.DeepSeq.Bounded.Pattern ( SeqNode(..) )+--import Control.DeepSeq.Bounded.Seqable ( SeqNode(..) )++#if USE_SOP+  import Generics.SOP+--import Generics.SOP.TH  -- not here, but rather in the module needing to generically derive an Seqable instance+#else+  import GHC.Generics+#endif++  import Control.Parallel ( par )++  import Data.Typeable ( typeOf )+  import Data.Typeable ( Typeable )++  import Debug.Trace ( trace )++-------------------------------------------------------------------------------++#if USE_SOP++  gseq_ :: Generic a => SeqNode -> a -> b -> b+  gseq_ Insulate     a b  =                 b+  gseq_ k            a b  = grnf_ k a `seq` b  -- sic! both Propagate and Spark++  gforce_ :: Generic a => SeqNode -> a -> a+  gforce_ Insulate     a  =                 a+  gforce_ k            a  = grnf_ k a `seq` a  -- sic! both Propagate and Spark++  grnf_ :: Generic a => SeqNode -> a -> ()+  grnf_ Insulate x = ()+  grnf_ k x = grnf_S k (from x)++  grnf_S :: SeqNode -> SOP I xss -> ()+#if USE_PAR_SEQABLE+  grnf_S Propagate       (SOP (Z xs))   = grnf_P xs `seq` ()+  grnf_S {-Spark-}_      (SOP (Z xs))   = grnf_P xs `par` ()+#else+  grnf_S {-Propagate-}_  (SOP (Z xs))   = grnf_P xs `seq` ()+#endif+  grnf_S k               (SOP (S xss))  = grnf_S k (SOP xss)++  grnf_P :: NP I xs -> ()+  grnf_P Nil = ()+  grnf_P (I x :* xs) = x `seq` grnf_P xs++-------------------------------------------------------------------------------++#if 1++  -- | @'seqharn' x@ is semantically the same as @x@, except its+  -- strictness, parallellism, etc. can be tweaked dynamically...+  --+  -- > seqharn = to . hliftA (gforce_ Insulate) . from+  --+  -- /I can see how this would be useful at compile-time, but how can we use this if seqharn only runs post-compilation?  Or is it just analogous to forcep?.../+  --+  -- /Also: How exactly to/ dynamically configure  /this?.../+  +  seqharn :: Generic a => a -> a+-- hliftA f xs = hpure (fn f) ` hap ` xs+  seqharn = to . hliftA (gforce_ Insulate) . from+--seqharn x = to $ hliftA (gforce_ Insulate) $ from x+--seqharn x = to $ hpure (fn $ gforce_ Insulate) `hap` from x+--seqharn x = to (hap (hpure (fn (gforce_ Insulate))) (from x))+--seqharn x = to $ hap (hpure (fn $ gforce_ Insulate)) $ from x++#if 0+  -- | The 'PatNode's of the 'Pattern' argument carry 'SeqNode'+  -- programmability information in the 'seqNode' field.+  -- The 'PatNode' must be 'WR' for interior nodes and 'WS' for leaves,+  -- such as returned by 'mkPat'.+  -- Pattern match is an error.+  configure_seqharn :: Generic a => Pattern -> SeqNode a -> SeqNode a+  configure_seqharn (Node pn cs) (SeqNode k x)+   | WI{} <- pn  = ...+#endif++-- No joy.+-- What if just replace every node with a SeqNode'?+-- But that's what I'm trying to do...++#if 0++  data SeqNode' a =+           Insulate' a+---      | Conduct' a+         | Propagate' a+#if USE_PAR_SEQABLE+         | Spark' a+#endif+    deriving ( Eq, Ord )+  unSeqNode' :: SeqNode' a -> a+  unSeqNode' (Insulate' x) = x+  unSeqNode' (Propagate' x) = x+#if USE_PAR_SEQABLE+  unSeqNode' (Spark' x) = x+#endif++#if 1++-- Yet here it is in SYB: ... oops, no, only if+-- the user passes the generic function in (familiar+-- quandry, esp from sai-shape-syb)...+  testboo :: Data a => GenericT -> a -> SeqNode' a+  testboo fg x = everywhere fg x+   where+    fg :: ...++#else++-- XXX Maybe this just isn't possible (and fortunately the function+-- approach even works!...) -- it seems like I want to say here+-- that SeqNode' a is equivalent to a as a type, but that's not+-- correct -- they will be equivalent, in some sense, as VALUES+-- (in a given term context), but they are not equivalent as types.+-- In particular, SeqNode' a has arity 1 for every constructor, but+-- a itself might be of any arity.+--   Still maybe there's some way ... the AST makes sense, anyway...+-- If we have a function a -> a, we can lift it to SeqNode' a -> SeqNode' a.+-- Or we can us unSeqNode'?...+--------+-- Note that TypeRep (returned by typeOf) does have an Eq instance.+-- However, I think the problem of supplying lists of TypeRep+-- instead of String type names, for stoptys argument, was+-- a deterrent...+--testboo :: forall a. (SeqNode' a ~ a, Generic a) =>+  testboo :: Generic a => [String] -> a -> SeqNode' a+--testboo :: (Typeable a, Generic a) => [String] -> a -> SeqNode' a+--testboo :: (Typeable a, Generic a, All2 Typeable (Code a)) => [String] -> a -> SeqNode' a+  testboo stoptys x = x''+   where+--  proxy = Proxy :: a+--  tstr = show $ typeOf x+--  x' = to $ hpure (fn (testboo stoptys)) `hap` from x+--  x' = to $ hcliftA proxy (unSeqNode' . testboo stoptys) $ from x+    x' = to $ hliftA (testboo stoptys) $ from x+--- x' = to $ hpure (I . fn . testboo stoptys . unI) `hap` from x+--- x' = to $ hpure (fn $ I . testboo stoptys . unI) `hap` from x+--  x' = to $ hpure (fn $ testboo stoptys) `hap` from x+#if 0+    x'' | elem tstr stoptys  = Insulate' x'+        | otherwise          = Propagate' x'+#else+    x'' | True       = Insulate' x+        | otherwise  = Propagate' x+#endif++#endif++#endif++#else++#if SEQHARN_WRAP_PARENT++  -- | @'seqharn' x@ is semantically the same as @x@, except its+  -- strictness, parallellism, etc. can be tweaked dynamically...+  seqharn :: Generic a => a -> a+  seqharn x = gforce_ Insulate (seqharnS (from x))++  -- From the sum, select the alternative corresponding to the term node.+  -- This alternative is one of the constructors of the data type,+  -- with its arguments represented as a product.+  seqharnS :: SOP I xss -> a+  seqharnS (SOP (Z xs))   = seqharnP xs+  seqharnS (SOP (S xss))  = seqharnS (SOP xss)++  -- Traverse the constructor arguments of the product.+  seqharnP :: NP I xs -> a+  seqharnP Nil = ()+  seqharnP (I x :* xs) = seqharn x `seq` seqharnP xs++#else++  -- | @'seqharn' x@ is semantically the same as @x@, except its+  -- strictness, parallellism, etc. can be tweaked dynamically...+  seqharn :: Generic a => a -> a+  seqharn x = seqharnS (from x)++  -- From the sum, select the alternative corresponding to the term node.+  -- This alternative is one of the constructors of the data type,+  -- with its arguments represented as a product.+  seqharnS :: SOP I xss -> a+  seqharnS (SOP (Z xs))   = seqharnP xs+  seqharnS (SOP (S xss))  = seqharnS (SOP xss)++  -- Traverse the constructor arguments of the product.+  seqharnP :: NP I xs -> a+  seqharnP Nil = ()+  seqharnP (I x :* xs) = (gforce_ Insulate (seqharn x)) `seq` seqharnP xs++#endif++#endif++-------------------------------------------------------------------------------++#else++#error "GSeqable: must use SOP for now..."++#endif++-------------------------------------------------------------------------------+
− src/Control/DeepSeq/Bounded/Generics.hs 
@@ -1,112 +0,0 @@------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Generics--- Copyright   :  (c) 2014, Andrew G. Seniuk--- License     :  BSD-style (see the LICENSE file)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  GHC------ Support for generic deriving (via "Generics.SOP") of 'NFDataN' and 'NFDataP' instances.  Also, "SOP" generic functions implementing "Seqable" without a class and instances.------ This metaboilerplate is standard for using the generic deriving--- facilities of GHC.Generics and Generics.SOP.  Consider--- <http://hackage.haskell.org/package/seqaid seqaid> for--- a turnkey solution.------ > {-# LANGUAGE TemplateHaskell #-}--- > {-# LANGUAGE DataKinds #-}--- > {-# LANGUAGE TypeFamilies #-}--- > {-# LANGUAGE DeriveGeneric #-}--- > {-# LANGUAGE DeriveDataTypeable #-}--- > --- > import Generics.SOP.TH--- > import Control.DeepSeq.Bounded ( NFDataN(..), grnfn, NFDataP(..), grnfp )--- > 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 ( forcen, 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 = mainP--- > mainN = return $! forcen 3          (A1 (B2 undefined) A2) :: IO TA--- > mainP = return $! forcep ".{.{.}.}" (A1 (B2 undefined) A2) :: IO TA--- > mainS = return $! force_ Propagate  (A1 (force_ Propagate (B2 undefined)) A2) :: IO TA-----------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Generics (--#if USE_SOP-      grnf_-    , gseq_-    , gforce_-#endif--#if USE_SOP-    , grnfn-#else-    , genericRnfn---  , genericRnfnV1-#endif--#if USE_SOP-#if USE_SOP-    , grnfp-#else-#if 1-    , genericRnfp-#if 0-    , genericRnfpV1-#endif-#endif-#endif-#endif--#if 0-      -- * "Control.DeepSeq" re-exports-    , deepseq-    , force-    , NFData(rnf)-    , ($!!)-#endif--  ) where-----------------------------------------------------------------------------------  -- In its own category, relative to GNFDataN and GNFDataP.-  -- A GHC.Generics alternative is also quite possible?-  -- Both these still require SOP instances to be derived-  -- for user data types, however, which ... well, so does-  -- the current version of Seqable (require NFDataN instances)...-#if USE_SOP-  import Control.DeepSeq.Bounded.Generics.GSeqable-#endif--  import Control.DeepSeq.Bounded.Generics.GNFDataN-#if USE_SOP-  import Control.DeepSeq.Bounded.Generics.GNFDataP-#endif----import Control.DeepSeq.Bounded---import Control.DeepSeq  -- needed?---import GHC.Generics----------------------------------------------------------------------------------
− src/Control/DeepSeq/Bounded/Generics/GNFDataN.hs 
@@ -1,288 +0,0 @@-----------------------------------------------------------------------------------  {-  LANGUAGE CPP #-}--#define USE_TRACE 1-----------------------------------------------------------------------------------#if USE_SOP-  {-# LANGUAGE DataKinds #-}-  {-# LANGUAGE TypeFamilies #-}-  {-# LANGUAGE ConstraintKinds #-}-  {-# LANGUAGE TemplateHaskell #-}-  {-# LANGUAGE GADTs #-}  -- for GHC 7.6.3-#else-  {-# LANGUAGE BangPatterns #-}-  {-# LANGUAGE TypeOperators #-}-  {-# LANGUAGE FlexibleContexts #-}-  {-  LANGUAGE MultiParamTypeClasses #-}-  {-  LANGUAGE Rank2Types #-}-#endif------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Generics.GNFDataN--- Copyright   :  (c) 2014, Andrew G. Seniuk--- License     :  BSD-style (see the LICENSE file)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  GHC------ Support for generic deriving (via "Generics.SOP") of 'NFDataN' instances.------ 'NFDataN' does not have any superclasses.------ It is also possible to derive instances using 'GHC.Generics', which--- avoids SOP and TH, but if you plan to use 'NFDataP' then SOP is required.--- (SOP can be used without TH if necessary; the interested reader is--- referred to SOP documentation.)------ This metaboilerplate is standard for using the generic deriving--- facilities of GHC.Generics and Generics.SOP.  Consider--- <http://hackage.haskell.org/package/seqaid seqaid> for--- a turnkey solution.------ > {-# LANGUAGE TemplateHaskell #-}--- > {-# LANGUAGE DataKinds #-}--- > {-# LANGUAGE TypeFamilies #-}--- > {-# LANGUAGE DeriveGeneric #-}--- > --- > import Generics.SOP.TH--- > import Control.DeepSeq.Bounded ( NFDataN(..), grnfn )--- > import GHC.Generics ( Generic )--- >--- > import Control.DeepSeq.Bounded ( forcen )--- > --- > data TA = A1 TB TA | A2  deriving ( Generic )--- > instance NFDataN TA where rnfn = grnfn--- > --- > data TB = B1 Int | B2 TA  deriving ( Generic )--- > instance NFDataN TB where rnfn = grnfn--- > --- > deriveGeneric ''TA--- > deriveGeneric ''TB--- >--- > main = return $! forcen 3 (A1 (B2 undefined) A2)-----------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Generics.GNFDataN-#if USE_SOP-  (-      grnfn-#else-  (-      genericRnfn---  , genericRnfnV1-#endif-#if 0-      -- * "Control.DeepSeq" re-exports-    , deepseq-    , force-    , NFData(rnf)-    , ($!!)-#endif-  ) where-----------------------------------------------------------------------------------  import Control.DeepSeq.Bounded.NFDataN--#if USE_SOP-  import Generics.SOP---import Generics.SOP.TH  -- not here, but rather in the module needing to generically derive an NFDataN instance-#else-  import GHC.Generics-#endif--#if 0-  -- actually can be used in the SOP implementation (and is in the-  -- example in the paper as well as the API docs), not that we nec.-  -- want this; but there's no n=infinity rnfn, so I don't see how-  -- else to manage it... after the "collapse"...-  import Control.DeepSeq ( NFData, deepseq )---import Control.DeepSeq ( rnf )  -- actually can be used in the SOP implementation, not that we necessarily want this; but there's no n=infinity rnfn, so I don't see how else to manage it... after the "collapse"...-#if 0-  import Control.DeepSeq  -- needed?-#endif-#endif--  import Debug.Trace ( trace )-----------------------------------------------------------------------------------#if USE_SOP--#if 1--  grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()-  grnfn n x = grnfnS n (from x)--  grnfnS :: (All2 NFDataN xss) => Int -> SOP I xss -> ()-  grnfnS n (SOP (Z xs))  = grnfnP (-1+n) xs-  grnfnS n (SOP (S xss)) = grnfnS n (SOP xss)--  grnfnP :: (All NFDataN xs) => Int -> NP I xs -> ()-  grnfnP n Nil          = ()-  grnfnP n (I x :* xs)-   | n <= 0             = ()-   | otherwise          = rnfn n x `seq` grnfnP n xs--#else--  -- XXX NOPE! This causes decrementing as traverse ctor args!-  -- However, the above explicit recursive version works!-  grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()--- Ah-hah!-  grnfn n = rnfn n . hcollapse . hcliftA p (K . (if n <= 0 then const () else rnfn (-1+n)) . unI) . from--- This doesn't help:---grnfn n = let n_ = (-1+n) in---          rnfn n . hcollapse . hcliftA p (K . rnfn n_ . unI) . from--- So this is the closest I have so far, but it's broken b/c it--- seems to add to the requisite depth, the index of the (leftmost?)--- sibling bearing "undefined".---grnfn n = rnfn n . hcollapse . hcliftA p (K . rnfn (-1+n) . unI) . from--- This just delays everything by one more.---grnfn n = rnfn (-1+n) . hcollapse . hcliftA p (K . rnfn (-1+n) . unI) . from--- I don't think this was my problem anyhow, as arities aren't--- high enough to expect it to affect depth of n [??...]--- (And it doesn't work anyhow -- way too much stuff gets forced!)---grnfn n = rnf    . hcollapse . hcliftA p (K . rnfn (-1+n) . unI) . from-    where p = Proxy :: Proxy NFDataN--- From the SOP paper:---   grnfn :: (Generic a, All2 NFDataN (Code a)) => a -> ()---   grnfn = rnfn . hcollapse . hcliftA p (K . rnf . unI) . from---     where p = Proxy :: Proxy NFDataN--- "We can understand this function by tracking the types. First--- we use from to translate from a to the generic representation--- SOP I (Code a). We then map rnf (modulo newtype wrapping and--- unwrapping) across this sum of products to get a value of type--- SOP (K ()) (Code a), which we can collapse to a list of type [()].--- Finally, we can reduce that list to a single unit value through one--- more application of rnf.  We use All2 in the type of grnf to require--- that the types of the leaves must all satisfy NFData."--#endif-----------------------------------------------------------------------------------#else--  genericRnfn :: (Generic a, GNFDataN (Rep a)) => Int -> a -> ()-  genericRnfn n = grnfn_ n . from---genericRnfn n = grnfn_ (-1+n) . from-  {-# INLINE genericRnfn #-}----  Hidden internal type-class------ Note: the 'V1' instance is not provided for 'GNFDataN' in order to--- trigger a compile-time error; see 'GNFDataNV1' which defers this to--- a runtime error.-  class GNFDataN f where-    grnfn_ :: Int -> f a -> ()-#if 1 || USE_TRACE-    grnfn_ n x = trace "HH-0" $ ()  -- never seen, so far...-#else-    grnfn_ n x = ()-#endif---  grnfn_ n x = rnfn n $ to x---  grnfn_ n x = rnfn n x--  instance GNFDataN U1 where-#if USE_TRACE-    grnfn_ _ !U1 = trace "HH-U1" $ ()-#else-    grnfn_ _ !U1 = ()-#endif-    {-# INLINE grnfn_ #-}--  instance NFDataN a => GNFDataN (K1 i a) where-#if USE_TRACE-#if 1-    grnfn_ n k@(K1 x) | n <= 0     = trace "()-K1" $ ()---                    | otherwise  = trace "HH-K1" $ k `seq` rnfn (-1+n) x---                    | otherwise  = trace "HH-K1" $ x `seq` rnfn (-1+n) x-                      | otherwise  = trace "HH-K1" $ rnfn (-1+n) x-#else-    grnfn_ n | n <= 0     = const ()-             | otherwise  = trace "HH-2" $ rnfn (-1+n) . unK1-#endif-#else-    grnfn_ n (K1 x) | n <= 0     = ()-                    | otherwise  = rnfn (-1+n) x-#endif-    {-# INLINE grnfn_ #-}--  instance GNFDataN a => GNFDataN (M1 i c a) where-#if USE_TRACE-#if 0-#elif 1-    grnfn_ n (M1 x) | n <= 0     = trace "()-M1" $ ()  -- prob. unnec.-                    | otherwise  = trace "HH-M1" $ grnfn_ n x-#elif 0-    grnfn_ n (M1 x) | n <= 0     = trace "()-M1" $ ()-                    | otherwise  = trace "HH-M1" $ grnfn_ (-1+n) x-#elif 0-    grnfn_ n | n <= 0     = const ()-             | otherwise  = trace "HH-3" $ grnfn_ (-1+n) . unM1-#endif-#else-    grnfn_ n (M1 x) | n <= 0     = ()  -- prob. unnec.-                    | otherwise  = grnfn_ n x-#endif-    {-# INLINE grnfn_ #-}--  instance (GNFDataN a, GNFDataN b) => GNFDataN (a :*: b) where-#if USE_TRACE-#if 0-#elif 1-    grnfn_ n (x :*: y) | n <= 0     = trace "()-:*:" $ ()  -- prob. unnec.-                       | otherwise  = trace "HH-:*:" $ let n' = n in grnfn_ n' x `seq` grnfn_ n' y-#elif 0-    grnfn_ n (x :*: y) | n <= 0     = trace "()-:*:" $ ()-                       | otherwise  = trace "HH-:*:" $ let n' = -1+n in grnfn_ n' x `seq` grnfn_ n' y-#elif 0-    grnfn_ n (x :*: y) | n <= 0     = ()-                       | otherwise  = trace "HH-4" $ let n' = -1+n in grnfn_ n' x `seq` grnfn_ n' y-#endif-#else-    grnfn_ n (x :*: y) | n <= 0     = ()  -- prob. unnec.-                       | otherwise  = let n' = n in grnfn_ n' x `seq` grnfn_ n' y-#endif-    {-# INLINE grnfn_ #-}--  instance (GNFDataN a, GNFDataN b) => GNFDataN (a :+: b) where-#if USE_TRACE-#if 0-#elif 1-    grnfn_ n (L1 x) | n <= 0     = trace "()-L1" $ ()  -- prob. unnec.-                    | otherwise  = trace "HH-L1" $ grnfn_ n x-    grnfn_ n (R1 x) | n <= 0     = trace "()-L2" $ ()  -- prob. unnec.-                    | otherwise  = trace "HH-L2" $ grnfn_ n x-#elif 0-    grnfn_ n (L1 x) | n <= 0     = trace "()-L1" $ ()-                    | otherwise  = trace "HH-L1" $ grnfn_ (-1+n) x-    grnfn_ n (R1 x) | n <= 0     = trace "()-L2" $ ()-                    | otherwise  = trace "HH-L2" $ grnfn_ (-1+n) x-#elif 0-    grnfn_ n (L1 x) | n <= 0     = ()-                    | otherwise  = trace "HH-5L" $ grnfn_ (-1+n) x-    grnfn_ n (R1 x) | n <= 0     = ()-                    | otherwise  = trace "HH-5R" $ grnfn_ (-1+n) x-#endif-#else-    grnfn_ n (L1 x) | n <= 0     = ()  -- prob. unnec.-                    | otherwise  = grnfn_ n x-    grnfn_ n (R1 x) | n <= 0     = ()  -- prob. unnec.-                    | otherwise  = grnfn_ n x-#endif-    {-# INLINE grnfn_ #-}--#endif----------------------------------------------------------------------------------
− src/Control/DeepSeq/Bounded/Generics/GNFDataP.hs 
@@ -1,407 +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 #-}-  {-# LANGUAGE GADTs #-}  -- for GHC 7.6.3-  {-# LANGUAGE TemplateHaskell #-}--  -- For tracing only:-  {-# LANGUAGE BangPatterns #-}------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Generics.GNFDataP--- Copyright   :  (c) 2014, Andrew G. Seniuk--- License     :  BSD-style (see the LICENSE file)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  GHC------ Support for generic deriving (via "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 Generics.SOP.  Consider--- <http://hackage.haskell.org/package/seqaid seqaid> for--- a turnkey solution.------ > {-# LANGUAGE TemplateHaskell #-}--- > {-# LANGUAGE DataKinds #-}--- > {-# LANGUAGE TypeFamilies #-}--- > {-# LANGUAGE DeriveGeneric #-}--- > {-# LANGUAGE DeriveDataTypeable #-}--- > --- > 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.Generics.GNFDataP (--      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----------------------------------------------------------------------------------
− src/Control/DeepSeq/Bounded/Generics/GSeqable.hs 
@@ -1,141 +0,0 @@------------------------------------------------------------------------------------- XXX Not only untested, but now unneeded...--- There is no Seqable class, because every instance would default.--- (rnf_ is just a polymorphic function now.)--- The module is left as "Seqable" at least for now.------------------------------------------------------------------------------------- XXX UNTESTED. And I just changed it a bunch when moved--- from Bool to SeqNodeKind, but it's still probably far off...-----------------------------------------------------------------------------------  {-  LANGUAGE CPP #-}--#define USE_TRACE 1-----------------------------------------------------------------------------------#if USE_SOP-  {-# LANGUAGE DataKinds #-}-  {-# LANGUAGE TypeFamilies #-}-  {-# LANGUAGE ConstraintKinds #-}-  {-# LANGUAGE TemplateHaskell #-}-  {-# LANGUAGE GADTs #-}  -- for GHC 7.6.3-#else-  {-# LANGUAGE BangPatterns #-}-  {-# LANGUAGE TypeOperators #-}-  {-# LANGUAGE FlexibleContexts #-}-  {-  LANGUAGE MultiParamTypeClasses #-}-  {-  LANGUAGE Rank2Types #-}-#endif------------------------------------------------------------------------------------- |--- Module      :  Control.DeepSeq.Bounded.Generics.GSeqable--- Copyright   :  (c) 2014, Andrew G. Seniuk--- License     :  BSD-style (see the LICENSE file)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  GHC------ Generic function version of "Seqable" (via "Generics.SOP").------ Probably, a "GHC.Generics" variant would also be possible.------ This metaboilerplate is standard for using the generic deriving--- facilities of Generics.SOP.  Consider--- <http://hackage.haskell.org/package/seqaid seqaid>--- for a turnkey solution.------ > {-# LANGUAGE TemplateHaskell #-}--- > {-# LANGUAGE DataKinds #-}--- > {-# LANGUAGE TypeFamilies #-}--- > {-# LANGUAGE DeriveDataTypeable #-}--- > --- > import Generics.SOP.TH--- > import Control.DeepSeq.Bounded.Seqable--- > --- > data TA = A1 TB TA | A2--- > data TB = B1 Int | B2 TA--- > --- > deriveGeneric ''TA--- > deriveGeneric ''TB--- > --- > main = return $! force_ Propagate (A1 (force_ Propagate (B2 undefined)) A2)-----------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.Generics.GSeqable-#if USE_SOP-  (-      grnf_-    , gseq_-    , gforce_-#else-  (-      genericSeq_---  , genericSeq_V1-#endif-  ) where-----------------------------------------------------------------------------------  import Control.DeepSeq.Bounded.Pattern ( SeqNodeKind(..) )---import Control.DeepSeq.Bounded.Seqable ( SeqNodeKind(..) )--#if USE_SOP-  import Generics.SOP---import Generics.SOP.TH  -- not here, but rather in the module needing to generically derive an Seqable instance-#else-  import GHC.Generics-#endif--  import Control.Parallel ( par )--  import Debug.Trace ( trace )-----------------------------------------------------------------------------------#if USE_SOP--  gseq_ :: Generic a => SeqNodeKind -> a -> b -> b-  gseq_ Insulate     a b  =                 b-  gseq_ k            a b  = grnf_ k a `seq` b  -- sic! both Propagate and Spark--  gforce_ :: Generic a => SeqNodeKind -> a -> a-  gforce_ Insulate     a  =                 a-  gforce_ k            a  = grnf_ k a `seq` a  -- sic! both Propagate and Spark--  grnf_ :: Generic a => SeqNodeKind -> a -> ()-  grnf_ Insulate x = ()-  grnf_ k x = grnf_S k (from x)--  grnf_S :: SeqNodeKind -> SOP I xss -> ()-#if PARALLELISM_EXPERIMENT-  grnf_S Propagate       (SOP (Z xs))   = grnf_P xs `seq` ()-  grnf_S {-Spark-}_      (SOP (Z xs))   = grnf_P xs `par` ()-#else-  grnf_S {-Propagate-}_  (SOP (Z xs))   = grnf_P xs `seq` ()-#endif-  grnf_S k               (SOP (S xss))  = grnf_S k (SOP xss)--  grnf_P :: NP I xs -> ()-  grnf_P Nil = ()-  grnf_P (I x :* xs)  = x `seq` grnf_P xs-----------------------------------------------------------------------------------#else--#error "GSeqable: must use SOP for now..."--#endif----------------------------------------------------------------------------------
src/Control/DeepSeq/Bounded/NFDataN.hs view
@@ -20,7 +20,7 @@  -- | -- Module      :  Control.DeepSeq.Bounded.NFDataN--- Copyright   :  (c) 2014, Andrew G. Seniuk+-- Copyright   :  Andrew G. Seniuk 2014-2015 -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>@@ -33,7 +33,8 @@  ------------------------------------------------------------------------------- -  module Control.DeepSeq.Bounded.NFDataN (+  module Control.DeepSeq.Bounded.NFDataN+  (        -- * Depth-bounded analogues of 'deepseq' and 'force' @@ -42,14 +43,24 @@        -- * Class of things that can be evaluated to an arbitrary finite depth +#if JUST_ALIAS_GNFDATAN+    , rnfn+#else     , NFDataN(..)+#endif -  ) where+  )+  where  -------------------------------------------------------------------------------  --import qualified Data.Generics.Shape as S  -- not actually used +#if JUST_ALIAS_GNFDATAN+  import Generics.SOP ( Generic )+  import Control.DeepSeq.Bounded.Generic.GNFDataN ( grnfn )+#endif+ #if USE_NFDATA_SUPERCLASS   import Control.DeepSeq #endif@@ -66,6 +77,16 @@  ------------------------------------------------------------------------------- +#if JUST_ALIAS_GNFDATAN+  type NFDataN = Generic+#endif++#if JUST_ALIAS_GNFDATAN+  rnfn = grnfn+#endif++-------------------------------------------------------------------------------+ -- infixr 0 $!!  -------------------------------------------------------------------------------@@ -85,14 +106,14 @@   -- 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 coinductive+  -- 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 a less indiscriminate substitute for 'deepseq'.   ---  -- Furthermore, 'deepseqn' can sometimes a better solution than+  -- Furthermore, 'deepseqn' can sometimes be a better solution than   -- using stict fields in your data structures, because the   -- latter will behave strictly everywhere that its constructors   -- are used, instead of just where its laziness is problematic.@@ -100,6 +121,15 @@   -- There may be possible applications to the prevention of resource leaks   -- in lazy streaming, but I'm not certain.   --+  -- One of the special qualities of 'NFDataN' is shape oblivity:+  -- it doesn't care about any details of the shape of the term+  -- it's forcing, it only cares about stratifying levels of+  -- recursion depth.+  -- (I would say \"as contrasted with <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html NFDataP>\" but cannot, because+  -- <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html NFDataP>+  -- was extended to include+  -- <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataN.html NFDataN>+  -- syntax\/capabilities, precisely to ammend this deficiency.)    deepseqn :: NFDataN a => Int -> a -> b -> b   deepseqn n a b = rnfn n a `seq` b@@ -143,6 +173,8 @@  ------------------------------------------------------------------------------- +#if ! JUST_ALIAS_GNFDATAN+   -- | A class of types that can be evaluated to arbitrary depth. #if USE_NFDATA_SUPERCLASS   class NFData a => NFDataN a where@@ -361,6 +393,8 @@                     rnfn n' x7 `seq`                     rnfn n' x8 `seq`                     rnfn n' x9++#endif  -------------------------------------------------------------------------------
src/Control/DeepSeq/Bounded/NFDataP.hs view
@@ -3,1028 +3,250 @@    {-  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--- Copyright   :  (c) 2014, Andrew G. Seniuk--- 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 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).--------------------------------------------------------------------------------------  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--#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.PatAlg  -- actually exports former--     -- * Class of things that can be evaluated over an arbitrary finite pattern--     , NFDataP(..)--  )--  where-----------------------------------------------------------------------------------  import Control.DeepSeq.Bounded.Pattern-  import Control.DeepSeq.Bounded.PatAlg ( 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 = x `deepseqp pat` 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-----------------------------------------------------------------------------------  -- It seems that people will tell you this should not-  -- be a class method; helper functions of class methods-  -- should not be inside the class?...-  -- I've just read in-  -- https://www.fpcomplete.com/user/thoughtpolice/using-reflection-  -- that there's an optimisation (which may also affect type issues)-  -- when a class has a single method only; so I moved rnfp' out of-  -- the NFDataP class finally (it was recommended to do so before,-  -- but I never understood why; now I at least had some reason).-  -- (It has not affected my type errors in this case though; no-  -- surprise as DeepSeqBounded/T02/t.hs shows it happening with-  -- a single-method class.)-#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+-------------------------------------------------------------------------------++#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.++     , DeepSeqBounded_PingException(..)++     , handleAttrs  -- used by GNFDataP at least++     -- * 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(..)++#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  -------------------------------------------------------------------------------
src/Control/DeepSeq/Bounded/NFDataPDyn.hs view
@@ -6,6 +6,7 @@ #define DO_TRACE 0 #define WARN_IGNORED_SUBPATTERNS 1 #define NEVER_IGNORE_SUBPATTERNS 0+#define USE_GENERICQ 0  -- Now specified via --flag=[-]USE_WWW_DEEPSEQ --- #define USE_WW_DEEPSEQ 1@@ -13,10 +14,13 @@ -------------------------------------------------------------------------------  #if USE_SOP+  -- XXX and what happened to DataKinds??... (only when also TemplateHaskell?)   {-# LANGUAGE TypeFamilies #-}   {-# LANGUAGE ConstraintKinds #-}-  {-# LANGUAGE GADTs #-}  -- for GHC 7.6.3+#if __GLASGOW_HASKELL__ < 708+  {-# LANGUAGE GADTs #-} #endif+#endif    {-# LANGUAGE Rank2Types #-}   {-  LANGUAGE ScopedTypeVariables #-}@@ -28,7 +32,7 @@  -- | -- Module      :  Control.DeepSeq.Bounded.NFDataPDyn--- Copyright   :  (c) 2014, Andrew G. Seniuk+-- Copyright   :  Andrew G. Seniuk 2014-2015 -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>@@ -39,7 +43,6 @@ -------------------------------------------------------------------------------    module Control.DeepSeq.Bounded.NFDataPDyn-   (       -- * Dynamic pattern-directed forcing@@ -67,7 +70,6 @@      , module Control.DeepSeq.Bounded.NFDataP    )-   where  -------------------------------------------------------------------------------@@ -82,6 +84,9 @@ #endif    import Data.Data ( Data )+#if USE_GENERICQ+  import Data.Generics ( GenericQ )+#endif  #if 1   import Data.Typeable ( Typeable )@@ -112,13 +117,17 @@ -------------------------------------------------------------------------------    -- | SOP/SYB hybrid dynamic 'deepseqp'.-  deepseqpDyn :: (Show a, NFDataP a, Generic a, Data a+  deepseqpDyn :: forall a b. (Show a, NFDataP a, Generic a, Data a     , All2 Show (Code a)     , All2 NFData (Code a)     , All2 NFDataN (Code a)     , All2 NFDataP (Code a)     , All2 Data (Code a)+#if USE_GENERICQ+    ) => GenericQ PatNode -> a -> b -> b+#else     ) => (forall c. Data c => c -> PatNode) -> a -> b -> b+#endif   deepseqpDyn fg a b = rnfpDyn fg a `seq` b   -- XXX Partially-applied; is that okay in GHC RULES?   {-  RULES@@ -126,7 +135,7 @@       #-}    -- | SOP/Typeable hybrid dynamic 'deepseqp'.-  deepseqpDyn'' :: (Show a, NFDataP a, Generic a, Data a+  deepseqpDyn'' :: forall a b. (Show a, NFDataP a, Generic a, Data a     , All2 Show (Code a)     , All2 NFData (Code a)     , All2 NFDataN (Code a)@@ -140,7 +149,7 @@       #-}    -- | SOP-only dynamic 'deepseqp'.-  deepseqpDyn' :: (Show a, NFDataP a, Generic a, Data a+  deepseqpDyn' :: forall a b. (Show a, NFDataP a, Generic a, Data a     , All2 Generic (Code a)     , All2 Show (Code a)     , All2 NFData (Code a)@@ -152,20 +161,24 @@ -------------------------------------------------------------------------------    -- | SOP/SYB hybrid dynamic 'forcep'.-  forcepDyn :: (Show a, NFDataP a, Generic a, Data a+  forcepDyn :: forall a. (Show a, NFDataP a, Generic a, Data a     , All2 Show (Code a)     , All2 NFData (Code a)     , All2 NFDataN (Code a)     , All2 NFDataP (Code a)     , All2 Data (Code a)+#if USE_GENERICQ+    ) => GenericQ PatNode -> a -> a+#else     ) => (forall c. Data c => c -> PatNode) -> a -> a+#endif   forcepDyn fg x = deepseqpDyn fg x x   {-  RULES     "forcepDyn/composition"    forall fg1 fg2 x.  (.) (forcepDyn fg2) (forcepDyn fg1) x = forcepDyn (gcombQ fg1 fg2) x       #-}    -- | SOP/Typeable hybrid dynamic 'forcep'.-  forcepDyn'' :: (Show a, NFDataP a, Generic a, Data a+  forcepDyn'' :: forall a. (Show a, NFDataP a, Generic a, Data a     , All2 Show (Code a)     , All2 NFData (Code a)     , All2 NFDataN (Code a)@@ -178,7 +191,7 @@       #-}    -- | SOP-only dynamic 'forcep'.-  forcepDyn' :: (Show a, NFDataP a, Generic a, Data a+  forcepDyn' :: forall a. (Show a, NFDataP a, Generic a, Data a     , All2 Generic (Code a)     , All2 Show (Code a)     , All2 NFData (Code a)@@ -201,7 +214,7 @@ -- This should be straightforward. We have adequate precedent in GNFDataP.    -- | SOP-only dynamic 'rnfp'.-  -- Takes an SOP generic function yielding 'PatNode', which extends+  -- Takes a SOP generic function yielding 'PatNode', which extends   -- the pattern dynamically, depending on the type of the value node.   rnfpDyn' :: forall a. (                Generic a@@ -263,10 +276,10 @@   rnfpDynP' fg Nil         = ()   rnfpDynP' fg (I x :* xs)    | trace (show $ typeOf x) False = undefined-   | WI <- pn   = trace ("Boo A "        ) $ rnfpDynP' fg xs         `seq` ()-   | otherwise  = trace ("Boo B "++show x) $ rnfpDynP' fg xs `seq` x `seq` ()+   | WI{} <- pn  = trace ("Boo A "        ) $ rnfpDynP' fg xs         `seq` ()+   | otherwise   = trace ("Boo B "++show x) $ rnfpDynP' fg xs `seq` x `seq` ()    where---  pn = WR+--  pn = WR emptyPatNodeAttrs     pn = fg x {-:: PatNode-}     pat = Node pn [] {-:: Pattern-} @@ -292,6 +305,9 @@ #if 0                      a #else+#if USE_GENERICQ+                     GenericQ PatNode+#else                      ( forall c. ( #if 1                          Data c@@ -301,6 +317,7 @@ #endif                        ) => c -> PatNode                      )+#endif                   -> a #endif                   -> ()@@ -325,10 +342,14 @@ #if 0                       SOP I xss #else+#if USE_GENERICQ+                     GenericQ PatNode+#else                       ( forall c. (                           Data c                         ) => c -> PatNode                       )+#endif                    -> SOP I xss #endif                    -> ()@@ -349,10 +370,14 @@ #if 0                       NP I xs #else+#if USE_GENERICQ+                     GenericQ PatNode+#else                       ( forall c. (                           Data c                         ) => c -> PatNode                       )+#endif                    -> NP I xs #endif                    -> ()@@ -362,19 +387,19 @@    | trace (show $ typeOf x) False = undefined --- | trace (show $ typeOf x) $! False = undefined #if 0-   | WI <- pn   = trace ("AAA "++show x) $ ()-   | otherwise  = trace ("BBB "++show x) $ ()+   | WI{} <- pn  = trace ("AAA "++show x) $ ()+   | otherwise   = trace ("BBB "++show x) $ () #else-   | WI <- pn   = trace ("AAA "        ) $ rnfpDynP fg xs         `seq` ()---- | WI <- pn   = trace ("AAA "++show x) $ rnfpDynP fg xs         `seq` ()---- | WI <- pn   = trace ("AAA "++show x) $ ()+   | WI{} <- pn  = trace ("AAA "        ) $ rnfpDynP fg xs         `seq` ()+--- | WI{} <- pn  = trace ("AAA "++show x) $ rnfpDynP fg xs         `seq` ()+--- | WI{} <- pn  = trace ("AAA "++show x) $ () --- | otherwise  = trace ("BBB "++show x) $ rnfpDynP fg xs `seq` rnfp pat x `seq` () ---- | otherwise  = trace ("BBB "++show x) $ rnfpDynP fg xs `seq` rnfpDyn fg x `seq` ()    | otherwise  = trace ("BBB "++show x) $ rnfpDynP fg xs `seq` x `seq` () #endif    where #if 0-    pn = WR+    pn = WR emptyPatNodeAttrs #else     pn = trace (show $ fg x) $ fg x {-:: PatNode-} --  pn = fg x {-:: PatNode-}@@ -439,8 +464,8 @@   rnfpDyn''P fg Nil         = ()   rnfpDyn''P fg (I x :* xs)    | trace (show $ typeOf x) False = undefined-   | WI <- pn   = trace ("AAA "        ) $ rnfpDyn''P fg xs         `seq` ()-   | otherwise  = trace ("BBB "++show x) $ rnfpDyn''P fg xs `seq` x `seq` ()+   | WI{} <- pn  = trace ("AAA "        ) $ rnfpDyn''P fg xs         `seq` ()+   | otherwise   = trace ("BBB "++show x) $ rnfpDyn''P fg xs `seq` x `seq` ()    where     pn = trace (show $ fg x) $ fg x {-:: PatNode-} --  pn = fg x {-:: PatNode-}@@ -500,7 +525,8 @@ -- = rnfp pat x `seq` map (rnfpDyn fg) x `seq` ()    where #if 1-    pn = WR+    pn = WR emptyPatNodeAttrs+--  pn = WR #else     pn = fg d {-:: PatNode-} #endif@@ -514,90 +540,10 @@  #else ----------------------------------------------------------------------------------#if 0-  -- XXX This was written to try to get rid of type errors, b/c-  -- I have definitely seen SYB refuse to compile until things-  -- are USED. (No joy yet.)-  blah :: (Show a, NFData a, NFDataP a, Data a) => a -> ()-  blah x = rnfpDynG (mkQ WI f :: GenericQ PatNode) x-   where-    f :: (Int,Bool) -> PatNode-    f (n,b) | n < 3 || not b  = WI-            | otherwise       = WS-#endif-----------------------------------------------------------------------------------#if 0---- Well Fuck.--#if 0-  rnfpDynG :: (Show d,NFDataP d,NFData d,Data d) => d -> ()---rnfpDynG :: (Typeable d,Show d,NFDataP d,NFData d,Data d) => d -> ()---rnfpDynG :: (Typeable d,Show d,NFDataP d,NFData d) => d -> ()---rnfpDynG :: Data d => d -> ()-  rnfpDynG x = rnfpDynG' f x-   where-    f :: (Int,Bool) -> PatNode-    f (n,b) | n < 3 || not b  = WI-            | otherwise       = WS-    rnfpDynG' :: forall e. Data e => ((Int,Bool) -> PatNode) -> e -> ()---  rnfpDynG' :: ((Int,Bool) -> PatNode) -> d -> ()---  rnfpDynG' :: (Show d,NFDataP d,NFData d,Data d) => ((Int,Bool) -> PatNode) -> d -> ()-    rnfpDynG' f x-     = (gmapQ (rnfpDynG' f) x) `seq` ()-     where-      pn = fg x :: PatNode-      pat = Node pn [] {-:: Pattern-}-      fg = mkQ WI f---    fg = ( mkQ WI f :: d -> PatNode )---    fg = mkQ WI ( f :: (Int,Bool) -> PatNode )-#else-  -- Note that (rnfpDynG fg) is itself a GenericQ ().-  rnfpDynG :: forall d. (Show d,NFDataP d,NFData d,Data d) => (forall e. (Show e,NFDataP e,NFData e,Data e) => e -> PatNode) -> d -> ()---rnfpDynG :: forall d. (Show d,NFDataP d,NFData d,Data d) => (d -> PatNode) -> d -> ()---rnfpDynG :: forall d. (Typeable d,Show d,NFDataP d,NFData d,Data d) => (d -> PatNode) -> d -> ()---rnfpDynG :: forall d. (Typeable d,Show d,NFDataP d,NFData d,Data d) => (forall e. (NFDataP e,NFData e,Data e) => e -> PatNode) -> d -> ()---rnfpDynG :: (Typeable d,Show d,NFDataP d,NFData d,Data d) => (forall e. (NFDataP e,NFData e,Data e) => e -> PatNode) -> d -> ()---rnfpDynG :: (Typeable d,Show d,NFDataP d,NFData d,Data d) => GenericQ PatNode -> d -> ()---rnfpDynG :: forall d. (Show d, NFDataP d, Data d) => (forall d. Data d => d -> PatNode) -> d -> ()---rnfpDynG :: GenericQ PatNode -> GenericQ ()---rnfpDynG :: forall d a. (Show d, NFDataP d, Data d, Show a, NFDataP a, Data a) => GenericQ PatNode -> a -> ()---rnfpDynG :: forall d. (Show d, NFDataP d, NFData d, Data d) => (d -> PatNode) -> d -> ()---rnfpDynG :: forall d. (Show d, NFDataP d, NFData d, Data d) => GenericQ PatNode -> d -> ()---rnfpDynG :: forall d. (Show d, NFDataP d, Data d) => GenericQ PatNode -> d -> ()---rnfpDynG :: forall d. (Show d, NFDataP d, Data d) => GenericQ PatNode -> d -> ()-  rnfpDynG fg x-#if 0--- = (rnfp pat x) `seq` ()--- =                    (gmapQ ((rnfpDynG fg)::GenericQ ()) x) `seq` ()--- =                    (gmapQ ((rnfpDynG fg)::d->()) x) `seq` ()--- =                    (gmapQ ((rnfpDynG fg)::NFDataP d => d->()) x) `seq` ()--- =                    ((gmapQ (rnfpDynG fg) x)::[()]) `seq` ()-   =                    (gmapQ (rnfpDynG fg) x) `seq` ()--- = (rnfp pat x) `seq` (gmapQ (rnfpDynG fg) x) `seq` ()-#else-   | WI <- pn   = ()-   | otherwise  = (rnfp pat x) `seq` (gmapQ ((rnfpDynG (fg::forall b. (Show b,NFDataP b,NFData b,Data b) => b -> PatNode)) :: forall c. (Show c,NFDataP c,NFData c,Data c) => c -> ()) x) `seq` ()---- | otherwise  = (rnfp pat x) `seq` (gmapQ ((rnfpDynG fg) :: forall e. (Show e,NFDataP e,NFData e,Data e) => e -> ()) x) `seq` ()---- | otherwise  = (rnfp pat x) `seq` (gmapQ ((rnfpDynG fg) :: forall e. Data e => e -> ()) x) `seq` ()---- | otherwise  = (rnfp pat x) `seq` (gmapQ (rnfpDynG fg) x) `seq` ()---- | otherwise  = (rnfp pat x) `seq` ()  -- this is fine---- | otherwise  = rnfp pat x `seq` gmapQ (rnfpDynG fg) x `seq` ()---- | otherwise  = rnfp pat x `seq` gmapQ ((rnfpDynG fg) :: GenericQ ()) x `seq` ()---- | otherwise  = ( ( rnfp pat ) :: d -> () ) d `seq` gmapQ (rnfpDynG fg) d `seq` ()-#endif-   where-    pn = fg x {-:: PatNode-}-    pat = Node pn [] {-:: Pattern-}-#endif--#endif+-- XXX I guess, at the very least, you'll need+-- syb-with-class if you want to implement this... --------------------------------------------------------------------------------+#error Cannot use NFDataPDyn without flag USE_SOP being True (at least at this time).  #endif
+ src/Control/DeepSeq/Bounded/NFDataP_new_grammar.hs view
@@ -0,0 +1,1552 @@++-------------------------------------------------------------------------------++  {-  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+  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 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 "FUCK" (Node XX []))  = undefined  -- FUCK /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)++#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')...+  --       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+#if USE_TRACE_PATNODE+       p1 <- if doTrace as+             then trc p0 b msg_trc+             else return p0+#endif+#if USE_PING_PATNODE+       p2 <- if doPing as+             then png p1 b msg_png+             else return p1+#endif+#if USE_DIE_PATNODE+       p3 <- if doDie as+             then die p2 b msg_die+             else return p2+#endif+#if USE_TIMING_PATNODE+       p4 <- if doTiming as+             then timing p3 b msg_timing+             else return p3+#endif+       return $! Node p3 []+    | 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+#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++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/NFDataP_old_grammar.hs view
@@ -0,0 +1,926 @@++-------------------------------------------------------------------------------++  {-  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++-------------------------------------------------------------------------------+
− src/Control/DeepSeq/Bounded/PatAlg.hs 
@@ -1,740 +0,0 @@-----------------------------------------------------------------------------------  {-  LANGUAGE CPP #-}---- Temporarily for compatibility of seqaid demo output--- with documents already written.-#define PROVIDE_OLD_SHRINK_PAT 1---- 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 WS, WI, 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.PatAlg--- Copyright   :  (c) 2014, Andrew G. Seniuk--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  provisional--- Portability :  portable, except mkPat, mkPatN and growPat (which use SYB)--------------------------------------------------------------------------------------  module Control.DeepSeq.Bounded.PatAlg--  (--     -- * Basic operations on Patterns--       unionPats-     , intersectPats-     , isSubPatOf---   , unionPatsStr--#if ! HASKELL98_FRAGMENT-     -- * Operations for obtaining and modifying Patterns based on a term--     , mkPat-     , mkPatN-     , growPat-#endif--     -- * Operations for obtaining subpatterns (in the 'isSubPatOf' 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--  )--  where-----------------------------------------------------------------------------------  import Control.DeepSeq.Bounded.Pattern--  import Data.Maybe ( isNothing, fromJust )--#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 Debug.Trace ( trace )-  import Control.DeepSeq ( force )-----------------------------------------------------------------------------------#if DO_TRACE-  mytrace = trace-#else-  mytrace _ = id-#endif-----------------------------------------------------------------------------------  -- | Compute the union of a list of 'Pattern's.-  unionPats :: [ Pattern ] -> Pattern-  unionPats [] = Node WI []  -- or what?---unionPats [] = Nil  -- or what?-  unionPats ps = foldr1 (union' False) ps---unionPats ps = foldr1 union' $ trace (">> " ++ show ps) $ ps---unionPats = foldr union' Nil-  union' :: Bool -> Pattern -> Pattern -> Pattern-#if 1-  union' _ (Node WI _) (Node WI _) = Node WI []-  union' _ p          (Node WI _) = p-  union' _ (Node WI _) p          = p-#else-  union' _ Nil Nil = {-trace "NilNil" $-} Nil  -- case not needed (caught by either of the next two!)-#if 0-  -- XXX Later: It is going to work out better if take the-  -- very opposite convention. That is consistent with-  -- how composition behaves when # is involved.-  -- This says # trumps any other pattern node. This is the only-  -- sensible resolution it seems to me, but sadly it breaks every-  -- law I've penned for NFDataP...-  union' _ p   Nil = {-trace ("pNil "++show p) $-} Nil-  union' _ Nil p   = {-trace ("Nilp "++show p) $-} Nil-#else-  -- This makes for less interesting composites perhaps, where # is-  -- involved, but at least it is consistent with non-fused composition.-  union' _ p   Nil = p-  union' _ Nil p   = p-#endif-#endif-  -- Symmetric cases:-  union' b node1@(Node p1 cs1) node2@(Node p2 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 use), this problem-   -- will never arise.-#if 0-   -- XXX Don't do it -- (==) on PatNode might be more expensive-   -- than I think, some nodes have list parameters...-   | p1 == p2           = Node p1 $ zipWith (union' b) cs1 cs2-#endif-#if ENFORCE_SAME_ARITY_UNION-   | WR <- p1, WR <- p2 = {-trace "WRWR" $-}-      if csokay then Node WR $ zipWith (union' False) cs1 cs2-      else error "unionPat: WRWR: encountered arity disparity!"-#else-   | WR <- p1, WR <- p2 = {-trace "WRWR" $-} Node WR $ zipWith (union' False) cs1 cs2-#endif-   | WS <- p1, WS <- p2 = {-trace "WSWS" $-} Node WS []-#if USE_WW_DEEPSEQ-   | WW <- p1, WW <- p2 = {-trace "WWWW" $-} Node WW []-#endif-#if ENFORCE_SAME_ARITY_UNION-   | TR tys1 <- p1, TR tys2 <- p2 = {-trace "TRTR" $-}-      if csokay then Node (TR (unionTys tys1 tys2)) $ zipWith (union' False) cs1 cs2-      else error "unionPat: TRTR: encountered arity disparity!"-   | TI tys1 <- p1, TI tys2 <- p2 = {-trace "TITI" $-}-      if csokay then Node (TI (intersectTys tys1 tys2)) $ zipWith (union' False) cs1 cs2-      else error "unionPat: TITI: encountered arity disparity!"-#else-   | TR tys1 <- p1, TR tys2 <- p2-      = {-trace "TRTR" $-} Node (TR (unionTys tys1 tys2)) $ zipWith (union' False) cs1 cs2-   | TI tys1 <- p1, TI tys2 <- p2-      = {-trace "TITI" $-} Node (TI (intersectTys tys1 tys2)) $ zipWith (union' False) cs1 cs2---- | TR cls1 tys1 cns1 <- p1, TR cls2 tys2 cns2 <- p2---    = {-trace "TRWR" $-} Node (TR (cls1++cls2) (tys1++tys2) (cns1++cns2)) $ zipWith union' cs1 cs2-#endif---- | ...-   where  -- (yes where's can be empty)-#if ENFORCE_SAME_ARITY_UNION-    csokay = length cs1 == length cs2  -- ouch-#endif-  -- Now the asymmetric cases:-  union' b node1@(Node p1 cs1) node2@(Node p2 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!-   --   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 use...-   | WR <- p1, WS <- p2 = {-trace "WRWS" $-} Node WR cs1-#if USE_WW_DEEPSEQ-   | WR <- p1, WW <- p2 = {-trace "WRWW" $-} Node WW []-#endif-#if USE_WW_DEEPSEQ-   | WS <- p1, WW <- p2 = {-trace "WSWW" $-} Node WW []-#endif-#if ENFORCE_SAME_ARITY_UNION-   | TR _ <- p1, WR <- p2 = {-trace "TRWR" $-}-      if csokay then node1-      else error $ "unionPat: " ++ if b then "WRTR" else "TRWR" ++ ": encountered arity disparity!"-#else-   | TR _ <- p1, WR <- p2 = {-trace "TRWR" $-} node1-#endif-   | TR _ <- p1, WS <- p2 = {-trace "TRWS" $-} node1-#if USE_WW_DEEPSEQ-   | TR _ <- p1, WW <- p2 = {-trace "TRWW" $-} node2-#endif-#if ENFORCE_SAME_ARITY_UNION-   | TI _ <- p1, WR <- p2 = {-trace "TIWR" $-}-      if csokay then node2-      else error $ "unionPat: " ++ if b then "WRTI" else "TIWR" ++ ": encountered arity disparity!"-#else-   | TI _ <- p1, WR <- p2 = {-trace "TIWR" $-} node2-#endif-   | TI _ <- p1, WS <- p2 = {-trace "TIWS" $-} node2-#if USE_WW_DEEPSEQ-   | TI _ <- p1, WW <- p2 = {-trace "TIWW" $-} node2-#endif-#if 0-   | TS _ <- p1, WR <- p2 = {-trace "TSWR" $-} node2-   | TS _ <- p1, WS <- p2 = {-trace "TSWS" $-} node2-   | TS _ <- p1, WW <- p2 = {-trace "TSWW" $-} node2-#endif-#if USE_WW_DEEPSEQ-   | TW _ <- p1, WR <- p2 = {-trace "TWWR" $-} node1-   | TW _ <- p1, WS <- p2 = {-trace "TWWS" $-} node1-   | TW _ <- p1, WW <- p2 = {-trace "TWWW" $-} node2-#endif-#if ENFORCE_SAME_ARITY_UNION-   | TI tys1 <- p1, TR tys2 <- p2 = {-trace "TITR" $-}-      if csokay then Node (TR (tys1++tys2)) $ zipWith (union' False) cs1 cs2-      else error $ "unionPat: " ++ if b then "TRTI" else "TITR" ++ ": encountered arity disparity!"-#else-   | TI tys1 <- p1, TR tys2 <- p2-      = {-trace "TITR" $-} Node (TR (tys1++tys2)) $ zipWith (union' False) cs1 cs2-#endif---- | ...-   | not b = union' True node2 node1-   | otherwise = error "unionPats: unexpected failure to (Haskell) pattern-match arguments!"-   where  -- (yes where's can be empty)-#if ENFORCE_SAME_ARITY_UNION-    csokay = length cs1 == length cs2  -- ouch-#endif--#if 0-  -- | This (unionPatsStr) seems pretty silly?... (It is used in the tests though.)-  unionPatsStr :: [ String ] -> String-  unionPatsStr = showPat . unionPats . map compilePat-#endif-----------------------------------------------------------------------------------  -- 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)-----------------------------------------------------------------------------------  -- | Return 'True' if the first pattern matches the second (and 'False' otherwise).-  ---  -- Note that matching does not imply spanning. Equality ('==') or @'flip' 'isSubPatOf'@ will work there, depending on your intentions.-  ---  -- XXX This doesn't yet handle type-constrained 'PatNode's-  -- ('TI', 'TR', 'TN' or 'TW'), because 'intersectPats' doesn't.-  isSubPatOf :: Pattern -> Pattern -> Bool-  isSubPatOf p pp = p == intersectPats [p, pp]  -- probably faster on avg.---isSubPatOf p pp = pp == unionPats [p, pp]-----------------------------------------------------------------------------------  -- | Compute the intersection of a list of 'Pattern's.-  ---  -- XXX This doesn't yet handle type-constrained 'PatNode's-  -- ('TI', 'TR', 'TN' or 'TW').-  intersectPats :: [ Pattern ] -> Pattern-  intersectPats [] = Node WI []  -- or what?-  intersectPats ps = foldr1 (intersection' False) ps-  intersection' :: Bool -> Pattern -> Pattern -> Pattern-  intersection' _ _           (Node WI _) = Node WI []-  intersection' _ (Node WI _) _           = Node WI []--- Note that chs1 == [] == chs2 (or at least is supposed to be),--- except for WR, PR and TR PatNode's.-  -- First check once for symmetric cases:-  intersection' b node1@(Node p1 cs1) node2@(Node p2 cs2)-#if 0-   -- XXX Don't do it -- (==) on PatNode might be more expensive-   -- than I think, some nodes have list parameters...-   -- (Could put this at top, allowing WN etc. to be accepted in many cases.)-   | p1 == p2      = Node p1 $ zipWith_ "intersection" (intersection' b) cs1 cs2-#endif-   | WS <- p1, WS <- p2  = node1-   | WR <- p1, WR <- p2  = let (b,zs) = zipWith_ "intersection" (intersection' b) cs1 cs2 in if b then Node WR zs else Node WS zs-   | WN n1 <- p1, WN n2 <- p2  = Node (WN (min n1 n2)) []-#if USE_WW_DEEPSEQ-#if PARALLELISM_EXPERIMENT-   | PW <- p1, PW <- p2  = node1-#endif-   | WW <- p1, WW <- p2  = node1-#endif-#if PARALLELISM_EXPERIMENT-   | PR <- p1, PR <- p2   = let (b,zs) = zipWith_ "intersection" (intersection' b) cs1 cs2 in if b then Node PR zs else Node WS zs-   | PN n1 <- p1, PN n2 <- p2  = Node (PN (min n1 n2)) []-#endif-  -- Now the asymmetric cases:-  intersection' b node1@(Node p1 cs1) node2@(Node p2 cs2)-   | WR <- p1, WS <- p2  = node2-#if USE_WW_DEEPSEQ-#if PARALLELISM_EXPERIMENT-   | PW <- p1  = node2-#endif-   | WW <- p1  = node2-#endif-   | WR <- p1, WN n2 <- p2  = truncatePat n2 node1-#if PARALLELISM_EXPERIMENT-   | PR <- p1, PN n2 <- p2  = truncatePat n2 node1-#endif-   | TI   _ <- p1  = error "intersectPats: can't handle TI PatNode's yet"-   | TR   _ <- p1  = error "intersectPats: can't handle TR PatNode's yet"-   | TN _ _ <- p1  = error "intersectPats: can't handle TN PatNode's yet"-#if USE_WW_DEEPSEQ-   | TW   _ <- p1  = error "intersectPats: can't handle TW PatNode's yet"-#endif-   | not b               = intersection' True node2 node1-   | otherwise = Node WI []---- | otherwise = error "intersectPats: unexpected failure to (Haskell) pattern-match arguments!"-----------------------------------------------------------------------------------  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 []-  zipWith_' :: (a -> b -> c) -> [a] -> [b] -> [c] -> (Bool,[c])-  zipWith_' _ [] [] acc = (True,acc)-  zipWith_' f (x:xs) (y:ys) acc = zipWith_' f xs ys (f x y : acc)-  zipWith_' _ _ _ acc = (False,acc)-----------------------------------------------------------------------------------  -- | Given an integer depth and a pattern, truncate the pattern to-  -- extend to at most this requested depth.-  truncatePat :: Int -> Pattern -> Pattern-  truncatePat n node-   | n <= 0              = Node WS []-   | Node p chs <- node  = Node p $ 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 assure the empty pattern-  -- never forces anything.-  emptyPat :: Pattern-  emptyPat = Node WI []  -- should do it!-----------------------------------------------------------------------------------#if ! HASKELL98_FRAGMENT-  -- | Obtain a lazy pattern, matching the shape of-  -- an arbitrary term (value expression).-  -- Interior nodes will be 'WR', and leaves will be 'WS'.-  ---  -- Note this gives counter-intuitive results when used on @'Rose' a@.-  -- 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 p cs) = Node (if null cs then WS else WR) $ map f cs---mkPat x = fmap (\ (Node p cs) -> if null cs then WS else WR) $ shapeOf x---mkPat x = (\ (Node p cs) -> if null cs then WS else WR) <$> shapeOf x---mkPat x = WR <$ shapeOf x--  -- | Obtain a lazy pattern, matching the shape of-  -- an arbitrary term, but only down to at most depth @n@.-  -- Interior nodes will be 'WR'.-  -- Leaf nodes will be 'WS' if they were leaves in the host value;-  -- otherwise (i.e. if they are at depth @n@) they will be 'WR'.-  ---  -- Satisfies @'forcep' . 'mkPatN' n = 'forcen' n@.-  ---  -- See caveat in the comment to 'mkPat'.-  mkPatN :: forall d. Data d => Int -> d -> Pattern-  mkPatN n = f n . shapeOf-   where-    f 0 (Node p cs) = Node (if null cs then WS else WR) []-    f n (Node p cs) = Node (if null cs then WS else WR) $ map (f (-1+n)) cs-#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.)-  shrinkPat :: Pattern -> Pattern-  shrinkPat (Node p cs)-   | WI <- p  = Node WI []  -- can't shrink (eventually elided from parent)-   | WS <- p  = Node WI []  -- may as well-   | WN n <- p  = if n <= 1 then Node WI []-                  else if n == 2 then Node WS []-                  else Node (WN (-1+n)) []-#if USE_WW_DEEPSEQ-   | WW <- p  = Node (WN 5) []  -- XXX arbitrary hardcode-#endif-#if PARALLELISM_EXPERIMENT-   -- take de-parallelisation as shrinkage-   | PR <- p  = Node WR cs-   | PN n <- p  = Node (WN n) []-#if USE_WW_DEEPSEQ-   | PW <- p  = Node WW []-#endif-#endif-   -- take un-type-constrained as shrinkage-   | TI _ <- p  = Node WI []-   | TR _ <- p  = Node WR cs-   | TN n _ <- p  = Node (WN n) []-#if USE_WW_DEEPSEQ-   | TW _ <- p  = Node WW []-#endif-   -- If this node has any grandchildren, recurse on the children.-   | not $ null $ filter (\ (Node q gcs) -> not $ null gcs) cs-      = Node p $ map shrinkPat cs-   -- At this point we know this node has no grandchildren.-   -- Check if all children are insulator nodes.-   | null $ filter (\ (Node p _) -> case p of-                                     WI -> False-                                     _ -> True) cs-      = case p of-         -- Must go to WI, since .{##} -> . is /not/ a lazification.-         WR -> Node WI []-#if PARALLELISM_EXPERIMENT-         PR -> Node WI []  -- sic-#endif-         TR _ -> Node WI []  -- sic-         _ -> error "shrinkPat: unexpected!"-   | otherwise-      = Node p $ map shrinkPat cs  -- still contains shrinkable children-----------------------------------------------------------------------------------#if PROVIDE_OLD_SHRINK_PAT-  -- | Old version, for temporary compatibility of seqaid demo mode.-  {-  DEPRECATED shrinkPat_old "For temporary compatibility of seqaid demo mode." #-}-  -- (Deprecation warning too noisy for me. Nobody will use this by accident.)-  shrinkPat_old :: Pattern -> Pattern-  shrinkPat_old (Node p cs)-   | not $ null $ filter (\ (Node q gcs) -> not $ null gcs) cs  = Node p $ map shrinkPat_old cs-   | WR <- p  = Node WS []-   | otherwise  = Node p []-#endif-----------------------------------------------------------------------------------#if ! HASKELL98_FRAGMENT-  -- | Grow all leaves by one level within the shape of the provided value.-  growPat :: forall d. Data d => Pattern -> d -> Pattern-  growPat pat x = growPat' pat $ shapeOf x-  growPat' :: Pattern -> Shape -> Pattern-  growPat' (Node p []) (Node q ds) = Node p $ map (const (Node WS [])) ds-  growPat' (Node p cs) (Node q ds) = Node p $ zipWith growPat' cs ds-#endif-----------------------------------------------------------------------------------  -- | This creates a new 'WR' node, the common root. The argument patterns-  -- become the children of the root (order is preserved).-  liftPats :: [ Pattern ] -> Pattern-  liftPats ps = Node WR ps-----------------------------------------------------------------------------------  -- | Introduce siblings at a node (interior or leaf) of the target.-  -- The first argument is target, the second is a path, and the-  -- third is a list of subpatterns for insertion, along with the-  -- indices of the child before which to insert. If this index-  -- is negative, it counts from the right. Indices are always-  -- relative to the original target as it was received.-{--}--- XXX Later: I don't understand. When would you use this?--- You change the number of children at a node, which seems--- unuseful. More reasonable than insertion would be to replace--- select children with a new subpatterns.-  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' (Node p cs) [] isibs  -- end of path chain-     | maximum (map fst isibs) > ncs  = error "splicePats: sibling indices must not exceed the number of existing children"-     | otherwise  = {-trace "**1**" $-} Node p $ f 0 cs isibs_-     where-      ncs = length cs-      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 = if i < 0 then ncs-(-i) else i-    splice' (Node p 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)"-     | otherwise  = {-trace "**2**" $-} Node p (csL ++ [splice' c is isibs] ++ csR)-     where-      (c:csR) = ccsR-      (csL,ccsR) = splitAt i cs-----------------------------------------------------------------------------------  -- | Elide siblings at a node (interior or leaf) of the target.-  -- The first argument is target, the second is a path, and the-  -- third is a list of child indices for elision.-  -- If this index is negative, it counts from the right.-  -- Indices are always relative to the original target as it was received.-{--}--- XXX Later: I don't understand. When would you want to--- change the number of children at a node (except possibly--- to zero)?...--- XXX This is templated from splicePats, and it seems more useful--- for it to just take a single path, or a list of paths; it doesn't--- really make sense to support multiple sibling elision in single pass.--- XXX Yes, change that! Let it take a list of paths instead.-  elidePats :: Pattern -> [Int] -> [Int] -> Pattern-  elidePats target path isibs'-   | otherwise          = elide' target path isibs-   where-    isibs = sortBy comp isibs'  -- questionable solution-     where-      comp x1 x2 = compare x1 x2-    -- (See comment in elidePats.)-    elide' (Node p cs) [] isibs  -- end of path chain-     | maximum isibs > ncs  = error "elidePats: sibling indices must not exceed the number of existing children"-     | otherwise  = {-trace "**1**" $-} Node p $ f 0 cs isibs_-     where-      ncs = length cs-      isibs_ = let lst = takeWhile (== -1) isibs in-               drop (length lst) isibs ++ map (\ x -> ncs) lst-      f n cs [] = cs-      f n [] isibs_remaining = error $ "elidePats: (2) 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 = if i < 0 then ncs-(-i) else i-    elide' (Node p 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 p (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)?...--- XXX It would be better if the weighting could be done once,--- then maintained, but will have to see how it performs...--- XXX It is lamentable that the change history of this function--- along with the GHC error messages (notably the topmost of them)--- is lost, since stuff like this would make exellent input--- to compiler AI (for improving prioritisation of error--- messages for example; the "lexical tradition" is also--- at work here!...).--- XXX Hey! This doesn't even need to call elidePats.-  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 pn chs)-   = ( Node pn $ left ++ [ ch'' ] ++ right , g' )-   where-    ch'' = ch'---  ch'' = (\ (Node (r,p) 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 pn chs) = probDensRose pat-    wpat@(Node pn chs) = probDensRose pat-    f :: StdGen -> Rose (PatNode,Double) -> (Rose (PatNode,Double), StdGen)-    f g (Node pn chs)-     | isNothing mh  = ( Node pn chs, g )  -- ??-     | null chs   = ( Node pn [], g )----  | null chs   = ( Node pn [], g'' )-     | null gchs  = ( Node pn $ left ++ [ Node (WI,1.0) [] ] ++ right , g'' )----  | null gchs  = ( Node pn $ left ++ right , g'' )-     | otherwise  = ( Node pn $ 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 (_,p) _) -> p) 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 "| "----------------------------------------------------------------------------------
+ src/Control/DeepSeq/Bounded/PatUtil.hs view
@@ -0,0 +1,137 @@++-------------------------------------------------------------------------------++  {-  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++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/PatUtil_new_grammar.hs view
@@ -0,0 +1,1199 @@++-------------------------------------------------------------------------------++  {-  LANGUAGE CPP #-}++-- 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_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, except mkPat, mkPatN and growPat (which use SYB)+--++-------------------------------------------------------------------------------++  module Control.DeepSeq.Bounded.PatUtil_new_grammar+  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+  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)+   | 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 PROVIDE_OLD_SHRINK_PAT+  -- | Old version, for temporary compatibility of seqaid demo mode.+  {-  DEPRECATED shrinkPat_old "For temporary compatibility of seqaid demo mode." #-}+  -- (Deprecation warning too noisy for me. Nobody will use this by accident.)+  shrinkPat_old :: Pattern -> Pattern+  shrinkPat_old (Node pas cs)+   | not $ null $ filter (\ (Node q gcs) -> not $ null gcs) cs  = Node pas $ map shrinkPat_old cs+   | WR{} <- pas  = Node (WS as) []+   | otherwise    = Node pas []+   where+    as = getPatNodeAttrs pas+#endif++-------------------------------------------------------------------------------++#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 "| "++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/PatUtil_old_grammar.hs view
@@ -0,0 +1,717 @@++-------------------------------------------------------------------------------++  {-  LANGUAGE CPP #-}++#define SHRINK_TO_EMPTY_WR 1++-- Temporarily for compatibility of seqaid demo output+-- with documents already written.+#define PROVIDE_OLD_SHRINK_PAT 1++-- 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 WS, WI, 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_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, except mkPat, mkPatN and growPat (which use SYB)+--++-------------------------------------------------------------------------------++  module Control.DeepSeq.Bounded.PatUtil_old_grammar+  where++-------------------------------------------------------------------------------++  import Control.DeepSeq.Bounded.Pattern++  import Data.Maybe ( isNothing, fromJust )++#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 Debug.Trace ( trace )+  import Control.DeepSeq ( force )++-------------------------------------------------------------------------------++#if DO_TRACE+  mytrace = trace+#else+  mytrace _ = id+#endif++-------------------------------------------------------------------------------++  -- | Compute the union of a list of 'Pattern's.+  unionPats :: [ Pattern ] -> Pattern+  unionPats [] = Node WI []  -- or what?+--unionPats [] = Nil  -- or what?+  unionPats ps = foldr1 (union' False) ps+--unionPats ps = foldr1 union' $ trace (">> " ++ show ps) $ ps+--unionPats = foldr union' Nil+  union' :: Bool -> Pattern -> Pattern -> Pattern+#if 1+  union' _ (Node WI _) (Node WI _) = Node WI []+  union' _ p          (Node WI _) = p+  union' _ (Node WI _) p          = p+#else+  union' _ Nil Nil = {-trace "NilNil" $-} Nil  -- case not needed (caught by either of the next two!)+#if 0+  -- XXX Later: It is going to work out better if take the+  -- very opposite convention. That is consistent with+  -- how composition behaves when # is involved.+  -- This says # trumps any other pattern node. This is the only+  -- sensible resolution it seems to me, but sadly it breaks every+  -- law I've penned for NFDataP...+  union' _ p   Nil = {-trace ("pNil "++show p) $-} Nil+  union' _ Nil p   = {-trace ("Nilp "++show p) $-} Nil+#else+  -- This makes for less interesting composites perhaps, where # is+  -- involved, but at least it is consistent with non-fused composition.+  union' _ p   Nil = p+  union' _ Nil p   = p+#endif+#endif+  -- Symmetric cases:+  union' b node1@(Node p1 cs1) node2@(Node p2 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 use), this problem+   -- will never arise.+#if 0+   -- XXX Don't do it -- (==) on PatNode might be more expensive+   -- than I think, some nodes have list parameters...+   | p1 == p2           = Node p1 $ zipWith (union' b) cs1 cs2+#endif+#if ENFORCE_SAME_ARITY_UNION+   | WR <- p1, WR <- p2 = {-trace "WRWR" $-}+      if csokay then Node WR $ zipWith (union' False) cs1 cs2+      else error "unionPat: WRWR: encountered arity disparity!"+#else+   | WR <- p1, WR <- p2 = {-trace "WRWR" $-} Node WR $ zipWith (union' False) cs1 cs2+#endif+   | WS <- p1, WS <- p2 = {-trace "WSWS" $-} Node WS []+#if USE_WW_DEEPSEQ+   | WW <- p1, WW <- p2 = {-trace "WWWW" $-} Node WW []+#endif+#if ENFORCE_SAME_ARITY_UNION+   | TR tys1 <- p1, TR tys2 <- p2 = {-trace "TRTR" $-}+      if csokay then Node (TR (unionTys tys1 tys2)) $ zipWith (union' False) cs1 cs2+      else error "unionPat: TRTR: encountered arity disparity!"+   | TI tys1 <- p1, TI tys2 <- p2 = {-trace "TITI" $-}+      if csokay then Node (TI (intersectTys tys1 tys2)) $ zipWith (union' False) cs1 cs2+      else error "unionPat: TITI: encountered arity disparity!"+#else+   | TR tys1 <- p1, TR tys2 <- p2+      = {-trace "TRTR" $-} Node (TR (unionTys tys1 tys2)) $ zipWith (union' False) cs1 cs2+   | TI tys1 <- p1, TI tys2 <- p2+      = {-trace "TITI" $-} Node (TI (intersectTys tys1 tys2)) $ zipWith (union' False) cs1 cs2+--- | TR cls1 tys1 cns1 <- p1, TR cls2 tys2 cns2 <- p2+--    = {-trace "TRWR" $-} Node (TR (cls1++cls2) (tys1++tys2) (cns1++cns2)) $ zipWith union' cs1 cs2+#endif+--- | ...+   where  -- (yes where's can be empty)+#if ENFORCE_SAME_ARITY_UNION+    csokay = length cs1 == length cs2  -- ouch+#endif+  -- Now the asymmetric cases:+  union' b node1@(Node p1 cs1) node2@(Node p2 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!+   --   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 use...+   | WR <- p1, WS <- p2 = {-trace "WRWS" $-} Node WR cs1+#if USE_WW_DEEPSEQ+   | WR <- p1, WW <- p2 = {-trace "WRWW" $-} Node WW []+#endif+#if USE_WW_DEEPSEQ+   | WS <- p1, WW <- p2 = {-trace "WSWW" $-} Node WW []+#endif+#if ENFORCE_SAME_ARITY_UNION+   | TR _ <- p1, WR <- p2 = {-trace "TRWR" $-}+      if csokay then node1+      else error $ "unionPat: " ++ if b then "WRTR" else "TRWR" ++ ": encountered arity disparity!"+#else+   | TR _ <- p1, WR <- p2 = {-trace "TRWR" $-} node1+#endif+   | TR _ <- p1, WS <- p2 = {-trace "TRWS" $-} node1+#if USE_WW_DEEPSEQ+   | TR _ <- p1, WW <- p2 = {-trace "TRWW" $-} node2+#endif+#if ENFORCE_SAME_ARITY_UNION+   | TI _ <- p1, WR <- p2 = {-trace "TIWR" $-}+      if csokay then node2+      else error $ "unionPat: " ++ if b then "WRTI" else "TIWR" ++ ": encountered arity disparity!"+#else+   | TI _ <- p1, WR <- p2 = {-trace "TIWR" $-} node2+#endif+   | TI _ <- p1, WS <- p2 = {-trace "TIWS" $-} node2+#if USE_WW_DEEPSEQ+   | TI _ <- p1, WW <- p2 = {-trace "TIWW" $-} node2+#endif+#if 0+   | TS _ <- p1, WR <- p2 = {-trace "TSWR" $-} node2+   | TS _ <- p1, WS <- p2 = {-trace "TSWS" $-} node2+   | TS _ <- p1, WW <- p2 = {-trace "TSWW" $-} node2+#endif+#if USE_WW_DEEPSEQ+   | TW _ <- p1, WR <- p2 = {-trace "TWWR" $-} node1+   | TW _ <- p1, WS <- p2 = {-trace "TWWS" $-} node1+   | TW _ <- p1, WW <- p2 = {-trace "TWWW" $-} node2+#endif+#if ENFORCE_SAME_ARITY_UNION+   | TI tys1 <- p1, TR tys2 <- p2 = {-trace "TITR" $-}+      if csokay then Node (TR (tys1++tys2)) $ zipWith (union' False) cs1 cs2+      else error $ "unionPat: " ++ if b then "TRTI" else "TITR" ++ ": encountered arity disparity!"+#else+   | TI tys1 <- p1, TR tys2 <- p2+      = {-trace "TITR" $-} Node (TR (tys1++tys2)) $ zipWith (union' False) cs1 cs2+#endif+--- | ...+   | not b = union' True node2 node1+   | otherwise = error "unionPats: unexpected failure to (Haskell) pattern-match arguments!"+   where  -- (yes where's can be empty)+#if ENFORCE_SAME_ARITY_UNION+    csokay = length cs1 == length cs2  -- ouch+#endif++#if 0+  -- | This (unionPatsStr) seems pretty silly?... (It is used in the tests though.)+  unionPatsStr :: [ String ] -> String+  unionPatsStr = showPat . unionPats . map compilePat+#endif++-------------------------------------------------------------------------------++  -- 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)++-------------------------------------------------------------------------------++  -- | Return 'True' if the first pattern matches the second (and 'False' otherwise).+  --+  -- Note that matching does not imply spanning. Equality ('==') or @'flip' 'isSubPatOf'@ will work there, depending on your intentions.+  --+  -- XXX This doesn't yet handle type-constrained 'PatNode's+  -- ('TI', 'TR', 'TN' or 'TW'), because 'intersectPats' doesn't.+  isSubPatOf :: Pattern -> Pattern -> Bool+  isSubPatOf p pp = p == intersectPats [p, pp]  -- probably faster on avg.+--isSubPatOf p pp = pp == unionPats [p, pp]++-------------------------------------------------------------------------------++  -- | Compute the intersection of a list of 'Pattern's.+  --+  -- XXX This doesn't yet handle type-constrained 'PatNode's+  -- ('TI', 'TR', 'TN' or 'TW').+  intersectPats :: [ Pattern ] -> Pattern+  intersectPats [] = Node WI []  -- or what?+  intersectPats ps = foldr1 (intersection' False) ps+  intersection' :: Bool -> Pattern -> Pattern -> Pattern+  intersection' _ _           (Node WI _) = Node WI []+  intersection' _ (Node WI _) _           = Node WI []+-- Note that chs1 == [] == chs2 (or at least is supposed to be),+-- except for WR, PR and TR PatNode's.+  -- First check once for symmetric cases:+  intersection' b node1@(Node p1 cs1) node2@(Node p2 cs2)+#if 0+   -- XXX Don't do it -- (==) on PatNode might be more expensive+   -- than I think, some nodes have list parameters...+   -- (Could put this at top, allowing WN etc. to be accepted in many cases.)+   | p1 == p2      = Node p1 $ zipWith_ "intersection" (intersection' b) cs1 cs2+#endif+   | WS <- p1, WS <- p2  = node1+   | WR <- p1, WR <- p2  = let (b,zs) = zipWith_ "intersection" (intersection' b) cs1 cs2 in if b then Node WR zs else Node WS zs+   | WN n1 <- p1, WN n2 <- p2  = Node (WN (min n1 n2)) []+#if USE_WW_DEEPSEQ+#if PARALLELISM_EXPERIMENT+   | PW <- p1, PW <- p2  = node1+#endif+   | WW <- p1, WW <- p2  = node1+#endif+#if PARALLELISM_EXPERIMENT+   | PR <- p1, PR <- p2   = let (b,zs) = zipWith_ "intersection" (intersection' b) cs1 cs2 in if b then Node PR zs else Node WS zs+   | PN n1 <- p1, PN n2 <- p2  = Node (PN (min n1 n2)) []+#endif+  -- Now the asymmetric cases:+  intersection' b node1@(Node p1 cs1) node2@(Node p2 cs2)+   | WR <- p1, WS <- p2  = node2+#if USE_WW_DEEPSEQ+#if PARALLELISM_EXPERIMENT+   | PW <- p1  = node2+#endif+   | WW <- p1  = node2+#endif+   | WR <- p1, WN n2 <- p2  = truncatePat n2 node1+#if PARALLELISM_EXPERIMENT+   | PR <- p1, PN n2 <- p2  = truncatePat n2 node1+#endif+   | TI   _ <- p1  = error "intersectPats: can't handle TI PatNode's yet"+   | TR   _ <- p1  = error "intersectPats: can't handle TR PatNode's yet"+   | TN _ _ <- p1  = error "intersectPats: can't handle TN PatNode's yet"+#if USE_WW_DEEPSEQ+   | TW   _ <- p1  = error "intersectPats: can't handle TW PatNode's yet"+#endif+   | not b               = intersection' True node2 node1+   | otherwise = Node WI []+--- | otherwise = error "intersectPats: unexpected failure to (Haskell) pattern-match arguments!"++-------------------------------------------------------------------------------++  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 []+  zipWith_' :: (a -> b -> c) -> [a] -> [b] -> [c] -> (Bool,[c])+  zipWith_' _ [] [] acc = (True,acc)+  zipWith_' f (x:xs) (y:ys) acc = zipWith_' f xs ys (f x y : acc)+  zipWith_' _ _ _ acc = (False,acc)++-------------------------------------------------------------------------------++  -- | Given an integer depth and a pattern, truncate the pattern to+  -- extend to at most this requested depth.+  truncatePat :: Int -> Pattern -> Pattern+  truncatePat n node+   | n <= 0              = Node WS []+   | Node p chs <- node  = Node p $ 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 assure the empty pattern+  -- never forces anything.+  emptyPat :: Pattern+  emptyPat = Node WI []  -- should do it!++-------------------------------------------------------------------------------++#if ! HASKELL98_FRAGMENT+  -- | Obtain a lazy pattern, matching the shape of+  -- an arbitrary term (value expression).+  -- Interior nodes will be 'WR', and leaves will be 'WS'.+  --+  -- Note this gives counter-intuitive results when used on @'Rose' a@.+  -- 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 p cs) = Node (if null cs then WS else WR) $ map f cs+--mkPat x = fmap (\ (Node p cs) -> if null cs then WS else WR) $ shapeOf x+--mkPat x = (\ (Node p cs) -> if null cs then WS else WR) <$> shapeOf x+--mkPat x = WR <$ shapeOf x++  -- | Obtain a lazy pattern, matching the shape of+  -- an arbitrary term, but only down to at most depth @n@.+  -- Interior nodes will be 'WR'.+  -- Leaf nodes will be 'WS' if they were leaves in the host value;+  -- otherwise (i.e. if they are at depth @n@) they will be 'WR'.+  --+  -- Satisfies @'forcep' . 'mkPatN' n = 'forcen' n@.+  --+  -- See caveat in the comment to 'mkPat'.+  mkPatN :: forall d. Data d => Int -> d -> Pattern+  mkPatN n = f n . shapeOf+   where+    f 0 (Node p cs) = Node (if null cs then WS else WR) []+    f n (Node p cs) = Node (if null cs then WS else WR) $ map (f (-1+n)) cs+#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.)+  shrinkPat :: Pattern -> Pattern+  shrinkPat (Node p cs)+   | WI <- p  = Node WI []  -- can't shrink (eventually elided from parent)+   | WS <- p  = Node WI []  -- may as well+   | WN n <- p  = if n <= 1 then Node WI []+                  else if n == 2 then Node WS []+                  else Node (WN (-1+n)) []+#if USE_WW_DEEPSEQ+   | WW <- p  = Node (WN 5) []  -- XXX arbitrary hardcode+#endif+#if PARALLELISM_EXPERIMENT+   -- take de-parallelisation as shrinkage+   | PR <- p  = Node WR cs+   | PN n <- p  = Node (WN n) []+#if USE_WW_DEEPSEQ+   | PW <- p  = Node WW []+#endif+#endif+   -- take un-type-constrained as shrinkage+   | TI _ <- p  = Node WI []+   | TR _ <- p  = Node WR cs+   | TN n _ <- p  = Node (WN n) []+#if USE_WW_DEEPSEQ+   | TW _ <- p  = Node WW []+#endif+#if SHRINK_TO_EMPTY_WR+   | WR <- p , null cs  = Node WI []+#endif+   -- If this node has any grandchildren, recurse on the children.+   | not $ null $ filter (\ (Node q gcs) -> not $ null gcs) cs+      = Node p $ map shrinkPat cs+   -- At this point we know this node has no grandchildren.+   -- Check if all children are insulator nodes.+   | null $ filter (\ (Node p _) -> case p of { WI -> False ; _ -> True}) cs+      = case p of+         -- Must go to WI, since .{##} -> . is /not/ a lazification.+#if SHRINK_TO_EMPTY_WR+         WR -> Node WR []+#else+         WR -> Node WI []+#endif+#if PARALLELISM_EXPERIMENT+         PR -> Node WI []  -- sic+#endif+         TR _ -> Node WI []  -- sic+         _ -> error "shrinkPat: unexpected!"+   | otherwise+      = Node p $ map shrinkPat cs  -- still contains shrinkable children++#if 0+  canonicalisePostShrinkPat :: Pattern -> Pattern+  canonicalisePostShrinkPat nod@(Node p cs)+   | null $ filter (/= Node WI []) cs  = nod+   | otherwise                         = Node WI []+#endif++-------------------------------------------------------------------------------++#if PROVIDE_OLD_SHRINK_PAT+  -- | Old version, for temporary compatibility of seqaid demo mode.+  {-  DEPRECATED shrinkPat_old "For temporary compatibility of seqaid demo mode." #-}+  -- (Deprecation warning too noisy for me. Nobody will use this by accident.)+  shrinkPat_old :: Pattern -> Pattern+  shrinkPat_old (Node p cs)+   | not $ null $ filter (\ (Node q gcs) -> not $ null gcs) cs  = Node p $ map shrinkPat_old cs+   | WR <- p  = Node WS []+   | otherwise  = Node p []+#endif++-------------------------------------------------------------------------------++#if ! HASKELL98_FRAGMENT+  -- | Grow all leaves by one level within the shape of the provided value.+  growPat :: forall d. Data d => Pattern -> d -> Pattern+  growPat pat x = growPat' pat $ shapeOf x+  growPat' :: Pattern -> Shape -> Pattern+  growPat' (Node p []) (Node q ds) = Node p $ map (const (Node WS [])) ds+  growPat' (Node p cs) (Node q ds) = Node p $ zipWith growPat' cs ds+#endif++-------------------------------------------------------------------------------++  -- | This creates a new 'WR' node, the common root. The argument patterns+  -- become the children of the root (order is preserved).+  liftPats :: [ Pattern ] -> Pattern+  liftPats ps = Node WR ps++-------------------------------------------------------------------------------++  -- | Introduce siblings at a node (interior or leaf) of the target.+  -- The first argument is target, the second is a path, and the+  -- third is a list of subpatterns for insertion, along with the+  -- indices of the child before which to insert. If this index+  -- is negative, it counts from the right. Indices are always+  -- relative to the original target as it was received.+{--}+-- XXX Later: I don't understand. When would you use this?+-- You change the number of children at a node, which seems+-- unuseful. More reasonable than insertion would be to replace+-- select children with a new subpatterns.+  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' (Node p cs) [] isibs  -- end of path chain+     | maximum (map fst isibs) > ncs  = error "splicePats: sibling indices must not exceed the number of existing children"+     | otherwise  = {-trace "**1**" $-} Node p $ f 0 cs isibs_+     where+      ncs = length cs+      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 = if i < 0 then ncs-(-i) else i+    splice' (Node p 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)"+     | otherwise  = {-trace "**2**" $-} Node p (csL ++ [splice' c is isibs] ++ csR)+     where+      (c:csR) = ccsR+      (csL,ccsR) = splitAt i cs++-------------------------------------------------------------------------------++  -- | Elide siblings at a node (interior or leaf) of the target.+  -- The first argument is target, the second is a path, and the+  -- third is a list of child indices for elision.+  -- If this index is negative, it counts from the right.+  -- Indices are always relative to the original target as it was received.+{--}+-- XXX Later: I don't understand. When would you want to+-- change the number of children at a node (except possibly+-- to zero)?...+-- XXX This is templated from splicePats, and it seems more useful+-- for it to just take a single path, or a list of paths; it doesn't+-- really make sense to support multiple sibling elision in single pass.+-- XXX Yes, change that! Let it take a list of paths instead.+  elidePats :: Pattern -> [Int] -> [Int] -> Pattern+  elidePats target path isibs'+   | otherwise          = elide' target path isibs+   where+    isibs = sortBy comp isibs'  -- questionable solution+     where+      comp x1 x2 = compare x1 x2+    -- (See comment in elidePats.)+    elide' (Node p cs) [] isibs  -- end of path chain+     | maximum isibs > ncs  = error "elidePats: sibling indices must not exceed the number of existing children"+     | otherwise  = {-trace "**1**" $-} Node p $ f 0 cs isibs_+     where+      ncs = length cs+      isibs_ = let lst = takeWhile (== -1) isibs in+               drop (length lst) isibs ++ map (\ x -> ncs) lst+      f n cs [] = cs+      f n [] isibs_remaining = error $ "elidePats: (2) 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 = if i < 0 then ncs-(-i) else i+    elide' (Node p 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 p (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)?...+-- XXX It would be better if the weighting could be done once,+-- then maintained, but will have to see how it performs...+-- XXX It is lamentable that the change history of this function+-- along with the GHC error messages (notably the topmost of them)+-- is lost, since stuff like this would make exellent input+-- to compiler AI (for improving prioritisation of error+-- messages for example; the "lexical tradition" is also+-- at work here!...).+-- 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 pn chs)+   = ( Node pn $ left ++ [ ch'' ] ++ right , g' )+   where+    ch'' = ch'+--  ch'' = (\ (Node (r,p) 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 pn chs) = probDensRose pat+    wpat@(Node pn chs) = probDensRose pat+    f :: StdGen -> Rose (PatNode,Double) -> (Rose (PatNode,Double), StdGen)+    f g (Node pn chs)+     | isNothing mh  = ( Node pn chs, g )  -- ??+     | null chs   = ( Node pn [], g )+---  | null chs   = ( Node pn [], g'' )+     | null gchs  = ( Node pn $ left ++ [ Node (WI,1.0) [] ] ++ right , g'' )+---  | null gchs  = ( Node pn $ left ++ right , g'' )+     | otherwise  = ( Node pn $ 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 (_,p) _) -> p) 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 "| "++-------------------------------------------------------------------------------+
src/Control/DeepSeq/Bounded/Pattern.hs view
@@ -3,681 +3,309 @@    {-  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---- Now specified via --flag=[-]USE_WWW_DEEPSEQ---- #define USE_WW_DEEPSEQ 1- ------------------------------------------------------------------------------- --- Good idea: Let * be followed by an integer N.--- This shall have the semantics that, when that node--- is matched in the pattern, instead of rnf it is forcen N'd.---- There may be fusion possible (which is worth trying here--- for practise, even if this lib is not used much):------   forcep p1 . forcep p2 = forcep (unionPat [p1,p2])------ This holds if pattern doesn't contain #, or any (type-)constrained--- subpatterns -- the latter might work out, if exclude # from them too,--- but I'm not sure.  With #, we lose even monotonicity, let alone--- the above law.------ For the above to hold, remember, the union must have exactly--- the "forcing potential" of the LHS -- no more, no less.-----------------------------------------------------------------------------------#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.Pattern--- Copyright   :  (c) 2014, Andrew G. Seniuk+-- Copyright   :  Andrew G. Seniuk 2014-2015 -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>--- Stability   :  experimental+-- Stability   :  provisional -- Portability :  portable --  ------------------------------------------------------------------------------- -  module Control.DeepSeq.Bounded.Pattern+#if ! NEW_IMPROVED_PATTERN_GRAMMAR+#warning You are using the old pattern grammar (NEW_IMPROVED_PATTERN_GRAMMAR flag is False). This will be deprecated in version 0.7.+#endif +  module Control.DeepSeq.Bounded.Pattern   ( -     -- * Pattern datatype--       Pattern, PatNode(..)----   , patternShapeOK  -- useful for defining instances of NFDataP--     -- * Pattern DSL--  -- | __Grammar__-  ---  -- @-  -- /pat/ /->/ /[/ __=__ /]/ __.__ /[/ __{__ /{/ /pat/ /}/ __}__ /]/-  --     /|/  /(/ /[/ __=__ /]/ __*__ /[/ /decimalint/ /]/ /|/ __#__ /)/-  --     /|/  __.:__ /ctorname/ /{/ /space/ /ctorname/ /}/ __{__ /[/ /{/ /pat/ /}/ /]/ __}__-  --     /|/  /(/ __*__ /[/ /decimalint/ /]/ /|/ __#__ /)/ __:__ /typename/ /{/ /space/ /typename/ /}/ __{}__-  -- /typename/ -> /string/-  -- /ctorname/ -> /string/-  -- /decimalint/ -> /digit string not beginning with zero/-  -- /space/ -> /space character ASCII 0x32/-  -- @-  ---  -- [I regret that Haddock cannot offer better markup for distinguishing-  -- the metasyntax.  The bold is not bold enough.  The alternation symbol,-  -- although \/|\/ in the document comment, does not show as slanted for me.-  -- Had no luck using color, also Unicode support seems pretty sketchy.-  -- Embedding an image is possible via data URL, but this has been known-  -- to crash Haddock except for very small images.]-  ---  -- __Examples__-  ---  -- @".{...}"@ will match any ternary constructor.-  ---  -- @'rnfp' ".{...}" expr@ will force evaluation of @expr@ to a depth of two,-  -- provided the head of @expr@ is a ternary constructor; otherwise it behaves-  -- as @'rnfp' "#" expr@ (i.e. do nothing).-  ---  -- @'rnfp' ".{###}" expr@ will force it to only a depth of one. That is,-  -- @'rnfp' ".{###}" expr = 'rnfp' "." expr@ when the head of @expr@-  -- is a ternary constructor; otherwise it won't perform any evaluation.-  ---  -- @'rnfp' "*" expr = 'rnf' expr@.-  ---  -- @'rnfp' ".{***}" expr@ will 'rnf' (deep) any ternary constructor, but-  -- will not touch any constructor of other arity.-  ---  -- @'rnfp' ".{..{*.}.}" expr@ will match any ternary constructor, then-  -- match the second subexpression constructor if it is binary, and-  -- if matching got this far, then the left sub-subexpression-  -- will be forced ('rnf'), but not the right.-  ---  -- @'rnfp' ".{.*:T{}#}" expr@ will unwrap (shallow 'seq') the first-  -- subexpression of @expr@, and the third subexpression won't be touched.-  -- As for the second subexpression, if its type is @T@ it will be-  -- completely evaluated ('rnf'), but otherwise it won't be touched.-  ---  -- @'rnfp' ".{=**}" expr@ will spark the /parallel/ complete evaluation of-  -- the two components of any pair. (Whether the computations actually-  -- run in parallel depends on resource availability, and the discretion-  -- of the RTS, as usual).-  ---  -- __Details__-  ---  -- The present pattern parser ignores any subpatterns of all-  -- pattern nodes except 'WR', 'TR' and 'PR', optionally emitting a warning.-  -- Hence, only 'WR', 'TR' and 'PR' patterns are potentially recursive.-  ---  -- When specifying a list of subpatterns with 'WR' or 'PR',-  -- in order for the match to succeed, the number of subpatterns must-  -- be equal to the arity of the named constructor.-  ---  -- Type constraints must always be followed by __{__ (opening brace) as delimiter.-  -- In the case of 'TR', if no recursion is desired, provide __{}__.-  -- In order for the match to succeed, the number of subpatterns must either-  -- be zero (__{}__), or be equal to the arity of the named constructor.-  ----     , compilePat-     , showPat--     -- * Why depend on whole containers package, when we only want a rose tree--     , Rose(..)--     -- * Preferred to have this in Seqable, but had cyclical dependency issues--     , SeqNodeKind(..)--  )--  where+#if NEW_IMPROVED_PATTERN_GRAMMAR --------------------------------------------------------------------------------+     -- * Pattern datatype -#if DO_DERIVE_DATA_AND_TYPEABLE-  import Data.Data ( Data )-  import Data.Typeable ( Typeable )-#elif DO_DERIVE_ONLY_TYPEABLE-  import Data.Typeable ( Typeable )-#endif+       Pattern -#if USE_WW_DEEPSEQ-  import Control.DeepSeq ( NFData )-#endif+     , PatNode(..) -  import Data.List ( intersperse )-  import Data.Char ( isDigit )-  import Data.Maybe ( isNothing, fromJust )+     , PatNodeAttrs(..) -  import Debug.Trace ( trace )-#if USE_WW_DEEPSEQ-  -- 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 NFDATA_INSTANCE_PATTERN-  -- for helping trace debugging-  import qualified Control.DeepSeq.Generics as DSG-  import qualified GHC.Generics as GHC ( Generic )-#endif-#endif+     -- * Pattern DSL --------------------------------------------------------------------------------+-- XXX You cannot use CPP here to tack on a note at the head of+-- this doc comment, probably because CPP (all of 'em) tend+-- to (not very smartly IMO) inject blank lines, which throws+-- Haddock off as document comments are ended by (among other+-- things) a blank line.+--+-- So if I want this touch, I need to duplicate the whole large+-- comment block, which I am willing to do as this is very+-- short-term (perhaps one month). -#if DO_TRACE-  mytrace = trace+#if HASKELL98_FRAGMENT+{- XXX PLEASE DON'T EDIT BELOW (i.e. this) BRANCH BY ACCIDENT!!! -}+     -- | /NOTE: You are using the HASKELL98_FRAGMENT (defaults False; set True).  This means, for a short time, the DSL is unavailable, and you will need to resort to using the PatNode constructors directly.  (The Blah98_new_grammar test suite is also unavailable.)  The reason is that the new grammar parser is written in attoparsec, which is far from being Haskell 98 (depends directly or indirectly on many language extensions).  This situation should be remedied by 0.7 (release expected early March 2015), maybe perhaps sooner, when I write an H98 parser for the new grammar.  In any case, these comments have been allowed to stand as they contain other useful information and examples./+     --+{- XXX Copy from the below, once it's stabilised! -}+{- XXX PLEASE DON'T EDIT ABOVE (i.e. this) BRANCH BY ACCIDENT!!! -} #else-  mytrace _ = id+     -- | __Grammar__+     --+     -- @+     -- /pat/          /->/  /[/ /modifiers/ /]/ /pat'/+     -- /pat'/         /->/     __.__  /|/  __!__  /|/  __*__ /[/ /decimalint/ /]/  /|/  __(__ /{/ /pat/ /}/ __)__+     -- /modifiers/    /->/  zero or one of each of the eight /modifier/, in any order+     -- /modifier/     /->/     __=__  /|/  __+__  /|/  __^__  /|/  __\/__  /|/  __%__+     --                  /|/  __:__ /typename/ /{/ __;__ /typename/ /}/ __:__+     --                  /|/  __@__ /decimalint/+     --                  /|/  __>__ /permutation/+     -- /typename/     /->/  string containing neither __:__ (unless /escaped/) nor __;__+     -- /escaped/      /->/  __\\\\:__ +     -- /decimalint/   /->/  digit string not beginning with zero+     -- /permutation/  /->/  of an initial part of the lowercase alphabet, /e.g./ __cdba__+     -- @+     --+     -- Here is the grammar in a more <http://fremissant.net/deepseq-bounded/grammar.html#new-grammar vivid rendering>.+     -- (Haddock makes it tricky to distinguish between metasyntax and concrete syntax.)+     --+     -- Optional whitespace can go between any two tokens (basically,+     -- anyplace there is space shown in the grammar above).+     --+     -- Semicolons never need escaping, because they're already illegal+     -- as part of any Haskell type name.+     --+     -- The semantics are given formally in the 'PatNode' and 'PatNodeAttrs'+     -- documentation, as well as informally in the examples below and from+     -- the project <http://www.fremissant.net/deepseq-bounded homepage>.+     --+     -- __Examples__+     --+     -- @\"__(...)__\"@ will match any ternary constructor.+     --+     -- @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__(!!!)__\" expr@ will force evaluation of @expr@ to a depth of two,+     -- provided the head of @expr@ is a ternary constructor; otherwise it behaves+     -- as @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__.__\" expr@ (/i.e./ do nothing).+     --+     -- @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__(...)__\" expr@ will force it to only a depth of one. That is,+     -- @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__(...)__\" expr =+     -- <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp>+     -- \"__!__\" expr@ when the head of @expr@+     -- is a ternary constructor; otherwise it won't perform any evaluation.+     --+     -- @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__*__\" expr = <http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData rnf> expr@.+     --+     -- @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__(***)__\" expr@ will <http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData rnf> (deep) any ternary constructor, but+     -- will not touch any constructor of other arity.+     --+     -- @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__(.(*.).)__\" expr@ will match any ternary constructor, then+     -- match the second subexpression constructor if it is binary, and+     -- if matching got this far, then the left sub-subexpression+     -- will be forced (<http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData rnf>), but not the right.+     --+     -- @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__(!:T:*.)__\" expr@ will unwrap (shallow 'seq') the first+     -- subexpression of @expr@, and the third subexpression won't be touched.+     -- As for the second subexpression, if its type is @T@ it will be+     -- completely evaluated (<http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData rnf>), but otherwise it won't be touched.+     --+     -- @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__(=**)__\" expr@ will spark the /parallel/ complete evaluation of+     -- the two components of any pair. (Whether the computations actually+     -- run in parallel depends on resource availability, and the discretion+     -- of the RTS, as usual).+     --+     -- @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataP.html#t:NFDataP rnfp> \"__(>ba(+*+*)=*)__\" expr@ matches a binary constructor, whose first parameter is also a binary constructor. This identifies three main AST branches -- serendipitously symbolised by asterisks -- making up the expression: which branches we'll call __A__, __B__ and __C__. So this example will perform <http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData rnf>, but in a controlled manner: __A__ and __B__ are forced in parallel with __C__, and furthermore, __B__ is forced before __A__. A traceline will be printed at the beginning of the forcing of __B__ and then another traceline will be printed at the beginning of the forcing of __A__. Note that \"__(=>ba(+*+*)*)__\" would be a legal equivalent.+     --+     -- I make no claims as to the usefulness of the examples, they are here just to explain the semantics of the DSL.+     --+     -- __Details__+     --+     -- The present pattern parser ignores any subpatterns of all+     -- pattern nodes except 'WR' and 'TR', optionally emitting a warning.+     -- /(XXX In 0.6.0.0, I'm not sure the warning is still possible.)/+     -- Hence, only 'WR' and 'TR' patterns are potentially recursive.+     --+     -- When specifying the list of subpatterns with 'WR' and 'TR',+     -- in order for the match to succeed, the number of subpatterns must+     -- be equal to the arity of the constructor the pattern node is+     -- matching against. (No other pattern node types accept subpatterns.)+     --+     -- Additionally, in the case of 'TR', matching (and consequent recursion) will only+     -- succeed if the term node has constructor name which is listed in the constraints.+     --+     -- It would be possible to have 'TR' nodes interpret the constraint+     -- as type name rather than constructor name, but this would require /sum patterns/+     -- (maybe for version 0.7).  The problem is, no single 'WR' node+     -- can match multiple constructors of differing arity.  This has the+     -- feel of an excellent application for SOP generics!...+     --+     -- (As contrasted with 'TR' nodes,) 'TI', 'TN' and 'TW' nodes interpret+     -- type constraint strings as type names (not constructor names).+     -- A moment's reflection will show you why it must be so.+     --+     -- Finally, if you're trying to name a constructor with __:__ in its name,+     -- you must escape the colon with a backslash thus __\\\\:__ because+     -- the unescaped colon is used as (opening and) closing character for+     -- lists of type and constructor names.+{--}+     -- Old interjection:+     -- I regret that Haddock cannot offer better markup for distinguishing+     -- the metasyntax.  The bold is not bold enough.  The alternation symbol,+     -- although \/|\/ in the document comment, does not show as slanted for me.+     -- Had no luck using color, also Unicode support seems pretty sketchy.+     -- Embedding an image is possible via data URL, but this has been known+     -- to crash Haddock except for very small images.+{--}+-- I'm still not sure if I try accepting a double-colon close here?+-- (Checking...)+     --              /|/   /(/ __.__  /|/  __*__ /[/ /decimalint/ /]/ /)/ __::__ /typename/ /{/ __;__ /typename/ /}/ __:__ /[/ __:__ /]/ #endif ----------------------------------------------------------------------------------  data Rose a = Node a [ Rose a ]-#if NFDATA_INSTANCE_PATTERN-#if DO_DERIVE_DATA_AND_TYPEABLE-   deriving (Show, Eq, GHC.Generic, Data, Typeable)--- deriving (Show, Eq, Functor, GHC.Generic, Data, Typeable)-#elif DO_DERIVE_ONLY_TYPEABLE-   deriving (Show, Eq, GHC.Generic, Typeable)-#else-   deriving (Show, Eq, GHC.Generic)-#endif-#else-#if DO_DERIVE_DATA_AND_TYPEABLE-   deriving (Show, Eq, Data, Typeable)-#elif DO_DERIVE_ONLY_TYPEABLE-   deriving (Show, Eq, Typeable)-#else-   deriving (Show, Eq)-#endif+#if 0+-- These are now in Compile (but may move them back once sort out some stuff)+     , compilePat+     , showPat #endif-  type Pattern = Rose PatNode -  instance Functor Rose where-    fmap f (Node x chs) = Node (f x) (map (fmap f) chs)--#if NFDATA_INSTANCE_PATTERN-  instance NFData a => NFData (Rose a) where rnf = DSG.genericRnf-#endif+     , isWI , isWR , isWS , isWN , isWW , isTI , isTR , isTN , isTW --------------------------------------------------------------------------------+     , emptyPatNodeAttrs+--   , emptySparkPatNodeAttrs+     , getPatNodeAttrs+     , setPatNodeAttrs+     , setPatNodePingParentTID+     , showPerm+     , showPatRaw+     , showPatNodeRaw -  -- | Note that only 'WR', 'TR' and 'PR' allow for explicit recursion.-  -- The other 'PatNode's are in leaf position when they occur in a 'Pattern'.+     , setPatternPatNodeUniqueIDs -  data PatNode-       =-         WR  -- ^ Continue pattern matching descendants.-       | WS  -- ^ Stop recursing (nothing more forced down this branch).-       | WN Int  -- ^ @'rnfn' n@ the branch under this node.-#if USE_WW_DEEPSEQ-       | WW  -- ^ Fully force ('rnf') the whole branch under this node.-#endif-       | WI  -- ^ Don't even unwrap the constructor of this node.-{--} -- XXX It's still unclear whether TI should allow subpatterns;--- the alternative is for TI, when type doesn't match, to behave--- as "." (no subpatterns); but since I say "otherwise behave as TR",--- and TR says "continue pattern matching descendants", this seems to--- say that subpatterns should be permitted.  Certainly it's no problem--- to permit subpatterns in this case, but WI should still ignore--- subpatterns since it will always be # regardless of node type.--- (Subpatterns ought to be "safely redundant" in this case, but whether--- they are depends on implementation and needs to be tested if allow--- WI subpatterns to survive past the parser/compiler!)---   And this all applies to TW and TN too, right? Yes.--- It seems clear that TI, TW and TN should all allow subpatterns.--- And that WI, WW and WN should elide them and issue a warning.---   But, none of my present woes seem to be connected with this...--- Nonetheless, it's important to pin down the semantics.-#if 1-       | TR [String]  -- ^ Match any of the types in the list (and continue pattern matching descendants); behave as 'WI' for nodes of type not in the list. (Note this behaviour is the complement of 'TI' behaviour.)----    | TS [String]  -- ^ Same as 'TR' except no subpatterns present.-       | TN Int [String]  -- ^ @'rnfn' n@ the branch under this node, if the node type matches any of the types in the list.-#if USE_WW_DEEPSEQ-       | TW [String]  -- ^ Fully force ('rnf') the whole branch under this node, if the node type matches any of the types in the list; otherwise behave as 'WI'.-#endif-       | TI [String]  -- ^ Don't even unwrap the constructor of this node, if it's type is in the list; otherwise behave as 'WR'. (Note this behaviour is the complement of 'TR' behaviour.)-#else-       | TR [TypeRep]  -- ...-#endif-#if PARALLELISM_EXPERIMENT-       | PR  -- ^ Spark the pattern matching of this subtree.-       | PN Int  -- ^ Spark @'rnfn' n@ of this subtree.-#if USE_WW_DEEPSEQ-       | PW  -- ^ Spark the full forcing ('rnf') of this subtree.-#endif-#endif-#if NFDATA_INSTANCE_PATTERN-#if DO_DERIVE_DATA_AND_TYPEABLE-       deriving ( Show, Eq, Typeable, Data, GHC.Generic )-#elif DO_DERIVE_ONLY_TYPEABLE-       deriving ( Show, Eq, Typeable, GHC.Generic )-#else-       deriving ( Show, Eq, GHC.Generic )-#endif-#else-#if DO_DERIVE_DATA_AND_TYPEABLE-       deriving ( Show, Eq, Typeable )  -- Data apparently not needed-#elif DO_DERIVE_ONLY_TYPEABLE-       deriving ( Show, Eq, Typeable )-#else-       deriving ( Show, Eq )-#endif-#endif+--   , patternShapeOK  -- useful for defining instances of NFDataP -#if NFDATA_INSTANCE_PATTERN-  instance NFData PatNode where rnf = DSG.genericRnf-#endif+     -- * Why depend on whole containers package, when we only want a rose tree --------------------------------------------------------------------------------+     , Rose(..) -#if 0-  patternShapeOK :: Data a => Pattern -> a -> Bool-  patternShapeOK pat x = S.shapeOf pat == S.shapeOf x-#endif+     -- * Preferred to have this in Seqable, but had cyclical dependency issues --------------------------------------------------------------------------------+     , SeqNode(..) -  -- 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_ :: 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 [] s_ []  -- XXX ??-    s_ = translateStarN s+     -- * Pattern datatype -  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+       Pattern+     , PatNode(..) -  parseInt :: String -> String -> ( Maybe String, String )-  parseInt [] acc = ( if null acc then Nothing else Just acc , "" )-  parseInt s@(c:cs) acc-   | length acc > 8  = error $ "compilePat: * followed by too many (>8) digits"-   | isDigit c       = parseInt cs (acc++[c])-   | otherwise       = ( if null acc then Nothing else Just acc , s )+--   , patternShapeOK  -- useful for defining instances of NFDataP -  -- 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)-  --           - empty list doesn't signal anything about whether W* or T* node-  --  (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] -> String -> [Pattern] -> ([Pattern], String)-  compilePat' spark mpn mn (t:ts) (c:cs) _-   | not $ c `elem` "{.*#"  = error $ "compilePat: parse error: post-treps pattern char " ++ show c ++ " not one of {.*#"-  compilePat' spark mpn mn [] [] acc = mytrace "EMPTY" $ (acc, [])-  compilePat' spark mpn mn [] (' ':cs) acc = mytrace "space" $ compilePat' spark mpn mn [] cs acc-  compilePat' spark mpn mn [] ('}':'{':cs) acc = error $ "compilePat: opening brace cannot follow closing brace"-  compilePat' spark mpn mn [] ('}':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 [] (c:':':cs) acc-   | null treps  = error $ "compilePat: colon must be followed by at least one type name"-   | otherwise   = compilePat' spark mpn mn treps (c:cs') acc-   where---  !_ = trace ("Boo: " ++ show (treps, cs')) ()-    (treps, cs') = compileTypeReps cs-  compilePat' spark mpn Nothing [] ('@':cs) acc-   | isNothing mn  = error $ "compilePat: internal error @2 (please report this bug!)"-   | otherwise     = compilePat' spark mpn mn [] ('@':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) [] ('@':cs) acc-   = compilePat' False mpn Nothing [] 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) [] (c:cs) acc-   = error $ "compilePat: internal error @1(" ++ [c] ++") (please report this bug!)"-  compilePat' spark mpn mn treps (c:'{':cs) acc = compilePat' spark mpn mn [] cs' (acc++[node])-   where-    (chs, cs') = mytrace (".{-cs="++cs) $ compilePat' spark mpn mn [] cs []-    node-     | null treps = 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'-     | otherwise = 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-\"{\": warning: * with subpattern" $ Node (TW treps) chs-#endif-        '#' -> trace "compilePat-\"{\": 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-\"{\": warning: * with subpattern" $ Node (TW treps) []-#endif-        '#' -> trace "compilePat-\"{\": warning: # with subpattern" $ Node (TI treps) []-#endif-#endif-        _ -> error $ "compilePat-T-\"{\": unexpected " ++ show c ++ " (cs'=" ++ cs'-#if PARALLELISM_EXPERIMENT-  compilePat' spark mpn mn treps ('=':cs) acc = compilePat' True mpn mn treps cs acc-#endif-  compilePat' spark mpn mn treps (c:cs) acc = compilePat' False mpn mn [] cs (acc++[node])---compilePat' spark mpn mn treps (c:cs) acc = compilePat' False mpn mn [] 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+     -- * Pattern DSL --------------------------------------------------------------------------------+     -- | __Grammar__+     --+     -- @+     -- /pat/ /->/ /[/ __=__ /]/ __.__ /[/ __{__ /{/ /pat/ /}/ __}__ /]/+     --     /|/  /(/ /[/ __=__ /]/ __*__ /[/ /decimalint/ /]/ /|/ __#__ /)/+     --     /|/  __.:__ /ctorname/ /{/ /space/ /ctorname/ /}/ __{__ /[/ /{/ /pat/ /}/ /]/ __}__+     --     /|/  /(/ __*__ /[/ /decimalint/ /]/ /|/ __#__ /)/ __:__ /typename/ /{/ /space/ /typename/ /}/ __{}__+     -- /typename/ -> /string/+     -- /ctorname/ -> /string/+     -- /decimalint/ -> /digit string not beginning with zero/+     -- /space/ -> /space character ASCII 0x32/+     -- @+     --+     -- Here is the grammar in a more <http://fremissant.net/deepseq-bounded/grammar.html vivid rendering>.+     -- (The Haddock markup makes it almost tricky to distinguish between metasyntax and concrete syntax.)+     --+     -- __Examples__+     --+     -- @\".{...}\"@ will match any ternary constructor.+     --+     -- @'rnfp' \".{...}\" expr@ will force evaluation of @expr@ to a depth of two,+     -- provided the head of @expr@ is a ternary constructor; otherwise it behaves+     -- as @'rnfp' \"#\" expr@ (/i.e./ do nothing).+     --+     -- @'rnfp' \".{###}\" expr@ will force it to only a depth of one. That is,+     -- @'rnfp' \".{###}\" expr = 'rnfp' \".\" expr@ when the head of @expr@+     -- is a ternary constructor; otherwise it won't perform any evaluation.+     --+     -- @'rnfp' \"*\" expr = 'rnf' expr@.+     --+     -- @'rnfp' \".{***}\" expr@ will 'rnf' (deep) any ternary constructor, but+     -- will not touch any constructor of other arity.+     --+     -- @'rnfp' \".{..{*.}.}\" expr@ will match any ternary constructor, then+     -- match the second subexpression constructor if it is binary, and+     -- if matching got this far, then the left sub-subexpression+     -- will be forced ('rnf'), but not the right.+     --+     -- @'rnfp' \".{.*:T{}#}\" expr@ will unwrap (shallow 'seq') the first+     -- subexpression of @expr@, and the third subexpression won't be touched.+     -- As for the second subexpression, if its type is @T@ it will be+     -- completely evaluated ('rnf'), but otherwise it won't be touched.+     --+     -- @'rnfp' \".{=**}\" expr@ will spark the /parallel/ complete evaluation of+     -- the two components of any pair. (Whether the computations actually+     -- run in parallel depends on resource availability, and the discretion+     -- of the RTS, as usual).+     --+     -- __Details__+     --+     -- The present pattern parser ignores any subpatterns of all+     -- pattern nodes except 'WR', 'TR' and 'PR', optionally emitting a warning.+     -- Hence, only 'WR', 'TR' and 'PR' patterns are potentially recursive.+     --+     -- When specifying a list of subpatterns with 'WR' or 'PR',+     -- in order for the match to succeed, the number of subpatterns must+     -- be equal to the arity of the named constructor.+     --+     -- Type constraints must always be followed by __{__ (opening brace) as delimiter.+     -- In the case of 'TR', if no recursion is desired, provide __{}__.+     -- In order for the match to succeed, the number of subpatterns must either+     -- be zero (__{}__), or be equal to the arity of the named constructor.+     --+{--}+     -- Old interjection:+     -- I regret that Haddock cannot offer better markup for distinguishing+     -- the metasyntax.  The bold is not bold enough.  The alternation symbol,+     -- although \/|\/ in the document comment, does not show as slanted for me.+     -- Had no luck using color, also Unicode support seems pretty sketchy.+     -- Embedding an image is possible via data URL, but this has been known+     -- to crash Haddock except for very small images. -  -- | 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+#if 0+-- These are now in Compile (but may move them back once sort out some stuff)+     , compilePat+     , showPat #endif --------------------------------------------------------------------------------+     -- * Why depend on whole containers package, when we only want a rose tree -  -- 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]+     , Rose(..) --------------------------------------------------------------------------------+     -- * Preferred to have this in Seqable, but had cyclical dependency issues -  -- | Inverse of 'compilePat'.-  ---  -- @'showPat' . 'compilePat' patstring  =  patstring@-  ---  -- provided that @'compilePat' patstring@ succeeds. (And, only up to-  -- subpatterns elided from # ('WI' or 'TI') or from * ('WW', 'WN',-  -- 'TW', 'TN', 'PW' or 'PN') nodes.)-  showPat :: Pattern -> String-  showPat (Node p chs)+     , SeqNode(..) -    | WR         <- p  = "."  ++ descend chs ++ perhapsEmptyBraces-    | 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 ++ perhapsEmptyBraces-    | PN n       <- p  = error "PN PatNode not yet supported (sorry!)"-#if USE_WW_DEEPSEQ-    | PW         <- p  = "#"  ++ descend chs-#endif-#endif+--- #if NEW_IMPROVED_PATTERN_GRAMMAR+---      module Control.DeepSeq.Bounded.Pattern_new_grammar  ,+--- #else+---      module Control.DeepSeq.Bounded.Pattern_old_grammar  ,+--- #endif -    | TR treps   <- p  = ".:" ++ descendT treps chs ++ perhapsEmptyBraces-    | 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-    perhapsEmptyBraces = if null chs then "{}" else ""-  descend :: [Pattern] -> String-  descend chs-   | null chs = ""-   | otherwise = "{" ++ concatMap showPat chs ++ "}"-  descendT :: [String] -> [Pattern] -> String-  descendT treps chs = treps_ ++ descend chs-   where treps_ = concat (intersperse " " treps)+  )+  where  ------------------------------------------------------------------------------- -  -- Note that Ord is derived, so the order that the constructors-  -- are listed matters!  (This only affects GHC rules, SFAIK.)-  -- (This data type is here, to avoid cyclical imports which-  -- GHC pretty much is useless with.)-  ---------  -- On the one hand, we want to keep this lightweight -- it can in-  -- principle be a single bit (Insulate/Propagate), as originally planned!-  -- But the Spark thing was too useful; and Print and Error would-  -- also be useful.  But they're more orthogonal.-#if 0-  type Spark = Bool-  type PrintPeriod = Int-  type ErrorMsg = String-  data SeqNodeKind =-           Insulate Spark PrintPeriod-         | Conduct Spark PrintPeriod-         | Force Spark PrintPeriod-         | Error ErrorMsg-    deriving ( Eq, Ord )+#if NEW_IMPROVED_PATTERN_GRAMMAR+  import Control.DeepSeq.Bounded.Pattern_new_grammar #else-  data SeqNodeKind =-           Insulate----      | Conduct-         | Propagate  -- XXX if include Conduct, then rename Propagate to Force-#if PARALLELISM_EXPERIMENT-         | Spark-#endif--- These would break the Ord; and besides, they're sort of orthogonal--- (as is Spark)----      | Print Int----      | Error String-    deriving ( Eq, Ord )+  import Control.DeepSeq.Bounded.Pattern_old_grammar #endif  -------------------------------------------------------------------------------
+ src/Control/DeepSeq/Bounded/Pattern_new_grammar.hs view
@@ -0,0 +1,694 @@++-------------------------------------------------------------------------------++  {-  LANGUAGE CPP #-}++#define DO_TRACE 0++#define USE_POST_ORDER_IDS 0++#define SHOW_PAT_NODE_ATTRS 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++-------------------------------------------------------------------------------++-- Good idea: Let * be followed by an integer N.+-- This shall have the semantics that, when that node+-- is matched in the pattern, instead of rnf it is forcen N'd.++-- There may be fusion possible (which is worth trying here+-- for practise, even if this lib is not used much):+--+--   forcep p1 . forcep p2 = forcep (unionPat [p1,p2])+--+-- This holds if pattern doesn't contain #, or any (type-)constrained+-- subpatterns -- the latter might work out, if exclude # from them too,+-- but I'm not sure.  With #, we lose even monotonicity, let alone+-- the above law.+--+-- For the above to hold, remember, the union must have exactly+-- the "forcing potential" of the LHS -- no more, no less.++-------------------------------------------------------------------------------++#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.Pattern_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+--++-------------------------------------------------------------------------------++  module Control.DeepSeq.Bounded.Pattern_new_grammar+  where++-------------------------------------------------------------------------------++#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++  import Control.Concurrent ( ThreadId )++  import Data.List ( intercalate )+  import Data.Char ( isDigit )+  import Data.Maybe ( isNothing, fromJust )+  import Data.Maybe ( isJust )++  import Debug.Trace ( trace )+#if USE_WW_DEEPSEQ+  -- 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 NFDATA_INSTANCE_PATTERN+  -- for helping trace debugging+  import qualified Control.DeepSeq.Generics as DSG+  import qualified GHC.Generics as GHC ( Generic )+#endif+#endif++  import Data.Char ( ord )+  import Data.Char ( chr )++  import Control.Monad.State as ST++-------------------------------------------------------------------------------++#if DO_TRACE+  mytrace = trace+#else+  mytrace _ = id+#endif++-------------------------------------------------------------------------------++  data Rose a = Node a [ Rose a ]+#if NFDATA_INSTANCE_PATTERN+#if DO_DERIVE_DATA_AND_TYPEABLE+   deriving (Show, Eq, GHC.Generic, Data, Typeable)+-- deriving (Show, Eq, Functor, GHC.Generic, Data, Typeable)+#elif DO_DERIVE_ONLY_TYPEABLE+   deriving (Show, Eq, GHC.Generic, Typeable)+#else+   deriving (Show, Eq, GHC.Generic)+#endif+#else+#if DO_DERIVE_DATA_AND_TYPEABLE+   deriving (Show, Eq, Data, Typeable)+#elif DO_DERIVE_ONLY_TYPEABLE+   deriving (Show, Eq, Typeable)+#else+   deriving (Show, Eq)+#endif+#endif+  type Pattern = Rose PatNode++  instance Functor Rose where+    fmap f (Node x chs) = Node (f x) (map (fmap f) chs)++#if NFDATA_INSTANCE_PATTERN+  instance NFData a => NFData (Rose a) where rnf = DSG.genericRnf+#endif++-------------------------------------------------------------------------------++-- XXX+--+-- A major design decision needs to be made [does it?...]:+-- Is PatNode to remain a SUM ( ctor1 | ctor2 | ... ) or should+-- it be refactored to be a PRODUCT, i.e. a new field called+-- patNodeKind :: PatNodeKind, and all the fields of PatNodeAttrs+-- are lifted up to be siblings of patNodeKind in a single+-- top-level product (and PatNodeAttrs identifier elided).+--+-- The SUM has the advantage of convenient pattern-matching,+-- whereas the PRODUCT ... well, since we're using record syntax+-- (not yet in PatNode though!...), we CAN (I just discovered!)+-- do plain H98 pattern matching on multi-parameter constructors,+-- projecting out JUST any one value into a fresh pattern variable.+--+-- So in light of that, the refactoring to product has a lot to+-- recommend it -- however, will there not be a runtime penalty+-- of an extra wrapper or selector application or something?...+--+-- Am I missing anything crucial?...+--+-- If PatNode became a newtype, we pay only a compile-time price, right?...+--+-- Reading:+--+--   newtype Age = Age { unAge :: Int }+-- brings into scope both a constructor and a de-constructor:+--      Age :: Int -> Age+--    unAge :: Age -> Int+--+-- Thanks! I was just trying to remember this.+-- So incidentally, newtypes allow record syntax but only for+-- SINGLE PARAMETER constructor. (So newtypes will be of little+-- use if we adopted the product design above.)++-------------------------------------------------------------------------------++  -- | These attributes can be mixed freely. Certain combinations may+  -- seem unuseful, but nothing is prohibited by design.+  --+  -- While this may seem bloated, most of these capabilities can+  -- be truly banished from the code via build flags (USE_PAR_PATNODE etc.).+  --+  -- In the concrete pattern syntax, all attributes are represented+  -- as prefix modifiers (prefixing the+  -- @\'.\'@, @\'!\'@, @\'(\'@ or @\'*\'@+  -- pattern node designator),+  -- except for 'depth' and 'typeConstraints', which are postfix.+  -- Prefix modifiers may be given in any order, but the postfix+  -- must be in depth-then-type-constraints order when both are present.+  -- +{--}+  -- XXX Is there any particular reason these fields should be marked strict?+  -- Should they be explicitly unboxed as well? (Performance has been adequate+  -- for the purposes so far...).+  data PatNodeAttrs+         = PatNodeAttrs {+               uniqueID :: !Int              -- ^ Optional for convenience; set up with 'setPatternPatNodeUniqueIDs'. Beware that this function is not called automatically (or if it happens to be at the moment, this behaviour shouldn't be relied upon). For example, if you were to call <http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-PatUtil.html#v:growPat growPat>, the added nodes would all have \"uniqueID\" of 0.+             , depth :: !Int                 -- ^ (__*__/n/) &#8195; Depth of forcing for 'WN' and 'TN' nodes (/n/ is decimal integer depth).+             , doConstrainType :: !Bool      -- ^ (__:__) &#8195; Constrain pattern to match only types named in 'typeConstraints'. /__XXX__ This should be considered experimental still in 0.6. This and the "NFDataPDyn" aspects lost attention to/ <http://hackage.haskell.org/package/seqaid seqaid>.+             , typeConstraints :: ![String]  -- ^ The list of type rep strings used in the type constraint (when 'doConstrainType' is 'True').+             , doDelay :: !Bool              -- ^ (__@__) &#8195; Delay (current thread) for 'delayus' microseconds. /__XXX__ Still buggy?/+             , delayus :: !Int               -- ^ Microseconds of delay (when 'doDelay' is 'True').+#if USE_PAR_PATNODE+             , doSpark :: !Bool              -- ^ (__=__) &#8195; Spark matching for parallel evaluation.+#endif+#if USE_PSEQ_PATNODE+             , doPseq :: !Bool               -- ^ (__>__/perm/) &#8195; Sequence child subpattern matching, according to the permutation in 'pseqPerm'.+             , pseqPerm :: Maybe [Int]       -- ^ Lowercase alphabetic sequence is used in the concrete pattern syntax.  @__>cdba(wxyz)__@ will cause subpattern matching recursion on a quaternary constructor, with the subpattern computations sequenced @__y__@ then @__z__@ then @__x__@ then @__w__@ (order corresponds to @__cdba__@).+{-[XXX Until it really is, better not leave it saying so!] It is a runtime error (with a message), tested during matching, if this is a Just value and the list is not compatibly sized with the subpatterns. Sequencing syntax therefore would only work with 'WR' and 'TR' nodes, so we trap for the other cases and give a suitable error message.-}+#endif+#if USE_TRACE_PATNODE+             , doTrace :: !Bool              -- ^ (__+__) &#8195; Output a traceline to stderr.+#endif+#if USE_PING_PATNODE+             , doPing :: !Bool               -- ^ (__^__) &#8195; Raise informative (asynchronous? support is not strong for it, <http://hackage.haskell.org/package/base/docs/Control-Exception.html#v:throwTo throwTo> blocks...) exception /en passant/, for benefit of upstream. The exception is thrown in a new thread, so that the pattern matching continues; for a terminating version, see 'doDie'.+             , pingParentTID :: Maybe ThreadId  -- ^ Needed as argument for 'throwTo' call.+#endif+#if USE_DIE_PATNODE+             , doDie :: !Bool                -- ^ (__/__) &#8195; Kill (just this) thread.+#endif+#if USE_TIMING_PATNODE+             , doTiming           :: !Bool   -- ^ (__%__) &#8195; Note time passed since pattern-matched parent node. /__XXX__ Work in progress./+             , timestamp          :: !Int  -- XXX for now+             , parent_timestamp   :: !Int+             , delta_timestamp    :: !Int+#endif+           }+#if NFDATA_INSTANCE_PATTERN+#if DO_DERIVE_DATA_AND_TYPEABLE+       deriving ( Show, Eq, Typeable, Data, GHC.Generic )+#elif DO_DERIVE_ONLY_TYPEABLE+       deriving ( Show, Eq, Typeable, GHC.Generic )+#else+       deriving ( Show, Eq, GHC.Generic )+#endif+#else+#if DO_DERIVE_DATA_AND_TYPEABLE+       deriving ( Show, Eq, Typeable )  -- Data apparently not needed+#elif DO_DERIVE_ONLY_TYPEABLE+       deriving ( Show, Eq, Typeable )+#else+       deriving ( Show, Eq )+#endif+#endif++#if NFDATA_INSTANCE_PATTERN+  instance NFData ThreadId where rnf x = ()+  instance NFData PatNodeAttrs where rnf = DSG.genericRnf+#endif++  emptyPatNodeAttrs :: PatNodeAttrs+  emptyPatNodeAttrs+   = PatNodeAttrs {+         uniqueID           = 0+       , depth              = 0+       , doConstrainType    = False+       , typeConstraints    = []+       , doDelay            = False+       , delayus            = 0+#if USE_PAR_PATNODE+       , doSpark            = False+#endif+#if USE_PSEQ_PATNODE+       , doPseq             = False+       , pseqPerm           = Nothing+#endif+#if USE_TRACE_PATNODE+       , doTrace            = False+#endif+#if USE_PING_PATNODE+       , doPing             = False+       , pingParentTID      = Nothing+#endif+#if USE_DIE_PATNODE+       , doDie              = False+#endif+#if USE_TIMING_PATNODE+       , doTiming           = False+       , timestamp          = 0  -- Int for now+       , parent_timestamp   = 0+       , delta_timestamp    = 0+#endif+     }++-- (later: seems unused so commenting out)+--emptySparkPatNodeAttrs :: PatNodeAttrs+--emptySparkPatNodeAttrs = emptyPatNodeAttrs { doSpark = True }++  getPatNodeAttrs :: PatNode -> PatNodeAttrs+  getPatNodeAttrs pas+   | WI as <- pas  = as+   | WS as <- pas  = as+   | WR as <- pas  = as+   | WN as <- pas  = as+   | WW as <- pas  = as+   | TI as <- pas  = as+--- | TS as <- pas  = as+   | TR as <- pas  = as+   | TN as <- pas  = as+   | TW as <- pas  = as+   | otherwise  = error $ "getPatNodeAttrs: unexpected PatNode: " ++ show pas++  setPatNodeAttrs :: PatNode -> PatNodeAttrs -> PatNode+  setPatNodeAttrs pas as'+   | WI{} <- pas  = WI as'+   | WS{} <- pas  = WS as'+   | WR{} <- pas  = WR as'+   | WN{} <- pas  = WN as'+   | WW{} <- pas  = WW as'+   | TI{} <- pas  = TI as'+--- | TS{} <- pas  = TS as'+   | TR{} <- pas  = TR as'+   | TN{} <- pas  = TN as'+   | TW{} <- pas  = TW as'+   | otherwise  = error $ "getPatNodeAttrs: unexpected PatNode: " ++ show pas++  setPatNodePingParentTID :: ThreadId -> PatNode -> PatNode+  setPatNodePingParentTID tid pn = pn'+   where pn' = let as' = (getPatNodeAttrs pn) { pingParentTID = Just tid }+               in setPatNodeAttrs pn as'++  showPerm :: Maybe [Int] -> String+  showPerm Nothing = ""+  showPerm (Just lst) = showPerm' lst+  showPerm' [] = ""+  showPerm' (i:is) = (chr (i + ord 'a')) : showPerm' is++  -- Refer to http://stackoverflow.com/questions/12658443/how-to-decorate-a-tree-in-haskell/12658639 (among other SO questions) for good info and options.+  -- I've opted to remain H98 here, folloiwng Luis Casillas' answer.+  setPatternPatNodeUniqueIDs :: Int -> Pattern -> Pattern+  setPatternPatNodeUniqueIDs n pat+#if USE_POST_ORDER_IDS+   = ST.evalState (mapRoseM step pat) n+#else+   = ST.evalState (mapRoseM' step pat) n+#endif+   where+#if 1+    step :: PatNode -> ST.State Int PatNode+    step pn = do tag <- postIncrement+                 let as = getPatNodeAttrs pn+                 let as' = as { uniqueID = tag }+                 let pn' = setPatNodeAttrs pn as'+                 return pn'+#else+    step :: Pattern -> ST.State Int Pattern+    step p = do tag <- postIncrement+                let Node pn cs = p+                let p' = Node (pn { uniqueID = tag }) cs+                return p'+--              return (p, tag)+#endif++#if 1++-- This is from Luis Casillas' answer.++#if 0+  -- This function is not part of the solution, but it will help you+  -- understand mapRoseM below.+  mapRose :: (a -> b) -> Rose a -> Rose b+  mapRose fn (Node a subtrees) =+      let subtrees' = map (mapRose fn) subtrees+          a' = fn a+       in Node a' subtrees'++  -- Normally you'd write that function like this:+  mapRose' fn (Node a subtrees) = Node (fn a) $ map (mapRose' fn) subtrees+#endif++  -- But I wrote it out the long way to bring out the similarity to the+  -- following, which extracts the structure of the tagStep definition from+  -- the first solution above.+  mapRoseM :: Monad m => (a -> m b) -> Rose a -> m (Rose b)+  mapRoseM action (Node a subtrees) =+      do subtrees' <- mapM (mapRoseM action) subtrees+         a' <- action a+         return $ Node a' subtrees'++  -- That whole business with getting the state and putting the successor+  -- in as the replacement can be abstracted out.  This action is like a+  -- post-increment operator.+  postIncrement :: Enum s => ST.State s s+  postIncrement = do val <- ST.get+                     ST.put (succ val)+                     return val++#if 0+  -- Now tag can be easily written in terms of those.+  tag init tree = evalState (mapRoseM step tree) init+      where step a = do tag <- postIncrement+                        return (a, tag)+#endif++  -- You can make mapRoseM process the local value+  -- before the subtrees if you want:+  mapRoseM' action (Node a subtrees) =+      do a' <- action a+         subtrees' <- mapM (mapRoseM' action) subtrees+         return $ Node a' subtrees'++#if 0+  -- And using Control.Monad you can turn this into a one-liner:+  mapRoseM action (Node a subtrees) =+      -- Apply the Rose constructor to the results of the two actions+      liftM2 Node (action a) (mapM (mapRoseM action) subtrees)++  -- Or in children-first order:+  mapRoseM' action (Node a subtrees) =+      liftM2 (flip Node ) (mapM (mapRoseM action) subtrees) (action a)+#endif++#endif++-------------------------------------------------------------------------------++  -- XXX Is there any particular reason these fields should be marked strict?++  -- | Only 'WR' and 'TR' allow for explicit recursion.+  --+  -- All other 'PatNode' values are in leaf position when they occur.+  --+  -- Concrete syntax for @W*@ and @T*@ nodes are identical. A @T*@ node+  -- is simply a @W*@ node bearing a type constraint attribute.+  -- Please refer to the __Grammar__ further down this page for more details,+  -- and links to even more information.+  --+  -- /Notes:/+  --+  -- /I've kept the @T*@ types broken out as separate constructors, although they could be handled as special cases of @W*@ types in a way analogous to 'doSpark' ('PatNodeAttrs').  These were not \"absorbed\" because the semantics seems icky, and it's still not clear which @W*@ types even make sense with a type constraint.../+  --+  -- /I tried parametrising this, but it messed up my Show instance and seemed to be pulling me away from Haskell 98, so reverted.  It looks a bit ugly in the Haddock unfortunately, with the redundant column of @PatNodeAttrs@. The @T*@ nodes will be absorbed by 'PatNodeAttrs' in version 0.7, and it won't look so bad./+  data PatNode+       =++-- PatNodeAttrs was strict, but changed it b/c had problems using TN{}+-- form in some places (though not, apparantly, in all places)...+         WI !PatNodeAttrs  -- ^ (/__I__nsulate/, __.__ ) &#8195; Don't even unwrap the constructor of this node.+       | WR !PatNodeAttrs  -- ^ (/__R__ecurse/, __(__...__)__ ) &#8195; Continue pattern matching descendants, provided that arity is compatible (else the match fails).  Interior nodes of a pattern are always @WR@, /i.e./ @WR@ is the only @PatNode@ offering explicit recursion.  The rest (@?S@, @?N@, and @?W@) are implicitly recursive, but control is only as powerful as "NFDataN".+       | WS !PatNodeAttrs  -- ^ (/__S__top/, __!__ ) &#8195; Stop recursing (nothing more forced down this branch). This is equivalent to 'WN' at a 'depth' of 1. /'WS' is somewhat vestigial, and may be removed in 0.7./+       | WN !PatNodeAttrs  -- ^ (/__N__ (depth)/, __*__n ) &#8195; @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataN.html#t:NFDataN rnfn> n@ the branch under this node.+#if USE_WW_DEEPSEQ+       | WW !PatNodeAttrs  -- ^ (/__W__/ild, __*__ ) &#8195; Fully force (<http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData rnf>) the whole branch under this node. /Note that this is/ not /achievable as a limiting case of 'WN', so the existence of 'WW' is formally justifiable in a way that 'WS' is not. Having said that, for all practical purposes, a 'WN' with 'depth' @= maxBound::Int@ could be used for 'WW'.../+#endif+{--} -- XXX It's still unclear whether TI should allow subpatterns;+-- the alternative is for TI, when type doesn't match, to behave+-- as "." (no subpatterns); but since I say "otherwise behave as TR",+-- and TR says "continue pattern matching descendants", this seems to+-- say that subpatterns should be permitted.  Certainly it's no problem+-- to permit subpatterns in this case, but WI should still ignore+-- subpatterns since it will always be # regardless of node type.+-- (Subpatterns ought to be "safely redundant" in this case, but whether+-- they are depends on implementation and needs to be tested if allow+-- WI subpatterns to survive past the parser/compiler!)+--   And this all applies to TW and TN too, right? Yes.+-- It seems clear that TI, TW and TN should all allow subpatterns.+-- And that WI, WW and WN should elide them and issue a warning.+--   But, none of my present woes seem to be connected with this...+-- Nonetheless, it's important to pin down the semantics.+-- XXX Jan. '15: Soon these T* nodes will disappear, and the corresponding+-- PatNodeAttrs attributes will be used, as did for the P* (now doSpark) nodes.+       | TI !PatNodeAttrs  -- ^ Don't even unwrap the constructor of this node, if it's type is in the list; otherwise behave as 'WW'. (Note this behaviour is the complement of 'TW' behaviour.)+       | TR !PatNodeAttrs  -- ^ Match any of the types in the list (and continue pattern matching descendants); behave as 'WI' for nodes of type not in the list.+---    | TS !PatNodeAttrs  -- (never existed)+       | TN !PatNodeAttrs  -- ^ @<http://hackage.haskell.org/package/deepseq-bounded-0.6.0.0/docs/Control-DeepSeq-Bounded-NFDataN.html#t:NFDataN rnfn> n@ the branch under this node, if the node type matches any of the types in the list; otherwise behave as 'WI'.+#if USE_WW_DEEPSEQ+       | TW !PatNodeAttrs  -- ^ Fully force (<http://hackage.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData rnf>) the whole branch under this node, if the node type matches any of the types in the list; otherwise behave as 'WI'. (Note this behaviour is the complement of 'TI' behaviour.)+#endif+       | XX                -- ^ Dummy node type reserved for internal use.++#if NFDATA_INSTANCE_PATTERN+#if DO_DERIVE_DATA_AND_TYPEABLE+       deriving ( Eq, Typeable, Data, GHC.Generic )+#elif DO_DERIVE_ONLY_TYPEABLE+       deriving ( Eq, Typeable, GHC.Generic )+#else+       deriving ( Eq, GHC.Generic )+#endif+#else+#if DO_DERIVE_DATA_AND_TYPEABLE+       deriving ( Eq, Typeable )  -- Data apparently not needed+#elif DO_DERIVE_ONLY_TYPEABLE+       deriving ( Eq, Typeable )+#else+       deriving ( Eq )+#endif+#endif++  isWI WI{} = True ; isWI _ = False+  isWR WR{} = True ; isWR _ = False+  isWS WS{} = True ; isWS _ = False+  isWN WN{} = True ; isWN _ = False+#if USE_WW_DEEPSEQ+  isWW WW{} = True ; isWW _ = False+#endif+  isTI TI{} = True ; isTI _ = False+  isTR TR{} = True ; isTR _ = False+  isTN TN{} = True ; isTN _ = False+#if USE_WW_DEEPSEQ+  isTW TW{} = True ; isTW _ = False+#endif++  instance Show PatNode where+#if SHOW_PAT_NODE_ATTRS++    show (WI as) = "WI " ++ show as+    show (WR as) = "WR " ++ show as+    show (WS as) = "WS " ++ show as+    show (WN as) = "WN " ++ show as+#if USE_WW_DEEPSEQ+    show (WW as) = "WW " ++ show as+#endif+    show (TI as) = "TI " ++ show as+    show (TR as) = "TR " ++ show as+    show (TN as) = "TN " ++ show as+#if USE_WW_DEEPSEQ+    show (TW as) = "TW " ++ show as+#endif++#else++    show pas+     | WI{} <- pas = s1++"WI"++s2+     | WR{} <- pas = s1++"WR"++s2+     | WS{} <- pas = s1++"WS"++s2+     | WN{} <- pas = s1++"WN"++s2'+#if USE_WW_DEEPSEQ+     | WW{} <- pas = s1++"WW"++s2+#endif+     | TI{} <- pas = s1++"TI"++s2''+     | TR{} <- pas = s1++"TR"++s2''+     | TN{} <- pas = s1++"TN"++s2'''+#if USE_WW_DEEPSEQ+     | TW{} <- pas = s1++"TW"++s2''+#endif+     where+      as = getPatNodeAttrs pas+      s1 =    ""+           ++ (if doDelay as then "@" ++ (show $ delayus as) else "")+#if USE_PAR_PATNODE+           ++ (if doSpark as then "=" else "")+#endif+#if USE_PSEQ_PATNODE+           ++ (if doPseq  as then ">" ++ (showPerm $ pseqPerm as) else "")+#endif+#if USE_TRACE_PATNODE+           ++ (if doTrace as then "+" else "")+#endif+#if USE_PING_PATNODE+           ++ (if doPing  as then "^" else "")+#endif+#if USE_DIE_PATNODE+           ++ (if doDie   as then "/" else "")+#endif+#if USE_TIMING_PATNODE+           ++ (if doTiming as then "%" else "")+#endif+      s2 = ""+      s2' = " " ++ show (depth as)+#if TYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR+      s2'' = " (" ++ intercalate " " (typeConstraints as) ++ ")"+#else+#if NEW_SEMICOLON_TYPE_LIST+      s2'' = " (" ++ intercalate ";" (typeConstraints as) ++ ")"+#else+      s2'' = " (" ++ intercalate ":" (typeConstraints as) ++ ")"+--    s2'' = " (" ++ intercalate ";" (typeConstraints as) ++ ")"+--    s2'' = " (" ++ intercalate ";" (map doubleBackslashes $ typeConstraints as) ++ ")"+#endif+#endif+      s2''' = s2' ++ s2''+#if 0+      doubleBackslashes :: String -> String+      doubleBackslashes ('\\':t) = '\\':'\\':doubleBackslashes t+      doubleBackslashes (h:t) = h:doubleBackslashes t+      doubleBackslashes [] = []+#endif++#endif++  showPatRaw :: Pattern -> String+  showPatRaw (Node pn cs) = showPatNodeRaw pn ++ "\n[" ++ intercalate "," (map showPatRaw cs) ++ "]"+  showPatNodeRaw :: PatNode -> String+  showPatNodeRaw (WI as) = "WI "++show as+  showPatNodeRaw (WR as) = "WR "++show as+  showPatNodeRaw (WS as) = "WS "++show as+  showPatNodeRaw (WN as) = "WN "++show as+#if USE_WW_DEEPSEQ+  showPatNodeRaw (WW as) = "WW "++show as+#endif+  showPatNodeRaw (TI as) = "TI "++show as+  showPatNodeRaw (TR as) = "TR "++show as+  showPatNodeRaw (TN as) = "TN "++show as+#if USE_WW_DEEPSEQ+  showPatNodeRaw (TW as) = "TW "++show as+#endif++#if NFDATA_INSTANCE_PATTERN+  instance NFData PatNode where rnf = DSG.genericRnf+#endif++-------------------------------------------------------------------------------++#if 0+  patternShapeOK :: Data a => Pattern -> a -> Bool+  patternShapeOK pat x = S.shapeOf pat == S.shapeOf x+#endif++-------------------------------------------------------------------------------++  -- Note that Ord is derived, so the order that the constructors+  -- are listed matters!  (This only affects GHC rules, SFAIK.)+  -- (This data type is here, to avoid cyclical imports which+  -- GHC pretty much is useless with.)+  --------+  -- On the one hand, we want to keep this lightweight -- it can in+  -- principle be a single bit (Insulate/Propagate), as originally planned!+  -- But the Spark thing was too useful; and Print and Error would+  -- also be useful.  But they're more orthogonal.+  --------+  -- Later: Went with PatNodeAttrs for Pattern, but for Seqable+  -- we really prefer to keep it swift and simple for a while yet.+#if 0+  type Spark = Bool+  type PrintPeriod = Int+  type ErrorMsg = String+  data SeqNode =+           Insulate Spark PrintPeriod+         | Conduct Spark PrintPeriod+         | Force Spark PrintPeriod+         | Error ErrorMsg+    deriving ( Eq, Ord )+#else+  -- Later: Maybe "Insulate" is too strong a word. If going to "Insulate",+  -- then "external demand" (like demand generated by natural program+  -- evaluation) should also be repulsed (probably throwing an Error).+  -- "Conduct" would then permit these external demands to propagate,+  -- but will not cause any additional forcing.+  -- Then "Propagate" (which we can call "Force" now?) would carry+  -- the artificial forcing demands.+  -- So yeah, pretty much the above scheme, but try to get it happening+  -- for natural demand.+  -- If we can print trace info for every node, we can trace natural demand.+  -- And use that info, dynamically, to configure the harness.  In a sense+  -- it seems silly to do that, since that's what the RTS is already doing,+  -- but it's an important special case. If the natural demand pattern+  -- is constant (over a window), then (within that window) we can+  -- safely manipulate the harness so long as its artificial forcing+  -- doesn't extend beyond those natural bounds.  Why would you want+  -- to do this? I'm not sure, but it has theoretical interest at least.+  -- Because, for one thing, you are no longer at risk of changing+  -- the semantics by introducing new bottoms.  And so if the demand+  -- pattern is BIG, we could use the seqharn to parallelise it etc?+  -- Just the natural demand that is...  I hope so. That's the ticket.+  data SeqNode =+           Insulate+---      | Conduct+         | Propagate  -- XXX if include Conduct, then rename Propagate to Force+#if USE_PAR_SEQABLE+         | Spark+#endif+-- These would break the Ord; and besides, they're sort of orthogonal+-- (as is Spark)+---      | Print Int+---      | Error String+    deriving ( Eq, Ord )+--  deriving ( Eq, Ord, Show )+#endif++-------------------------------------------------------------------------------+
+ src/Control/DeepSeq/Bounded/Pattern_old_grammar.hs view
@@ -0,0 +1,270 @@++-------------------------------------------------------------------------------++  {-  LANGUAGE CPP #-}++#define DO_TRACE 0++#define SHOW_PAT_NODE_ATTRS 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++-------------------------------------------------------------------------------++-- Good idea: Let * be followed by an integer N.+-- This shall have the semantics that, when that node+-- is matched in the pattern, instead of rnf it is forcen N'd.++-- There may be fusion possible (which is worth trying here+-- for practise, even if this lib is not used much):+--+--   forcep p1 . forcep p2 = forcep (unionPat [p1,p2])+--+-- This holds if pattern doesn't contain #, or any (type-)constrained+-- subpatterns -- the latter might work out, if exclude # from them too,+-- but I'm not sure.  With #, we lose even monotonicity, let alone+-- the above law.+--+-- For the above to hold, remember, the union must have exactly+-- the "forcing potential" of the LHS -- no more, no less.++-------------------------------------------------------------------------------++#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.Pattern_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+--++-------------------------------------------------------------------------------++#warning You are using the old pattern grammar (NEW_IMPROVED_PATTERN_GRAMMAR flag is False). This will be deprecated in version 0.7.++  module Control.DeepSeq.Bounded.Pattern_old_grammar+--- {-# DEPRECATED "Use Wobble instead" #-}+  where++-------------------------------------------------------------------------------++#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++  import Data.List ( intercalate )+  import Data.Char ( isDigit )+  import Data.Maybe ( isNothing, fromJust )+  import Data.Maybe ( isJust )++  import Debug.Trace ( trace )+#if USE_WW_DEEPSEQ+  -- 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 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++-------------------------------------------------------------------------------++  data Rose a = Node a [ Rose a ]+#if NFDATA_INSTANCE_PATTERN+#if DO_DERIVE_DATA_AND_TYPEABLE+   deriving (Show, Eq, GHC.Generic, Data, Typeable)+-- deriving (Show, Eq, Functor, GHC.Generic, Data, Typeable)+#elif DO_DERIVE_ONLY_TYPEABLE+   deriving (Show, Eq, GHC.Generic, Typeable)+#else+   deriving (Show, Eq, GHC.Generic)+#endif+#else+#if DO_DERIVE_DATA_AND_TYPEABLE+   deriving (Show, Eq, Data, Typeable)+#elif DO_DERIVE_ONLY_TYPEABLE+   deriving (Show, Eq, Typeable)+#else+   deriving (Show, Eq)+#endif+#endif+  type Pattern = Rose PatNode++  instance Functor Rose where+    fmap f (Node x chs) = Node (f x) (map (fmap f) chs)++#if NFDATA_INSTANCE_PATTERN+  instance NFData a => NFData (Rose a) where rnf = DSG.genericRnf+#endif++-------------------------------------------------------------------------------++  -- | Note that only 'WR', 'TR' and 'PR' allow for explicit recursion.+  -- The other 'PatNode's are in leaf position when they occur in a 'Pattern'.++  data PatNode+       =++         WR  -- ^ Continue pattern matching descendants.+       | WS  -- ^ Stop recursing (nothing more forced down this branch).+       | WN Int  -- ^ @'rnfn' n@ the branch under this node.+#if USE_WW_DEEPSEQ+       | WW  -- ^ Fully force ('rnf') the whole branch under this node.+#endif+       | WI  -- ^ Don't even unwrap the constructor of this node.+{--} -- XXX It's still unclear whether TI should allow subpatterns;+-- the alternative is for TI, when type doesn't match, to behave+-- as "." (no subpatterns); but since I say "otherwise behave as TR",+-- and TR says "continue pattern matching descendants", this seems to+-- say that subpatterns should be permitted.  Certainly it's no problem+-- to permit subpatterns in this case, but WI should still ignore+-- subpatterns since it will always be # regardless of node type.+-- (Subpatterns ought to be "safely redundant" in this case, but whether+-- they are depends on implementation and needs to be tested if allow+-- WI subpatterns to survive past the parser/compiler!)+--   And this all applies to TW and TN too, right? Yes.+-- It seems clear that TI, TW and TN should all allow subpatterns.+-- And that WI, WW and WN should elide them and issue a warning.+--   But, none of my present woes seem to be connected with this...+-- Nonetheless, it's important to pin down the semantics.+#if 1+       | TR [String]  -- ^ Match any of the types in the list (and continue pattern matching descendants); behave as 'WI' for nodes of type not in the list. (Note this behaviour is the complement of 'TI' behaviour.)+---    | TS [String]  -- ^ Same as 'TR' except no subpatterns present.+       | TN Int [String]  -- ^ @'rnfn' n@ the branch under this node, if the node type matches any of the types in the list.+#if USE_WW_DEEPSEQ+       | TW [String]  -- ^ Fully force ('rnf') the whole branch under this node, if the node type matches any of the types in the list; otherwise behave as 'WI'.+#endif+       | TI [String]  -- ^ Don't even unwrap the constructor of this node, if it's type is in the list; otherwise behave as 'WR'. (Note this behaviour is the complement of 'TR' behaviour.)+#else+       | TR [TypeRep]  -- ...+#endif+#if PARALLELISM_EXPERIMENT+       | PR  -- ^ Spark the pattern matching of this subtree.+       | PN Int  -- ^ Spark @'rnfn' n@ of this subtree.+#if USE_WW_DEEPSEQ+       | PW  -- ^ Spark the full forcing ('rnf') of this subtree.+#endif+#endif++#if NFDATA_INSTANCE_PATTERN+#if DO_DERIVE_DATA_AND_TYPEABLE+       deriving ( Show, Eq, Typeable, Data, GHC.Generic )+#elif DO_DERIVE_ONLY_TYPEABLE+       deriving ( Show, Eq, Typeable, GHC.Generic )+#else+       deriving ( Show, Eq, GHC.Generic )+#endif+#else+#if DO_DERIVE_DATA_AND_TYPEABLE+       deriving ( Show, Eq, Typeable )  -- Data apparently not needed+#elif DO_DERIVE_ONLY_TYPEABLE+       deriving ( Show, Eq, Typeable )+#else+       deriving ( Show, Eq )+#endif+#endif++#if NFDATA_INSTANCE_PATTERN+  instance NFData PatNode where rnf = DSG.genericRnf+#endif++-------------------------------------------------------------------------------++#if 0+  patternShapeOK :: Data a => Pattern -> a -> Bool+  patternShapeOK pat x = S.shapeOf pat == S.shapeOf x+#endif++-------------------------------------------------------------------------------++  -- Note that Ord is derived, so the order that the constructors+  -- are listed matters!  (This only affects GHC rules, SFAIK.)+  -- (This data type is here, to avoid cyclical imports which+  -- GHC pretty much is useless with.)+  --------+  -- On the one hand, we want to keep this lightweight -- it can in+  -- principle be a single bit (Insulate/Propagate), as originally planned!+  -- But the Spark thing was too useful; and Print and Error would+  -- also be useful.  But they're more orthogonal.+#if 0+  type Spark = Bool+  type PrintPeriod = Int+  type ErrorMsg = String+  data SeqNode =+           Insulate Spark PrintPeriod+         | Conduct Spark PrintPeriod+         | Force Spark PrintPeriod+         | Error ErrorMsg+    deriving ( Eq, Ord )+#else+  data SeqNode =+           Insulate+---      | Conduct+         | Propagate  -- XXX if include Conduct, then rename Propagate to Force+#if PARALLELISM_EXPERIMENT+         | Spark+#endif+-- These would break the Ord; and besides, they're sort of orthogonal+-- (as is Spark)+---      | Print Int+---      | Error String+    deriving ( Eq, Ord )+#endif++-------------------------------------------------------------------------------+
src/Control/DeepSeq/Bounded/Seqable.hs view
@@ -83,32 +83,35 @@  -- | -- Module      :  Control.DeepSeq.Bounded.Seqable--- Copyright   :  (c) 2014, Andrew G. Seniuk+-- Copyright   :  Andrew G. Seniuk 2014-2015 -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Andrew Seniuk <rasfar@gmail.com> -- Stability   :  provisional -- Portability :  GHC (uses SOP) ----- This module provides an overloaded function, 'seq_', for efficiently--- switching between @'forcen' 0@ and @'forcen' 2@.  This is useful for+-- This module provides generic functions 'rnf_', 'force_' and 'seq_',+-- for efficient switching between @n=0@ and @n=2@ in the corresponding+-- 'rnfn n', 'forcen n' and 'deepseqn n' (of 'NFDataN').  This is useful for -- connecting units of forcing (propagating demand).  It was motivated -- for use with auto-instrumentation, where 'seq_' can be injected -- at every node of the AST (refer to the <seqaid> project).--- Each node carries a couple bits of information, determining which--- depth (0 or 2) is in force, and whether to spark parallel evaluation+--+-- Each 'SeqNode' carries a couple bits of information, determining which+-- depth (0 or 2) is in effect, and whether to spark parallel evaluation -- when the depth is 2.  This state can be configured statically -- or dynamically.  ------------------------------------------------------------------------------- -  module Control.DeepSeq.Bounded.Seqable (+  module Control.DeepSeq.Bounded.Seqable+  (        rnf_     , force_     , seq_ -    , SeqNodeKind(..)  -- re-export+    , SeqNode(..)  -- re-export  -- Must await seqaid implementation: #if 0@@ -116,11 +119,12 @@ --  , initSeqableHarness #endif -  ) where+  )+  where  ------------------------------------------------------------------------------- -#if PARALLELISM_EXPERIMENT+#if USE_PAR_SEQABLE   import Control.Parallel ( par ) #endif @@ -133,10 +137,10 @@ --import Data.Data ( Data )  #if JUST_ALIAS_GSEQABLE && ! HASKELL98_FRAGMENT-  import Control.DeepSeq.Bounded.Generics.GSeqable+  import Control.DeepSeq.Bounded.Generic.GSeqable   import Generics.SOP ( Generic ) #else-  import Control.DeepSeq.Bounded.Pattern ( SeqNodeKind(..) )+  import Control.DeepSeq.Bounded.Pattern ( SeqNode(..) ) #endif  -------------------------------------------------------------------------------@@ -147,7 +151,7 @@ #if 0   -- Note that Ord is derived, so the order that the constructors   -- are listed matters!  (This only affects GHC rules, SFAIK.)-  data SeqNodeKind =+  data SeqNode =            Insulate          | Propagate          | Spark@@ -162,24 +166,24 @@  #if JUST_ALIAS_GSEQABLE && ! HASKELL98_FRAGMENT #if 1-  rnf_ :: forall a. Generic a => SeqNodeKind -> a -> ()+  rnf_ :: forall a. Generic a => SeqNode -> a -> ()   rnf_ = grnf_-  force_ :: forall a. Generic a => SeqNodeKind -> a -> a+  force_ :: forall a. Generic a => SeqNode -> a -> a   force_ = gforce_-  seq_ :: forall a b. Generic a => SeqNodeKind -> a -> b -> b+  seq_ :: forall a b. Generic a => SeqNode -> a -> b -> b   seq_ = gseq_ #else-  rnf_ = grnf_ :: forall a. Generic a => SeqNodeKind -> a -> ()-  force_ = gforce_ :: forall a. Generic a => SeqNodeKind -> a -> a-  seq_ = gseq_ :: forall a b. Generic a => SeqNodeKind -> a -> b -> b+  rnf_ = grnf_ :: forall a. Generic a => SeqNode -> a -> ()+  force_ = gforce_ :: forall a. Generic a => SeqNode -> a -> a+  seq_ = gseq_ :: forall a b. Generic a => SeqNode -> a -> b -> b #endif #else  ------------------------------------------------------------------------------- -  rnf_ :: NFDataN a => SeqNodeKind -> a -> ()+  rnf_ :: NFDataN a => SeqNode -> a -> ()   rnf_ Insulate     a  =                ()-#if PARALLELISM_EXPERIMENT+#if USE_PAR_SEQABLE   rnf_ Propagate    a  = rnfn 2 a `seq` ()   rnf_ {-Spark-}_   a  = rnfn 2 a `par` () #else@@ -188,9 +192,9 @@  ------------------------------------------------------------------------------- -  force_ :: NFDataN a => SeqNodeKind -> a -> a+  force_ :: NFDataN a => SeqNode -> a -> a   force_ Insulate     a  =                a-#if PARALLELISM_EXPERIMENT+#if USE_PAR_SEQABLE   force_ Propagate    a  = rnfn 2 a `seq` a   force_ {-Spark-}_   a  = rnfn 2 a `par` a #else@@ -199,9 +203,9 @@  ------------------------------------------------------------------------------- -  seq_ :: NFDataN a => SeqNodeKind -> a -> b -> b+  seq_ :: NFDataN a => SeqNode -> a -> b -> b   seq_ Insulate     a b  =                b-#if PARALLELISM_EXPERIMENT+#if USE_PAR_SEQABLE   seq_ Propagate    a b  = rnfn 2 a `seq` b   seq_ {-Spark-}_   a b  = rnfn 2 a `par` b #else
− test/Blah.hs 
@@ -1,2982 +0,0 @@------------------------------------------------------------------------------------- Disclaimer: I've not used HUnit yet. I'm using it only--- as a "hook" so can compile/test in less clock time...--- (I forget the details of how why.)------ Obviously, this should use proper HUnit eventually.--- And QuickCheck and SmallCheck, DEFINITELY!!!...--- This is a great case for those; and shape-syb no less.------ This file could be cleaned up a lot, but that's--- not quite a priority at the moment...------ The reason I shied away from making it real HUnit tests--- is probably related to the fancy exception throwing/catching--- and catching of all exceptions (including error), etc.--- Which was aggravated by the nature of this project and--- of its tests, which hit bottom as a matter of course...------ Yeah; and looking at examples of QuickCheck and SmallCheck,--- it's still not clear to me how to work bottoming-out--- into my tests.---   I guess I could catch the bottoms in my code, and return--- some reserved value to indicate that it occurred?...-----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-----------------------------------------------------------------------------------#define FOCUS_TEST 0-#define USE_TRACE 0------------------------------------------------------------------------------------- Later: This may work with some versions of GHC, but I'm quite--- sure I've seen it not work with some recent version...--- Unfortunately, this doesn't work -- all pragmas are processed,--- regardless of CPP (so CPP must run after).--- The fact the CPP itself can be set via a pragma complicates this.--- It could be made an exception, and the LANGUAGE CPP pragma could--- be parsed regardless of CPP context (as all pragmas currently are).--- As it is, we need separate source modules, and to switch at--- import statements (and in the .cabal file).--- THIS IS A BUG.--- So anyhow, this is only here as a reminder:----  #if ! HASKELL98_FRAGMENT----  {-# LANGUAGE ... #-}----  #endif-  {-# LANGUAGE DeriveGeneric #-}-  {-# LANGUAGE DeriveDataTypeable #-}  -- to make BottomedOut-  {-# LANGUAGE BangPatterns #-}--  {-# LANGUAGE Rank2Types #-}  -- for SYB (testing rnfpDyn and friends)-----------------------------------------------------------------------------------  -- SOP pragmas:--  -- Not necessarily needed to work with SOP, but I think it'll-  -- be helpful here [?] ...-  {-# LANGUAGE ScopedTypeVariables #-}-  {-  LANGUAGE AllowAmbiguousTypes #-}---- Actually, CPP doesn't work with Haskell (GHC) pragmas last I checked...-#if USE_SOP-  {-# LANGUAGE DataKinds #-}-  {-# LANGUAGE TypeFamilies #-}-  {-# LANGUAGE ConstraintKinds #-}-  {-# LANGUAGE TemplateHaskell #-}-#endif-----------------------------------------------------------------------------------  module Blah ( run_tests ) where-----------------------------------------------------------------------------------  import Bottom-  import Foo-  import FooG----import     Control.DeepSeq.Generics-  import Control.DeepSeq.Bounded---import Control.DeepSeq.Bounded hiding ( F )-  import Control.DeepSeq.Bounded.Generics--#if 0-  import GHC.Generics---import GHC.Generics ( Generic )-#endif--  import Data.Maybe--  import Control.Exception---import Control.Monad ( guard )-  import Control.Monad ( replicateM )-  import Control.Monad ( when )-  import Data.Typeable ( Typeable )-  import Data.Typeable ( typeOf )--  import Data.Data ( Data )--  import Data.Generics.Aliases ( mkQ, extQ, GenericQ )----import Util ( spoor )-  import Debug.Trace ( trace )-  import Control.DeepSeq--  import Data.Typeable ( Proxy(..) )--#if USE_SOP-  import Generics.SOP hiding ( Shape )-#endif--  import System.Random--  import System.IO.Unsafe ( unsafePerformIO )-----------------------------------------------------------------------------------  -- For convenience in GHCi interactive sessions:-  cp = compilePat-  ip = intersectPats-  isp = isSubPatOf--  -- For more compact test expressions:--- XXX Refer to Seqable.hs for comments about JUST_ALIAS_GSEQABLE.-#if 1-#if JUST_ALIAS_GSEQABLE-  fI :: forall a. Generic a => a -> a-  fI = force_ Insulate-  fP :: forall a. Generic a => a -> a-  fP = force_ Propagate-#else-  fI :: forall a. NFDataN a => a -> a-  fI = force_ Insulate-  fP :: forall a. NFDataN a => a -> a-  fP = force_ Propagate-#endif-#else-  fI = force_ Insulate-  fP = force_ Propagate-#endif--  gI :: forall a. Generic a => a -> a-  gI = gforce_ Insulate-  gP :: forall a. Generic a => a -> a-  gP = gforce_ Propagate-----------------------------------------------------------------------------------  run_tests = do--    putStr "\n"-    -- So can notice the start when scrollback, esp. in ghci reload/reruns.---  replicateM 50 $ putStrLn "################################################################################"-    putStrLn "\nTesting.\n"--#if ! FOCUS_TEST--#if 1---  let shp s = s ++ replicate (30 - length s) ' ' ++ show (compilePat s)-    let shp s = -         unsafePerformIO $ -         catch-          ( return $! force $ s ++ replicate (30 - length s) ' ' ++ show (compilePat s) )-          ( \e -> do let err = show (e :: ErrorCall)-                     return err )--    putStrLn "Pattern                       Compiles to"---  putStrLn $ shp ""  -- empty pattern syntax error-    putStrLn $ shp "*"  -- Node WW []---  putStrLn $ shp "@"  -- Node WS []  -- obsoleted (use "." w/o children)-    putStrLn $ shp "#"  -- Node I []  -- no parent to absorb (should be error)-    putStrLn $ shp "."  -- Node WS []---  putStrLn $ shp "**"  -- Node WS []  -- "disconnected pattern (not rooted)"---  putStrLn $ shp ".*"  -- Node WS []  -- "disconnected pattern (not rooted)"---  putStrLn $ shp "*."  -- Node WS []  -- "disconnected pattern (not rooted)"-    putStrLn $ shp ".{}"  -- Node WR []-    putStrLn $ shp ".{*}"  -- Node WR [Node WW []]-    putStrLn $ shp ".{**}"  -- Node WR [Node WW [],Node WW []]-    putStrLn $ shp ".{.*}"  -- Node WR [Node WS [],Node WW []]-    putStrLn $ shp ".{#.}"  -- Node WR [Node I [],Node WS []]-    putStrLn $ shp ".{#{#}}"  -- Node WR [Node I []] with warning-    putStrLn $ shp ".{.{#}}"  -- Node WR [Node WR [Node I []]]-    putStrLn $ shp ".{*#*#*#**#*#*}"  -- looks fine-    putStrLn $ shp ".{*#.{*#.{*#}*}*{#*}#*}"  -- warning about *{...}-    putStrLn $ shp ".{*#.{*#.{*#}*}*#*}"---  putStrLn $ shp ".{*#.{*#.{*#}*}{*}{#*}#*}"  -- }{ syntax error--- [old comment for that last:] NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil],NodeM WW [],NodeM WW [],Nil,NodeM WW []],Nil,NodeM WW []] -- was wrong but is fixed I think-    putStrLn $ shp ".{.*.{*23*}}"-#if PARALLELISM_EXPERIMENT-    putStrLn $ shp ".{.=*.{=*23*}}"-#endif-#endif--#endif--#if ! FOCUS_TEST--#if 1-    let test_patterns10 = [-           (4,  "")  -- syntax error-         , (4,  ".##")  -- syntax error (disconnected pattern)-         , (1,  ".{.##}")  -- fail-         , (5,  ".{.{}#{}#{}}")-         , (2,  "*")-         , (2,  ".{***}")-         , (1,  ".{###}")-         , (1,  ".{*##}")-         , (2,  ".{**#}")-         , (2,  ".{##*}")--           -- Remember, [a] is a recursive binary ctor app!...-           -- The next four tests give instance errors for [a], but if-           -- testing expTG_* (GNFDataP/grnfp) then it's no longer a list...-         , (13, ".{..{*#*}#}")-         , (13, ".{..{*###}#}")-         , (13, ".{..{*####}#}")-         , (23, ".{..{*####}.}")--         , (2,  ".{..{*#}*}")-         , (1,  ".{..{*#}#}")-         , (1,  ".{..{*.{#*}}#}")-         , (2,  ".{..{*.{*#}}#}")-         , (13, ".{..{.{..{#*}}}#}")  -- See above comment about [a] instance-         , (2,  ".{#.{..{..{#*}}}#}")--           -- (See Book, p.84.)-         , (1,  ".{..{..{#.{..}}}#}")-         , (1,  ".{..{..{#*}}#}")-         , (1,  ".{*.{*.{#*}}#}")-         , (2,  ".{##*}")-         , (2,  ".{*#*}")-         , (1,  ".:Tuple3{*.{*.{#*}}#}")  -- oops...-         , (1,  ".:(,,){*.{*.{#*}}#}")-         , (2,  ".:(,,){*.{*.{.*}}#}")-         , (1,  ".:Bool{***}")  -- XXX makes no sense (but works) -- oh well;-                                  -- this is an important point to note in-                                  -- docs/blog also...-         , (1,  "*:Bool")-         , (2,  "*:(,,)")-         , (2,  ".{*#.}")-         , (2,  ".{*#.:Bool}")  -- XXX this gives parse error on 2nd .-         , (2,  ".{*#.:Bool{}}")  -- XXX this gives no parse error; if it does what-                                  -- it says, it will only match a childless Bool node-         , (1,  ".{*#.:Int{}}")  -- still need to implement # when not in type-         , (1,  ".{*#.:(,){}}")  -- still need to implement # when not in type-         , (1,  ".{*#.:Int }")  -- still need to implement # when not in type-         , (1,  ".{*#.:Int'}")  -- still need to implement # when not in type-         , (1,  ".{*##:Bool}")-         , (2,  ".{*##:Int}")-         , (2,  ".{*##:(,)}")-         , (1,  ".{*##:Bool{}}")-         , (2,  ".{*##:Int{}}")-         , (2,  ".{*##:(,){}}")-         , (1,  ".{**2#}")-         , (2,  ".{**3#}")-         , (1,  ".{*#:G2{}#}")-         , (1,  ".{*#:Int{}#}")-         ]-    doit14 True test_patterns10---  doit10 True test_patterns10-#endif--#if USE_SOP---- Seems fine; it's not a good test as the # in the middle--- only forces one ctor when type doesn't match, and need--- to force one more level to hit an undefined.-#if 1-    let test_patterns11 = [-           (4,  "")  -- syntax error-#if 0-         , (4,  ".##")  -- syntax error (disconnected pattern)-         , (1,  ".{.##}")  -- fail-         , (5,  ".{.{}#{}#{}}")-         , (2,  "*")-         , (2,  ".{***}")-         , (1,  ".{###}")-         , (1,  ".{*##}")-         , (2,  ".{**#}")-         , (2,  ".{##*}")--           -- Remember, [a] is a recursive binary ctor app!...-           -- The next four tests give instance errors for [a], but if-           -- testing expTG_* (GNFDataP/grnfp) then it's no longer a list...-         , (13, ".{..{*#}#}")-         , (13, ".{..{*###}#}")-         , (13, ".{..{*####}#}")-         , (23, ".{..{*####}.}")--         , (2,  ".{..{*##}*}")-         , (1,  ".{..{*##}#}")-         , (1,  ".{..{*#*}#}")-         , (2,  ".{..{**#}#}")--           -- (See Book, p.84.)-         , (1,  ".{..{.#.}#}")-         , (1,  ".{..{.#*}#}")-         , (1,  ".{*.{*#*}#}")-         , (2,  ".{##*}")-         , (2,  ".{*#*}")-         , (1,  ".:Tuple3{*.{*#*}#}")  -- oops...-         , (1,  ".:(,,){*.{*#*}#}")-         , (2,  ".:(,,){*.{*.*}#}")-         , (1,  ".:Bool{***}")  -- XXX makes no sense (but works) -- oh well;-                                -- this is an important point to note in-                                -- docs/blog also...-         , (1,  "*:Bool")-         , (2,  "*:(,,)")-         , (2,  ".{*#.}")-         , (2,  ".{*#.:Bool}")  -- XXX this gives parse error on 2nd .-         , (2,  ".{*#.:Bool{}}")  -- XXX this gives no parse error; if it does what-                                  -- it says, it will only match a childless Bool node-         , (1,  ".{*#.:Int{}}")  -- still need to implement # when not in type-         , (1,  ".{*#.:(,){}}")  -- still need to implement # when not in type-         , (1,  ".{*#.:Int }")  -- still need to implement # when not in type-         , (1,  ".{*#.:Int'}")  -- still need to implement # when not in type-         , (1,  ".{*##:Bool}")-         , (2,  ".{*##:Int}")-         , (2,  ".{*##:(,)}")-         , (1,  ".{*##:Bool{}}")-         , (2,  ".{*##:Int{}}")-         , (2,  ".{*##:(,){}}")-         , (1,  ".{**0#}")-         , (1,  ".{**1#}")-         , (2,  ".{**2#}")-         , (2,  ".{**3#}")-#endif-         , (1,  ".{*#:G2{}#}")-         , (1,  ".{*#:Int{}#}")-         ]-    doit15 True test_patterns11-#endif--#endif--#if USE_SOP---- All fine last checked.-#if 1-    let test_patterns12 = [-#if 0-           (1, ".{.##}")-#else-#if 1-           (4, "..")--         , (2, "*")-         , (1, "*0")-         , (1, "*1")-         , (2, "*2")-         , (2, "*3")--#if 1--         , (1, ".{.#.}")-         , (2, ".{...}")--         , (1, "*:TG")  -- (misuse; TG is a type name, not the name of a ctor)-         , (1, "*:G1")-         , (2, "*:G2")-         , (1, "*:G1{..}")-         , (1, "*:G1{...}")-         , (2, "*:G2{..}")-         , (2, "*:G2{...}")--         -- the getter used makes the rest uninteresting (none touch bottom)-         , (1, "#:G1")-         , (1, "#:G2")-         , (1, "#:G1{..}")-         , (1, "#:G1{...}")---       , (6, "#:G1{...}")-         , (1, "#:G2{..}")-         , (1, "#:G2{...}")--         , (1, ".:G1{..}")-         , (1, ".:G1{...}")-         , (1, ".:G2{..}")-         , (2, ".:G2{...}")-#endif-#else-           (2, "#:G1{}")-         , (1, "#:G2{}")-         , (2, "#:Int{}")-         , (1, "*:G1")-         , (2, "*:G2")-         , (1, "*:G1{}")-         , (2, "*:G2{}")-         , (1, "*:Int{}")-         , (2, "*:G2{..}")-         , (2, "*:G2{...}")-         , (2, "*{..}")-         , (2, "*{....}")-         , (1, ".{..}")-         , (2, ".{...}")-         , (1, ".{....}")-#endif-#endif-         ]-    doit16 True test_patterns12-#endif--#endif--#if USE_SOP---- This should work, once the patterns are right for lists,--- but until I get non-list generic tests working I'm not--- going to struggle with this.-#if 0-    let test_patterns13 = [--- expTH_1 = H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False    (for ref.)--- expTH_4 = H2 1 [H1 2.3, H3, H4 (__, I3 __ (H1 4.5))] __       (in use)-           (4,  "")  -- syntax error-         , (1,  ".{..{..{..{.{#.{#.}}.}}}#}")-         , (2,  ".{..{..{..{.{..{#.}}.}}}#}")-         , (2,  ".{..{..{..{.{#.{..}}.}}}#}")-         , (2,  ".{..{..{..{.{#.{#.}}.}}}.}")-         , (1,  ".{..{.{.}.{..{.{#.{#.{.}}}.}}}#}")-         , (2,  ".{..{.{.}.{..{.{..{#.{.}}}.}}}#}")-         , (2,  ".{..{.{.}.{..{.{#.{..{.}}}.}}}#}")-         , (2,  ".{..{.{.}.{..{.{#.{#.{.}}}.}}}.}")-         , (2,  ".{..{.{.}.{..{.{#.{#..{.}}}.}}}.}")-         ]-    doit17 True test_patterns13-#endif--#if 1-    let test_patterns14 = [--- expTJ_1 = J2 ( 1, J4 ( J3, K3 K2 ( J1 4.5))) False     -- for ref.--- expTJ_2 = J2 ( 1, J4 ( J3, K3 __ ( J1 4.5))) False--- expTJ_3 = J2 ( 1, J4 ( __, K3 K2 ( J1 4.5))) False--- expTJ_4 = J2 ( 1, J4 ( __, K3 __ ( J1 4.5))) __        -- in use---           {  { {} {  { {}  {  {} { {  {} }}}}}}}--- XXX The tuples are ctors, I forgot...-           (4 ,  "")  -- syntax error-#if 0-         , (1 ,  ".")-         , (13,  ".{}")-         , (13,  ".{.}")-         , (2 ,  ".{..}")-         , (13,  ".{...}")-         , (13,  ".{....}")-         , (13,  ".{.....}")-#endif--- expTJ_1 = J2 ( 1, J4 ( J3, K3 K2 ( J1 4.5))) False     -- for ref.---                J2 { (,) { I J4 { (,) { J3 K3 { K2 { J1 { 4.5 } } } } } } False }---                .  {  .  { .  . {  .  { .  .  {  . { .  { .   } } } } } } . }-           -- this pattern also double-checked on paper-         , (2 ,  ".{.{..{.{..{..{.}}}}}.}")---       , (1 ,  ".{.{..{.{..{#.{.}}}}}#}")  -- blows (in partic. expTJ_2)-         , (1 ,  ".{.{..{.{#.{..{.}}}}}#}")  -- blows (in partic. expTJ_3)---       , (1 ,  ".{.{..{.{#.{#.{.}}}}}#}")  -- blows (in partic. expTJ_4)-#if 0-         , (1 ,  ".{.{..{#{##{##{#}}}}}#}")  -- = ".{.{..{#}}#}" (no blow)-         , (1 ,  ".{.{..{#{#.{#.{.}}}}}#}")  -- = ".{.{..{#}}#}" (no blow)-         , (1 ,  ".{.{..{#{..{#.{.}}}}}#}")  -- = ".{.{..{#}}#}" (no blow)-         , (1 ,  ".{.{..{.{..{#.{.}}}}}#}")  -- blows-         , (1 ,  ".{.{..{.{##{##{#}}}}}#}")  -- blows-         , (1 ,  ".{.{..{#}}#}")             -- confirming (no blow)-#endif-#if 0-         , (2 ,  ".{.{..{.{..{.{.{.}}}}}}.}")-         , (1 ,  ".{.{..{.{#.{#{.{.}}}}}}#}")-         , (1 ,  "#{#{##{#{##{#{#{#}}}}}}#}")-         , (1 ,  ".{#{##{#{##{#{#{#}}}}}}#}")-         , (1 ,  ".{.{##{#{##{#{#{#}}}}}}#}")-         , (1 ,  ".{.{..{#{##{#{#{#}}}}}}#}")-#endif-#if 0-         , (1,  ".{..{#.{#.{.}}}#}")-         , (2,  ".{..{..{..{.}}}.}")-         , (2,  "*")-         , (2,  ".{.*.}")-         , (2,  ".{***}")-#endif-         ]-    doit18 True test_patterns14-#endif--#if 1-    let test_patterns14b = [--- expTJ_5 = J2 ( 1, J4 ( __, K2 )) False-           (4 ,  "")  -- syntax error-         , (2 ,  ".{.{..{.{..}}}.}")-         , (1 ,  ".{.{..{.{#.}}}.}")-         , (1 ,  ".{.{..{#{..}}}.}")-         , (1 ,  ".{.{.#{.{..}}}.}")-         ]-    doit18b True test_patterns14b-#endif--#if 1-    let test_patterns14c = [--- expTJ_6 = J4 ( __, K2 ) False-           (4 ,  "")  -- syntax error-         , (2 ,  ".{.{..}}")-         , (1 ,  ".{.{#.}}")-         , (1 ,  ".{#{..}}")-         , (1 ,  "#{.{..}}")-         ]-    doit18c True test_patterns14c-#endif--#if 1-    let test_patterns14d = [--- expTJ_7 = ( __, K2 )-           (4 ,  "")  -- syntax error-         , (2 ,  ".{..}")-         , (1 ,  ".{#.}")-         , (1 ,  "#{..}")-         ]-    doit18d True test_patterns14d-#endif--#if 1-    let test_patterns14e = [--- expTJ_8 = __ :: TJ-           (4 ,  "")  -- syntax error-         , (2 ,  ".")-         , (1 ,  "#")-         ]-    doit18e True test_patterns14e-#endif--#if 1-    let test_patterns14f = [--- expTJ_8 = (K5 (__::TJ))-           (4 ,  "")  -- syntax error-         , (1 ,  ".")-         , (1 ,  ".{#}")-         , (2 ,  ".{.}")-         , (1 ,  "#")-         ]-    doit18f True test_patterns14f-#endif---- These work!-#define TRY_THIS 1-#if 1-    let test_patterns14g = [-#if TRY_THIS--- exp = K3 (__::TK) J3-#else--- exp = K3 K2 (__::TJ)-#endif-           (4 ,  "")  -- syntax error-         , (1 ,  ".")-#if TRY_THIS-         , (1 ,  ".{#.}")-         , (2 ,  ".{.#}")-#else-         , (2 ,  ".{#.}")-         , (1 ,  ".{.#}")-#endif-         , (2 ,  ".{..}")-         , (1 ,  "#")-         ]-    doit18g True test_patterns14g-#endif---- Okay last I checked.-#if 1-    let test_patterns15 = [--- expTL_1 = L1 5.6 (M1 True)--- expTL_2 = L1 5.6 (M1 __)--- expTL_3 = L1 5.6 __--- expTL_4 = L1 __ (M1 True)-           (4 ,  "")  -- syntax error-#if 0-#elif 1-         , (1 ,  "#")-         , (5 ,  "#{..}")-         , (1 ,  ".{..}")-         , (2 ,  ".{.{.}.}")-         , (1 ,  ".{.{#}.}")-#elif 0-         , (1 ,  "#")-         , (5 ,  "#{..}")-         , (2 ,  ".{..}")-         , (1 ,  ".{#.{.}}")-#elif 0-         , (1 ,  "#")-         , (5 ,  "#{..}")-         , (2 ,  ".{..}")-         , (2 ,  ".{..{.}}")-         , (2 ,  ".{..{#}}")-#elif 0-         , (1 ,  "#")-         , (5 ,  "#{..}")-         , (1 ,  ".{..}")-         , (2 ,  ".{..{.}}")-         , (1 ,  ".{..{#}}")-#endif-         ]-    doit19 True test_patterns15-#endif---- Good test case for the problem. No tuples; every step is generic.-#if 1-    let test_patterns16 = [--- expTK_1 = K3 K2 ( J1 4.5)     -- for ref.--- expTK_2 = K3 __ ( J1 4.5)---           {  {} { {  {} }}}--- XXX Don't forget tuples are ctors...-           (4 ,  "")  -- syntax error-#if 0-         , (2 ,  ".{..}")-         , (1 ,  ".{#.}")-         , (2 ,  ".{.#}")-         , (1 ,  ".{##}")-#else-         , (2 ,  ".{..{.}}")  -- ok-         , (1 ,  ".{##}")     -- X-         , (1 ,  ".{#.}")     -- X-         , (1 ,  ".{#.{#}}")  -- X-         , (1 ,  ".{#.{.}}")  -- X-         , (2 ,  ".{.#{.}}")  -- X  & this does give the # with subpat. warning.-         , (2 ,  ".{.#{#}}")  -- X  & why no warning about # with subpattern?-         , (1 ,  ".{##{#}}")  -- X  & why no warning about # with subpattern?-         , (1 ,  "#{##{#}}")  -- ok & why no warning about # with subpattern?-#endif-         ]-    doit20 True test_patterns16-#endif--#endif-------------------------------------------------#endif---- Later: Oh! Don't be silly -- it's all compile-time, and the--- size or shape of the list is irrelevant -- which rules--- will fire depends on THIS FILE'S SOURCE CODE (not it's--- data, including static values)!--- XXX Even with empty list, the same rule firings occur!...--- If comment out this block however, the rules do not fire!-#if 1-    -- Testing composition and union:-    let test_patterns11 = [-           (1, ".", ".")-         , (2, ".", "*")-         , (2, "*", ".")-         , (2, "*", "*")-         , (2, ".{...}", ".{*..}")-         , (2, ".{*..}", ".{..*}")-         , (2, ".{.*#}", ".{.#.}")-         ]-    doit11 True test_patterns11-#endif--#if ! FOCUS_TEST--#if 1-    -- Testing splicePats-    let test_patterns12 = [-           (1, ".", [], [(0,"*")])-         , (1, ".{}", [], [(0,"*")])-         , (1, ".", [0], [(0,"*")])-         , (1, ".{..}", [], [(0,"*")])-         , (1, ".{..}", [0], [(0,"*")])-         , (1, ".{..}", [2], [(0,"*")])-         , (1, ".{..}", [], [(0,"*"),(0,"#")])-         , (1, ".{..}", [], [(0,"*"),(1,"#")])-         , (1, ".{..}", [], [(1,"#"),(0,"*")])-         , (1, ".{..}", [], [(0,"*"),(2,"#")])-         , (1, ".{..}", [], [(2,"*"),(2,"#"),(2,"#")])-         , (1, ".{..}", [], [(-1,"*")])-         , (1, ".{..}", [], [(0,"*")])-         , (1, ".{..}", [], [(1,"*")])-         , (1, ".{..}", [], [(2,"*")])-         , (1, ".{..}", [], [(3,"*")])-         , (1, ".{..{..}.}", [1], [(0,"*")])-         , (1, ".{..{..}.}", [1], [(0,"*3"),(1,"#"),(2,"*")])-         , (1, ".{..{..}.}", [1,0], [(0,"*"),(0,"#")])-         , (1, ".{.{...}.{.{}.}.}", [1], [(0,"*"),(0,"#")])-         , (1, ".{.{...}.{.{}.}.}", [1,0], [(0,"*"),(0,"#")])-         , (1, ".{.{###}.{.{}#}#}", [1,0], [(0,"*"),(0,"#")])-         , (1, ".{.:(,,){###}.{.{}#}#}", [1,0], [(0,"*"),(0,"#")])-         ]-    doit12 True test_patterns12-#endif--#if 1-    -- Testing elidePats-    -- XXX There's a nice way to do this, by rewriting each test-    -- automatically (or via manual regex substitutions) so that-    -- the target is the result of the corresponding splicePats test.-    -- Unfortunately, the expected results are not encoded for-    -- the splicePats test, so oh well, for now at least, just-    -- build some fresh tests!-    let test_patterns12b = [-           (1, ".{.{..}..{.}}", [], [0])-         , (1, ".{.{..}..{.}}", [0], [0])-         , (1, ".{.{..}..{.}}", [1], [0])-         , (1, ".{.{..}..{.}}", [1], [1])-         ]-    doit12b True test_patterns12b-#endif--#endif--#if ! FOCUS_TEST--#if 1-    -- Testing erodePat-    -- XXX Note we toss the stdgen when done here...-    stdgen12c <- newStdGen---  let stdgen12c = mkStdGen seed-    let test_patterns12c = [-           (1, ".{.{..}..{.}}", [])  -- recursive test...-         ]---  stdgen12c <- doit12c True test_patterns12c-#if 0-    stdgen12c' <- doit12c True test_patterns12c stdgen12c-    stdgen12c'' <- doit12c True test_patterns12c stdgen12c'-    stdgen12c''' <- doit12c True test_patterns12c stdgen12c''-    return ()-#else-#if 1-    stdgen12c' <- doit12c True test_patterns12c stdgen12c 5-    return ()-#else-    doit12c True test_patterns12c stdgen12c-      >>= doit12c True test_patterns12c-      >>= doit12c True test_patterns12c-      >>= doit12c True test_patterns12c-      >>= doit12c True test_patterns12c-      >>= doit12c True test_patterns12c-      >>= doit12c True test_patterns12c-      >>= doit12c True test_patterns12c-      >>= doit12c True test_patterns12c-#endif-#endif-#endif--#endif--#if 1-    -- Testing anything else we can with a single function!-    -- (Getting sick of this cloning.)-    -- Functions are listed in (current) export order.-    -- Things still needing testing are >'d.-    -- Things tested but failing some tests have a *.-    -- -    -- XXX Wow does this ever look cleaner with "Pat" instead of "Pattern"!...-    -- Fortunately splicePats is already tested separately; the rest-    -- we need to test deal only in Pat args (or list of same), so-    -- we can pass a couple [Pat] to test13 along with an Int code-    -- to control delegation.-    --  1    unionPats        :: [ Pat ] -> Pat-    --  2    intersectPats    :: [ Pat ] -> Pat-    --  3    isSubPatOf      :: Pat -> Pat -> Bool---  --  4    unionPatssStr    :: [ String ] -> String-    --  5    emptyPat        :: Pat-    --  6    mkPat           :: forall d. Data d => d -> Pat-    --  7    growPat         :: forall d. Data d => Pat -> d -> Pat-    --  8    shrinkPat       :: Pat -> Pat-    --  9    liftPats         :: [ Pat ] -> Pat-    -- 10    splicePats       :: Pat -> [Int] -> [(Int, Pat)] -> Pat-    -- 11    isPath          :: Pat -> Bool-    -- 12    mkPatN          :: Int -> Pat -> Bool-    -- 13    elidePats        :: Pat -> Pat -> [Int] -> Pat-    -- 14    erodePat        :: StdGen -> [Int] -> Pat -> (Pat, StdGen)-    let test_patterns13 = [-           ( 1, [".{...}", ".{.#}"], "")-         , ( 2, [".{...}", ".{.#}"], "")-         , ( 3, [".", "."], "True")-         , ( 3, ["#", "#"], "True")-         , ( 3, ["*", "*"], "True")-         , ( 3, [".", ".{}"], "True")-         , ( 3, [".{}", "."], "False")-         , ( 3, [".{}", ".{.}"], "False")-         , ( 3, [".{.}", ".{.}"], "True")-         , ( 3, [".{.}", ".{..}"], "False")-         , ( 3, [".{.}", ".{.{.}}"], "True")-         , ( 3, [".{..}", ".{.#}"], "False")-         , ( 3, [".{.#}", ".{..}"], "True")-         , ( 3, [".{..}", ".{...}"], "False")-         , ( 3, [".{}", ".{...}"], "False")-         , ( 3, [".", ".{*.#}"], "True")-         , ( 3, ["#", ".{*.#}"], "True")-         , ( 3, ["*", ".{*.#}"], "False")-         , ( 3, ["*", ".{*}"], "False")-         , ( 3, ["*", ".{**}"], "False")-         , ( 4, [".{...}", ".{.#}"], "")-         , ( 5, [".{...}", ".{.#}"], "")-         , ( 6, [".{...}", ".{.#}"], "")-         -- matching against val = ([1,2,3::Int],(False,"foo"))-         -- mkPat val = ".{.{..{..{..}}}.{..{..{..{..}}}}}"-         , ( 7, [".{.{..{..}}.{..{..}}}"], "")-         , ( 7, [".{.{..{..{..}}}.{..{..{..}}}}"], "")-         , ( 7, [".{.{..{..{..}}}.{..{..{..{..}}}}}"], "")-         , ( 8, [".{.{..{..{..}}}.{..{..{..{..}}}}}"], "")-         , ( 8, [".{.{..{..{..}}}.{..{..{..}}}}"], "")-         , ( 8, [".{.{..{..}}.{..{..}}}"], "")-         , ( 8, [".{.{#.{..}}.{#.{*3.}}}"], "")-         , ( 8, [".{.{#.}.{#.}}"], "")-         , ( 8, [".{..}"], "")-         , ( 8, ["."], "")-         , ( 9, [".{...}", ".{.#}"], "")-         , (10, [".{...}", ".{.#}"], "")-         , (11, [".{...}", ".{.#}"], "")-         , (12, [".{...}", ".{.#}"], "")-    -- 12    mkPatN          :: Int -> Pat -> Bool-    -- 13    elidePats        :: Pat -> Pat -> [Int] -> Pat-    -- 14    erodePat        :: StdGen -> [Int] -> Pat -> (Pat, StdGen)-         ]-    putStrLn "==================================================="-    putStrLn "Testing miscellaneous PatAlg functions..."-    doit13 True test_patterns13-#endif--#if ! FOCUS_TEST--#if 1-    -- Testing fusion-    putStrLn "\nTesting fusion\n-fenable-rewrite-rules -O -ddump-rules -ddump-simpl-stats -ddump-rule-firings\n"-    let exp12 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-    let get12 (_,xs,_) = (xs!!2)-    putStrLn $ show $ get12 $ ( forcep ".:Bool" . forcep ".:Int" ) exp12-    putStrLn $ show $ get12 $ ( forcep ".:Bool" . forcep_ (compilePat ".:Int") ) exp12-    putStrLn $ show $ get12 $ ( forcep_ (compilePat ".:Bool") . forcep ".:Int" ) exp12-    putStrLn $ show $ get12 $ ( forcep_ (compilePat ".:Bool") . forcep_ (compilePat ".:Int") ) exp12-#endif--#if 1-    putStrLn "\n\-  expN_1 = [__] :: [Int]\n\-  expN_2 = [0,1,__,3] :: [Int]\n\-  expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)\n\-  expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)\n\-\n\-  getN_1 xs = show $ ()\n\---getN_1 xs = show $ head xs\n\---getN_2 xs = show $ (xs!!1)\n\-  getN_2 xs = show $ (xs!!3)\n\-  getN_3 (_,xs,_) = show $ (xs!!2)\n"-    doit5 1 0 1 "" >>= putStrLn-    doit6 1 0 1 "" >>= putStrLn-    doit7 1 0 1 "" >>= putStrLn-    doit8 1 0 1 "" >>= putStrLn-#if 0-    doit9 >>= putStrLn  -- XXX broken (whatever it is)-#endif-#endif--#if 1-    putStr hdline-    putStrLn "Testing generic GNFDataN (refer to Foo.hs for the defs).\n"-    putStr hline-#if 0-#if ! USE_SOP-    putStrLn $ show $ from expTE_1-    putStrLn $ show $ from $ F 23-    putStrLn $ show $ from $ Just 11  -- bad comparison: two constructors!-#endif---  putStrLn $ show $ from $ Just (undefined::Int)---  putStrLn $ show $ from expTE_2---  putStrLn $ show $ from expTE_3-    putStr "\n"-    putStrLn $ ""-           ++ "expBase7 = B2 (A1 True 4) (B1 True (A2 undefined))\n"-           ++ "expBase8 = B2 (A1 undefined 4) (B1 True (A2 undefined))\n"-           ++ "expBase9 = B2 (A1 undefined 4) (B1 undefined (A2 undefined))\n"-           ++ "...\n"-           ++ "getB_1 (B2 _ (B1 b _)) = b\n"-           ++ "getB_2 (B2 (A1 _ n) _) = n\n"-#endif-    s2 <- doit2 1 0 1 ""-    putStrLn s2-#if 0-    putStrLn $ ""-           ++ "expTB_15 = (A3 (B3 False undefined 5) False)\n"-           ++ "getA (A3 _ b) = show b\n"-    s3 <- doit3 1 1 1 ""-    putStrLn s3-#endif-#endif--#if 0-    s4 <- doit4 1 0 1 ""-    putStrLn s4-#endif--#if 0-    putStrLn $ ""-           ++ "expBase1 = ([True,False],3,Just \"fox\")         :: ([Bool],Int,Maybe String)\n"-           ++ "expBase2 = ([True,False],__,Just \"fox\")        :: ([Bool],Int,Maybe String)\n"-           ++ "expBase3 = ([True,__],3,Just \"fox\")            :: ([Bool],Int,Maybe String)\n"-           ++ "expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)\n"-           ++ "expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)\n"-           ++ "expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)\n"-           ++ "get1 ((x:_),_,_) = x           -- True\n"-           ++ "get2 (_,x,_) = x               -- 3\n"-           ++ "get3 (_,_,x) = fromJust x      -- \"fox\"\n"-           ++ "get4 (_,_,Just (x:_)) = x      -- 'f'\n"-    s1 <- doit1 1 1 1 ""-    putStrLn s1-#endif--#if USE_SOP--#if 1-    -- Testing rnfpDyn -- working-    putStrLn "\nTesting SOP rnfpDyn with SYB generic stop condition.\n"-#if 1-    let exp21 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-    let get21 (_,xs,_) = (xs!!2)-    let f21_a :: [Int] -> PatNode-        f21_a _ = WI-    let f21_b :: Bool -> PatNode-        f21_b _ = WI-    let fg21 :: GenericQ PatNode-        fg21 = mkQ WR f21_a `extQ` f21_b---  let fg21 = mkQ WR f21_a `extQ` f21_b :: forall a. Data a => a -> PatNode---  let fg21 = mkQ WR f21_a `extQ` f21_b :: GenericQ PatNode-    putStrLn $ show $ get21 $ forcepDyn fg21 exp21-#else-    let exp21 = (3.4, [5,__,7], False) :: (Float, [Int], Bool)-    let get21 (_,xs,_) = (xs!!2)-#if 0-#elif 1-    let f21 :: [Int] -> PatNode-        f21 _ = WI-    let fg21 :: GenericQ PatNode-        fg21 = mkQ WR f21-#elif 0-    let f21 :: (Float,[Int],Bool) -> PatNode-    -- Cannot do in SYB? We can't just "stop on any 3-tuple"; we need-    -- to give the types of the components of the tuple as well?---  let f21 :: (,,) a b c -> PatNode---  let f21 :: (,,) * * * -> PatNode---  let f21 :: (,,) -> PatNode---  let f21 :: (a,b,c) -> PatNode---  let f21 :: (Typeable a,Typeable b,Typeable c) => (a,b,c) -> PatNode---  let f21 :: (Data a,Typeable a,Data b,Typeable b,Data c,Typeable c) => (a,b,c) -> PatNode-        f21 _ = WI---      f21 (x,y,z) = WI-    let fg21 :: GenericQ PatNode-        fg21 = mkQ WR f21-#elif 0-    let f21 :: Int -> PatNode-        f21 x = WI---      f21 x = case x of { 5 -> WR ; _ -> WI }  -- "case x" forces x!---  let (f21::Int->PatNode) x = case x of { 5 -> WR ; _ -> WI }-    let fg21 :: GenericQ PatNode-        fg21 = mkQ WR f21-#endif-    putStrLn $ show $ get21 $ forcepDyn fg21 exp21-#endif-#endif--#if 1-    -- Testing rnfpDyn again -- not working...-    putStrLn "\nTesting SOP/SYB rnfpDyn again.\n"-#if 0-#elif 1-    let exp22 = [[[__]],[[__,6],[7]]] :: [[[Int]]]--- These three should be exactly equivalent (same core produced)?---  let get22 xs = (((xs!!1)!!1)!!0)---  let get22 [_,[[_,n],_]] = n-    let get22 (_:((_:n:_):_):_) = n-    let f22a :: Int -> PatNode-        f22a _ = trace "Noo-A" $ WI-    let f22b :: [Int] -> PatNode-        f22b _ = trace "Noo-B" $ WI-    let f22c :: [[Int]] -> PatNode-        f22c _ = trace "Noo-C" $ WI-    let f22d :: [[[Int]]] -> PatNode  -- goes boom-        f22d _ = trace "Noo-D" $ WI-    let fg22 :: GenericQ PatNode-        fg22 = mkQ WR id---                                                              -- blows---                                                 `extQ` f22d  -- blows-                                       `extQ` f22c `extQ` f22d  -- FINE---                         `extQ` f22b `extQ` f22c `extQ` f22d  -- FINE---             `extQ` f22a `extQ` f22b `extQ` f22c              -- blows---             `extQ` f22a `extQ` f22b `extQ` f22c `extQ` f22d  -- FINE-#elif 0-    let exp22 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]-    let get22 xs = (((xs!!1)!!2)!!0)-    let f22 :: Int -> PatNode        -- goes boom---  let f22 :: [Int] -> PatNode      -- goes boom---  let f22 :: [[Int]] -> PatNode    -- goes boom---  let f22 :: [[[Int]]] -> PatNode  -- goes boom-        f22 _ = trace "Noo-A" $ WI-    let fg22 :: GenericQ PatNode-        fg22 = mkQ WR f22-#else-    let exp22 = (3.4, [[[__]],[[__,6],__,[7]]], __) :: (Float, [[[Int]]], Bool)---  let exp22 = (3.4, [[__],[[__,6],__,[7]]], __) :: (Float, [[[Int]]], Bool)-    let get22 (_,xs,_) = (((xs!!1)!!2)!!0)-    let f22_a :: [[Int]] -> PatNode-        f22_a _ = WI-    let f22_b :: Bool -> PatNode-        f22_b _ = WI-    let fg22 :: GenericQ PatNode-        fg22 = mkQ WR f22_a `extQ` f22_b---  let fg22 = mkQ WR f22_a `extQ` f22_b :: forall a. Data a => a -> PatNode---  let fg22 = mkQ WR f22_a `extQ` f22_b :: GenericQ PatNode-#endif-    putStrLn $ show $ get22 $ forcepDyn fg22 exp22-#endif--#if 1--- XXX This isn't working yet.--- And it won't work naively either, b/c SOP is *shallow*...--- Note:--- *Foo> :m +Generics.SOP--- *Foo Generics.SOP> datatypeInfo (Proxy :: Proxy [[Int]])--- ADT "GHC.Types" "[]" (Constructor "[]" :* (Infix ":" RightAssociative 5 :* Nil))--- So, as done in GNFDataP, we need to pattern-match in tandem on this,--- through the *S and *P SOP recursion auxilliaries...--- XXX I came back to this -- getting type errors, could probably--- get rid of by adding extra functions (as per GNFDataP.hs code),--- but remember, this is supposed to be API-user code ... if it's--- going to be that painful to write, we have a problem...--- (Still, can probably write friendlier wrapper functions.)-    -- Testing rnfpDyn' with SOP generic stop condition-    putStrLn "\nTesting SOP rnfpDyn' with SOP generic stop condition.\n"-#if 0-#elif 1-    putStrLn $ doit23-#elif 0-    let exp23 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]-    let get23 xs = (((xs!!1)!!2)!!0)-    let fg23 :: forall a. (Generic a, HasDatatypeInfo a) => a -> PatNode-        fg23 d | cname == "[[Int]]"  = WI-               | otherwise           = WR-          where-#if 1-           ADT mname tname (Constructor cname :* _) = dti---         ADT mname tname (Constructor cname :* _) = dti :: DatatypeInfo (Code a)---         (mname,tname,cname) = case dti of ...---         ADT mname tname (Constructor cname :* (Infix ":" RightAssociative 5 :* Nil)) = dti-#endif-           dti = datatypeInfo proxy_a-           proxy_a = Proxy :: Proxy a-           xrep = from d-    putStrLn $ show $ get23 $ forcepDyn' fg23 exp23-#endif-#endif--#if 1--- Gave up on the fully-SOP one, at least for now, b/c--- it seems like it's hard to write (much uglier than SYB one),--- and then writing a friendly wrapper looks tough as well.--- But here is a 3rd alternative, hybrid SOP/Typeable which--- is even simpler from the user perspective, only less efficient.-    putStrLn "Testing SOP rnfpDyn'' with Typeable generic stop condition\n"-    let exp24 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]-    let get24 xs = (((xs!!1)!!2)!!0)-    let fg24 :: forall a. Typeable a => a -> PatNode-        fg24 d | t == "[[[Int]]]"  = WI-               | t == "[[Int]]"    = WI-               | otherwise         = WR-         where t = show $ typeOf d-    -- This is a simple alternative to the SOP/SYB hybrid.-    -- If efficiency isn't prime concern, this would appear to be-    -- even simpler ... the above looks much more lucid to me than-    -- the usual SYB way of mkQ/extQ; here, just define one normal-    -- function, and away you go...-    putStrLn $ show $ get24 $ forcepDyn'' fg24 exp24-#endif--#endif--#endif--#if ! FOCUS_TEST--#if 1-    putStrLn "\nTesting Seqable class (tuple with list):\n"-    let test_patterns24 = [-           (1,  1, (3.4, [5, __, 7], False))                        -- okay-         , (2,  2, fP (3.4, fP (5 : fP (__ : fP (7 : []))), __))    -- okay-         , (2,  3, fP (3.4, fP (5 : fI (__ : fP (7 : []))), __))    -- okay-         , (1,  4, fI (3.4, fP (5 : fI (__ : fP (7 : []))), __))    -- XXX-         , (1,  5, fI (3.4, fI (5 : fI (__ : fP (7 : []))), __))    -- okay-         , (2,  6, fI (3.4, fI (5 : fP (__ : fP (7 : []))), __))    -- okay-         , (1,  7, fI (3.4, fP (5 : fI (__ : fP (7 : []))), True))  -- XXX-         , (1,  8, fP (3.4, fI (5 : fI (__ : fP (7 : []))), True))  -- XXX-         , (1,  9, fP (3.4, fI (5 : fI (__ : fI (7 : []))), True))  -- XXX-         ] :: [(Int,Int,(Float,[Int],Bool))]-    doit24 True test_patterns24-#endif--#if 1-    putStrLn "\nTesting Seqable class (nested tuples):\n"-    let test_patterns25 = [-           (1,  1, (3.4, (__, 7), False))       -- okay-         , (1,  2, fI (3.4 ,fI (__, 7) ,__))    -- okay-         , (2,  3, fP (3.4 ,fP (__, 7) ,__))    -- XXX-         , (2,  4, fP (3.4 ,fI (__, 7) ,__))    -- XXX-         , (2,  5, fI (3.4 ,fP (__, 7) ,__))    -- XXX-         , (1,  6, fI (3.4 ,fI (__, 7) ,True))  -- okay-         , (2,  7, fP (3.4 ,fP (__, 7) ,True))  -- XXX-         , (1,  8, fP (3.4 ,fI (__, 7) ,True))  -- okay-         , (2,  9, fI (3.4 ,fP (__, 7) ,True))  -- XXX-         ] :: [(Int,Int,(Float,(Bool,Int),Bool))]-    doit25 True test_patterns25-#endif--#if USE_SOP--#if 1-    putStrLn "\nTesting generic Seqable (tuple with list):\n"-    let test_patterns26 = [-           (1,  1, (3.4, [5, __, 7], False))                        -- okay-         , (2,  2, gP (3.4, gP (5 : gP (__ : gP (7 : []))), __))    -- okay-         , (2,  3, gP (3.4, gP (5 : gI (__ : gP (7 : []))), __))    -- okay-         , (1,  4, gI (3.4, gP (5 : gI (__ : gP (7 : []))), __))    -- XXX-         , (1,  5, gI (3.4, gI (5 : gI (__ : gP (7 : []))), __))    -- okay-         , (2,  6, gI (3.4, gI (5 : gP (__ : gP (7 : []))), __))    -- okay-         , (1,  7, gI (3.4, gP (5 : gI (__ : gP (7 : []))), True))  -- XXX-         , (1,  8, gP (3.4, gI (5 : gI (__ : gP (7 : []))), True))  -- XXX-         , (1,  9, gP (3.4, gI (5 : gI (__ : gI (7 : []))), True))  -- XXX-         ] :: [(Int,Int,(Float,[Int],Bool))]-    doit26 True test_patterns26-#endif--#if 1-    putStrLn "\nTesting generic Seqable (expTJ_*):\n"--- expTJ_1 = J2 ( 1, J4 ( J3, K3 K2 ( J1 4.5))) False     -- for ref.--- expTJ_2 = J2 ( 1, J4 ( J3, K3 __ ( J1 4.5))) False--- expTJ_3 = J2 ( 1, J4 ( __, K3 K2 ( J1 4.5))) False--- expTJ_4 = J2 ( 1, J4 ( __, K3 __ ( J1 4.5))) __        -- in use-    let test_patterns27 = [-           (1,  1, gI (J2 (gI ( 1, gI (J4 (gI ( __, gI (K3 __ ( gI (J1 4.5)))))))) __))-         , (2,  2, gP (J2 (gP ( 1, gP (J4 (gP ( __, gP (K3 __ ( gP (J1 4.5)))))))) __))-         , (1,  3, gI (J2 (gP ( 1, gP (J4 (gI ( __, gI (K3 __ ( gP (J1 4.5)))))))) __))-         , (2,  4, gP (J2 (gP ( 1, gP (J4 (gI ( __, gI (K3 __ ( gP (J1 4.5)))))))) __))-         , (2,  5, gI (J2 (gP ( 1, gP (J4 (gP ( __, gI (K3 __ ( gP (J1 4.5)))))))) __))-         , (2,  6, gI (J2 (gP ( 1, gP (J4 (gI ( __, gP (K3 __ ( gP (J1 4.5)))))))) __))-         ] :: [(Int,Int,TJ)]-    doit27 True test_patterns27-    putStrLn "\n"-#endif--#endif--#endif-----------------------------------------------------------------------------------  hline :: String-  hline = "---------------------------------------------------\n"-  hdline :: String-  hdline = "===================================================\n"-----------------------------------------------------------------------------------  doit1 :: Int -> Int -> Int -> String -> IO String-  doit1 i j k acc-   -- this glitch (the exception that seemingly escapes my catch)-   -- happens just for these combos (and for all j):--- | i == 3 && k == 4  = doit1 (1+i) j k acc  -- trying to avoid a glitch...--- | i == 3 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...--- | i == 3 && j < 4 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...-   | k == 7  = return acc-   | j == 6  = doit1 1 1 (1+k) acc-   | i == 5  = doit1 1 (1+j) k acc-   | otherwise  = do-      fexp <- catch-               -- The semantics of the !'s here are not what they were,-               -- since forcing in some places. [?] But at least the-               -- first one seems definitely still needed...-               -- LATER: The second one is also needed, finally seen!-               -- (It is needed for a version of getE _ = "getee", only.)-               -- XXX I'm just not sure whether the second ! is better-               -- to leave in or leave out...-               ( return $! get $! forcen dep exp )-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)---    doit1 (1+i) j k $! force $ acc-      doit1 (1+i) j k $! acc---    doit1 (1+i) j k $ acc-        ++ "( get" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k ++ " )  "-        ++ fexp ++ "\n"-   where-    exp = case k of-            1 -> expBase1-            2 -> expBase2-            3 -> expBase3-            4 -> expBase4-            5 -> expBase5-            6 -> expBase6-    get = case i of-           1 -> get1-           2 -> get2---         3 -> unsafePerformIO . get3  -- yeesh!...---         3 -> get3-           3 -> get3 (i,j,k)-           4 -> get4-    dep = j--  -- XXX All this fuss to deal with the case that the-  -- entire argument m is undefined (or whatever is going-  -- for "undefined" at the moment...) -- but, none of-  -- the expBase[1-5] have this! ch.-  myFromJust :: Maybe a -> IO (Either () a)-  myFromJust m = do-                    putStrLn "Boo!"-                    catch-                      (myFromJust' m)-                      (\e -> do putStrLn $! show (e::BottomedOut)-                                putStrLn "HERE!"-                                return $! Left ())-  myFromJust' :: Maybe a -> IO (Either () a)-  myFromJust' Nothing = do---                         throw BottomedOut-                           return $! Left ()-  myFromJust' (Just x) = return $! Right x---myFromJust _ = throw BottomedOut------------------------------------  doit2 :: Int -> Int -> Int -> String -> IO String-  doit2 i j k acc--- | k == 2  = {- trace (show (i,j,k)) $ -} return acc--- | k == 7  = return acc-   | k == 27  = return acc--- | k == 21  = return acc--- | k == 5  = return acc--- | j == 15  = doit2 1 0 (1+k) acc-   | j == 11  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc--- | j == 8  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc--- | j == 3  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc--- | i == 3  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc-#else-   | i == 2  = doit2 1 (1+j) k acc--- | i == 3  = doit2 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )---             ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit2 (1+i) j k $! acc-        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expTB_" ++ show (k'-6) ++ " )  "---      ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expBase" ++ show k' ++ " )  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            7 -> expBase7-            8 -> expBase8-            9 -> expBase9-            10 -> expBase10-            11 -> expBase11-            12 -> expBase12-            13 -> expBase13-            14 -> expBase14-            15 -> expBase15-            16 -> expBase16-            17 -> expBase17-            18 -> expBase18-            19 -> expBase19-            20 -> expBase20-            21 -> expBase20  -- fudge it!!-            22 -> expBase22-            23 -> expBase23-            24 -> expBase24-            25 -> expBase25-            26 -> expBase26-            27 -> expBase27-            28 -> expBase28-            29 -> expBase29-            30 -> expBase30-            31 -> expBase31-            32 -> expBase32-    get = case i of-           1 -> if k' >= 27 then getB_3 else getB_1-           2 -> getB_2-    dep = j'-    j' = j---  j' = j+11---  k' = k+26-    k' = k+6--  doit3 :: Int -> Int -> Int -> String -> IO String-  doit3 i j k acc-   | k == 2  = return acc-   | j == 8  = {- trace (show (i,j,k)) $ -} doit3 1 1 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit3 1 (1+j) k acc-#else-   | i == 2  = doit3 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit3 (1+i) j k $! acc-        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k' ++ " )  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            21 -> expBase21-    get = case i of-           1 -> getA-    dep = j'-    i' = i-    j' = j-    k' = k+20--  doit4 :: Int -> Int -> Int -> String -> IO String-  doit4 i j k acc--- | k == 2  = return acc-   | k == 4  = return acc-   | j == 8  = {- trace (show (i,j,k)) $ -} doit4 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit4 1 (1+j) k acc-#else-   | i == 2  = doit4 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit4 (1+i) j k $! acc-        ++ "( getE $ forcen " ++ show dep ++ " expTE_" ++ show k' ++ " )  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            1 -> expTE_1-            2 -> expTE_2-            3 -> expTE_3-    get = case i of-           1 -> getE-    dep = j'-    i' = i-    j' = j-    k' = k-----------------------------------------------------------------------------------  doit5 :: Int -> Int -> Int -> String -> IO String-  doit5 i j k acc-   | k == 2  = return acc-   | j == 5  = {- trace (show (i,j,k)) $ -} doit5 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit5 1 (1+j) k acc-#else-   | i == 2  = doit5 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit5 (1+i) j k $! acc-        ++ "forcen " ++ show dep ++ " expN_" ++ show k' ++ " `seq` ()  =  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            1 -> expN_1-    get = case i of-           1 -> getN_1-    dep = j'-    i' = i-    j' = j-    k' = k-----------------------------------------------------------------------------------  doit6 :: Int -> Int -> Int -> String -> IO String-  doit6 i j k acc-   | k == 2  = return acc-   | j == 5  = {- trace (show (i,j,k)) $ -} doit6 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit6 1 (1+j) k acc-#else-   | i == 2  = doit6 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit6 (1+i) j k $! acc-        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            _ -> expN_2-    get = case i of-           _ -> getN_2-    dep = j'-    i' = i+1-    j' = j-    k' = k+1-----------------------------------------------------------------------------------  doit7 :: Int -> Int -> Int -> String -> IO String-  doit7 i j k acc-   | k == 2  = return acc-   | j == 5  = {- trace (show (i,j,k)) $ -} doit7 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit7 1 (1+j) k acc-#else-   | i == 2  = doit7 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit7 (1+i) j k $! acc-        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            _ -> expN_3-    get = case i of-           _ -> getN_3-    dep = j'-    i' = i+2-    j' = j-    k' = k+2-----------------------------------------------------------------------------------  doit8 :: Int -> Int -> Int -> String -> IO String-  doit8 i j k acc-   | k == 2  = return acc-   | j == 5  = {- trace (show (i,j,k)) $ -} doit8 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit8 1 (1+j) k acc-#else-   | i == 2  = doit8 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit8 (1+i) j k $! acc-        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            _ -> expN_4-    get = case i of-           _ -> getN_3-    dep = j'-    i' = i+2-    j' = j-    k' = k+3-----------------------------------------------------------------------------------#if 0--#if 0-  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-  patP_1 = Node (TR [typeOf ((__,__,__)::(Float, [Int], Bool))])-             [ Node (TR [typeOf (__::Bool)]) []---           [ Node (TR [typeOf (__::Float)]) []---           [ Node (NTR [typeOf (__::Bool)]) []---           [ Node (NTR [typeOf (__::Float)]) []---           , Node WS []-             , Node (TW [typeOf ([__]::[Int])]) []---           , Node (TR [typeOf ([__]::[Int])]) []---           , Node (TR [typeOf ([__]::[Int])]) [ Node WS [], Node WS [] ]  -- why not?-             , Node WW []---           , Node I []-             ]-  getP_1 (_,xs,_) = show $ (xs!!2)-#endif--  doit9 :: IO String-  doit9 = do-#if 0-    putStrLn "\-  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)\n\-  patP_1 = Node (T [typeOf ((__,__,__)::(Float, [Int], Bool))])\n\-             [ Node W []\n\-             , Node (T [typeOf ([__]::[Int])]) []\n\-             , Node I []\n\-             ]\n\-  getP_1 (_,xs,_) = show $ (xs!!2)\n"-    putStrLn "getP_1 $ forcep patP_1 expP_1"-#endif-    s <- catch-             ( return $! getP_1 $! forcep patP_1 expP_1 )---           ( return $! getP_2 $! forcep patP_2 expP_2 )---           ( return $! getP_3 $! forcep patP_3 expP_3 )-             -- ErrorCall if use __ = undefined-             -- BottomedOut if use __ = throw BottomedOut-             (\e -> do let err = show (e :: ErrorCall)---           (\e -> do let err = show (e :: BottomedOut)-                       return err)-    return s--#endif-----------------------------------------------------------------------------------  doit10 :: Bool -> [(Int,String)] -> IO ()-  doit10 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit10 b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "7 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit10: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-                let pat = compilePat patstr-                let get (_,xs,_) = show $ (xs!!2)-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"-                  putStrLn "get (_,xs,_) = show $ (xs!!2)"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit10 False t-----------------------------------------------------------------------------------  doit11 :: Bool -> [(Int,String,String)] -> IO ()-  doit11 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit11 b ((code,patstr1,patstr2):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  _ -> error $ "doit11: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-                let patstrU = showPat $ unionPats [compilePat patstr1, compilePat patstr2]-                let pat1 = compilePat patstr1-                let pat2 = compilePat patstr2-                let patU = unionPats [pat1,pat2]-                let get (_,xs,_) = show $ (xs!!2)-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"-                  putStrLn "get (_,xs,_) = show $ (xs!!2)"-                  putStrLn "? = get $ ( forcep patstr2 . forcep patstr1 ) exp"---                putStrLn "? = get $ ( forcep ( unionPatsStr [ patstr1, patstr2 ] ) ) exp"-                  putStrLn "? = get $! ( forcep_ ( unionPats [ pat1, pat2 ] ) ) exp"-                  putStrLn "(Results were more interesting with a previous semantics...)."-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr1                     = " ++ patstr1-                putStrLn $ "patstr2                     = " ++ patstr2-                putStrLn $ "patstrU                     = " ++ patstrU-                if code > 4-                then putStrLn $  "expected value              = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat patstr1  = " ++ showPat pat1-                putStrLn $ "showPat.compilePat patstr2  = " ++ showPat pat2-                putStrLn $ "showPat.compilePat patstrU  = " ++ showPat patU-                if code <= 4-                then putStrLn $  "expected value              = " ++ expect-                else return ()-                putStr "actual value                = "-                let s1 = get $! ( forcep patstr2 . forcep patstr1 ) exp-                putStrLn s1-                putStr "actual value                = "-                let s2 = get $! forcep patstrU exp-#if 1-                let s3 = s2-#else-                putStrLn s2-                let s3 = get $! forcep_ ( unionPats [ pat1, pat2 ] ) exp-#endif-                return $! s3-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit11 False t-----------------------------------------------------------------------------------  doit12 :: Bool -> [(Int,String,[Int],[(Int,String)])] -> IO ()---doit12 :: Bool -> [(Int,String,String,[(Int,String)])] -> IO ()-  doit12 _ [] = do-                   return ()-  doit12 b ((code,patstr1,path,isibs'):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  _ -> error $ "doit12: unexpected code " ++ show code-    s <- catch-           ( do-                let target = compilePat patstr1---              let path = compilePat patstr2-                let isibs = map (\ (x,y) -> (x,compilePat y)) isibs'-                if b-                then do-                  putStr hdline-                  putStrLn "Testing splicePats."-                  putStr hline-                else return ()-                putStrLn $ "target       " ++ patstr1-                putStrLn $ "path         " ++ show path---              putStrLn $ "path         " ++ patstr2-                putStrLn $ "isibs        " ++ show isibs'-                let s1 = force $ showPat $ splicePats target path isibs---              let s1 = showPat $! splicePats target path isibs---              let s1 = showPat $ splicePats target path isibs-                putStr "result       "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    if null t then return () else putStr hline-    doit12 False t-----------------------------------------------------------------------------------  doit12b :: Bool -> [(Int,String,[Int],[Int])] -> IO ()-  doit12b _ [] = do-                   return ()-  doit12b b ((code,patstr1,path,isibs'):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  _ -> error $ "doit12b: unexpected code " ++ show code-    s <- catch-           ( do-                let target = compilePat patstr1-                let isibs = isibs'-                if b-                then do-                  putStr hdline-                  putStrLn "Testing elidePats."-                  putStr hline-                else return ()-                putStrLn $ "target       " ++ patstr1-                putStrLn $ "path         " ++ show path-                putStrLn $ "isibs        " ++ show isibs'-                let s1 = force $ showPat $ elidePats target path isibs-                putStr "result       "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    if null t then return () else putStr hline-    doit12b False t-----------------------------------------------------------------------------------  -- This is the first recursive test [much later than "12" would suggest].-  doit12c :: Bool -> [(Int,String,[Int])] -> StdGen -> Int -> IO StdGen---doit12c :: Bool -> [(Int,String,[Int],Int)] -> StdGen -> IO StdGen---doit12c :: Bool -> [(Int,String,StdGen,[Int],Int)] -> IO StdGen---doit12c :: Bool -> [(Int,String,StdGen,[Int],Int)] -> IO ()-  doit12c _ [] g _ = do-                   return g---                 return ()-  doit12c b lst@((code,patstr1,path):t) g 0 = return g-  doit12c b lst@((code,patstr1,path):t) g nreps = do  -- but singleton expected?-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  _ -> error $ "doit12c: unexpected code " ++ show code-    (s, g') <- catch---  s <- catch-           ( do-                let target = compilePat patstr1-                if b-                then do-                  putStr hdline-                  putStrLn "Testing erodePat."-                  putStr hline-                else return ()-                putStrLn $ "target       " ++ patstr1-                putStrLn $ "stdgen       " ++ show g-                putStrLn $ "path         " ++ show path-                let (rslt, g') = erodePat g path target-                let s1 = force $ showPat $ rslt---              let s1 = force $ showPat $ erodePat g path target-                putStr "result       "-                return $! (s1, g')---              return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return (err, g))---                   return err)-    putStrLn s-    putStr hline-    doit12c False lst g' (-1+nreps)---  doit12c False t g' (-1+nreps)-----------------------------------------------------------------------------------  doit13 :: Bool -> [(Int,[String],String)] -> IO ()-  doit13 _ [] = do-                   putStr hline-                   return ()-  doit13 b ((code,patstrlst,expectstr):t) = do-    s <- catch-           ( do-                s1 <- case code of--- Where were they done already?--- Oh, in doit11 and doit12 above...-                       1 -> error $ hline ++ "unionPats test already done test13-1!"---                     4 -> error $ hline ++ "unionPatsStr test already done test13-4!"-                       10 -> error $ hline ++ "splicePats test already done test13-10!"-                       11 -> error $ hline ++ "isPath test already done test13-11!"-    --  1    unionPats        :: [ Pat ] -> Pat-    --  2  * intersectPats :: [ Pat ] -> Pat-    --  3  * isSubPatOf      :: Pat -> Pat -> Bool---  --  4    unionPatsStr     :: [ String ] -> String-    --  5  * emptyPat        :: Pat-    --  6  * mkPat           :: forall d. Data d => d -> Pat-    --  7  * growPat         :: forall d. Data d => Pat -> d -> Pat-    --  8  * shrinkPat       :: Pat -> Pat-    --  9  * liftPats         :: [ Pat ] -> Pat-    -- 10    splicePats       :: Pat -> Pat -> [(Int, Pat)] -> Pat-    -- 11    isPath          :: Pat -> Bool-                       2 -> do-                               let patA = patstrlst!!0-                               let patB = patstrlst!!1-                               putStr hline-                               putStrLn "Testing      intersectPats [patA, patB]"-                               putStrLn $ "patA         " ++ patA-                               putStrLn $ "patB         " ++ patB-                               putStr $ "result       "-                               let s1 = force $ showPat $ intersectPats [compilePat patA, compilePat patB]-                               return s1-                       3 -> do-                               let patA = patstrlst!!0-                               let patB = patstrlst!!1-                               putStr hline-                               putStrLn "Testing      isSubPatOf patA patB"-                               putStrLn $ "patA         " ++ patA-                               putStrLn $ "patB         " ++ patB-                               let s1 = force $ show $ isSubPatOf (compilePat patA) (compilePat patB)-                               if s1 /= expectstr-                               then do putStrLn $ "expect       " ++ expectstr-                                       putStr $ "result       "-                               else putStr $ "as expected  "-                               return s1-                       5 -> do-                               putStr hline-                               putStrLn "Testing      emptyPat"-                               putStr $ "result       "-                               let s1 = force $ showPat $ emptyPat-                               return s1-                       6 -> do-                               putStr hline-                               putStrLn "Testing      mkPat ([1,2,3],(False,\"foo\"))"-                               putStr $ "result       "-                               let s1 = force $ showPat $ mkPat ([1,2,3::Int],(False,"foo"))-                               return s1-                       7 -> do-                               let patA = patstrlst!!0-                               putStr hline-                               putStrLn "Testing      growPat patA ([1,2,3],(False,\"foo\"))"-                               putStrLn $ "patA         " ++ patA-                               putStr $ "result       "-                               let s1 = force $ showPat $ growPat (compilePat patA) ([1,2,3::Int],(False,"foo"))-                               return s1-                       8 -> do-                               let patA = patstrlst!!0-                               putStr hline-                               putStrLn "Testing      shrinkPat patA"-                               putStrLn $ "patA         " ++ patA-                               putStr $ "result       "-                               let s1 = force $ showPat $ shrinkPat (compilePat patA)-                               return s1-                       9 -> do-                               putStr hline-                               putStrLn "Testing      liftPats patstrlst"-                               putStrLn $ "patstrs      " ++ show patstrlst-                               putStr $ "result       "-                               let s1 = force $ showPat $ liftPats $ map compilePat patstrlst-                               return s1-    -- 12    mkPatN          :: Int -> Pat -> Bool-    -- 13    elidePats        :: Pat -> Pat -> [Int] -> Pat-    -- 14    erodePat        :: StdGen -> [Int] -> Pat -> (Pat, StdGen)-                       12 -> do-                               putStr hline-                               putStrLn "Testing      mkPatN 2 ([1,2,3],(False,\"foo\"))"-                               putStr $ "result       "-                               let s1 = force $ showPat $ mkPatN 2 ([1,2,3::Int],(False,"foo"))-                               return s1-                       _ -> error $ "doit13: unexpected code " ++ show code-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit13 False t-----------------------------------------------------------------------------------  doit14 :: Bool -> [(Int,String)] -> IO ()-  doit14 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit14 b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "7 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit14: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-                let pat = compilePat patstr-                let get (_,xs,_) = show $ (xs!!2)-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"-                  putStrLn "get (_,xs,_) = show $ (xs!!2)"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit14 False t-----------------------------------------------------------------------------------#if USE_SOP--  -- This is an adaptation of doit10 to user-defined datatypes,-  -- for testing GNFDataP, which is finally within reach thanks-  -- to SOP!-  doit15 :: Bool -> [(Int,String)] -> IO ()-  doit15 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit15 b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "7 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit15: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = expTG_5  -- ( G1, G2 5 __ 7, __ )---              let exp = expTG_4  -- ( G1, G2 5 6 7, __ )---              let exp = expTG_3  -- ( G1, G2 __ __ 7, __ )---              let exp = expTG_2  -- ( __, G2 __ __ 7, __ )---              let exp = expTG_1  -- ( G1, G2 5 6 7, True )---              let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-                let pat = compilePat patstr-                let get = getG---              let get (_,xs,_) = show $ (xs!!2)-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = (G1, G2 5 __ 7, __) :: (TG, TG, Bool)"-                  putStrLn "get (_,(G2 _ _ n),_) = n"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit15 False t-----------------------------------------------------------------------------------  doit16 :: Bool -> [(Int,String)] -> IO ()-  doit16 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit16 b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "7 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit16: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = expTG_6  -- G2 5 __ 7-                let pat = compilePat patstr-                let get = getG'-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = G2 5 __ 7 :: TG"-                  putStrLn "get (G2 _ _ n) = n"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit16 False t-----------------------------------------------------------------------------------  doit17 :: Bool -> [(Int,String)] -> IO ()-  doit17 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit17 b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "4.5"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "4.5 (but \"# with subpattern\" warning)"-                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "4.5 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit17: unexpected code " ++ show code-    s <- catch-           ( do---              let exp = expTH_1  -- H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False---              let exp = expTH_2  -- H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] False---              let exp = expTH_3  -- H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] __-                let exp = expTH_4  -- H2 1 [H1 2.3, H3, H4 (__, I3 __ (H1 4.5))] __-                let pat = compilePat patstr-                let get = getH-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] __ :: TH"---                putStrLn "exp = H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False :: TH"-                  putStrLn "get = (H2 _ [_, _, H4 (_, I3 _ (H1 f))] _) = show f"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit17 False t-----------------------------------------------------------------------------------  doit18 :: Bool -> [(Int,String)] -> IO ()-  doit18 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit18 b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "4.5"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "4.5 (but \"# with subpattern\" warning)"-                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "4.5 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit18: unexpected code " ++ show code-    s <- catch-           ( do---              let exp = expTJ_1  -- J2 (1, J4 (J3, K3 K2 (J1 4.5))) False---              let exp = expTJ_2  -- J2 (1, J4 (J3, K3 __ (J1 4.5))) False-                let exp = expTJ_3  -- J2 (1, J4 (__, K3 K2 (J1 4.5))) False---              let exp = expTJ_4  -- J2 (1, J4 (__, K3 __ (J1 4.5))) __-                let pat = compilePat patstr-                let get = getJ-                if b-                then do-                  putStrLn "==================================================="---                putStrLn "exp = J2 (1, J4 (J3, K3 K2 (J1 4.5))) False"-                  putStrLn "exp = J2 (1, J4 (J3, K3 __ (J1 4.5))) False"---                putStrLn "exp = J2 (1, J4 (__, K3 K2 (J1 4.5))) False"---                putStrLn "exp = J2 (1, J4 (__, K3 __ (J1 4.5))) __"-                  putStrLn "get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit18 False t-----------------------------------------------------------------------------------  doit18b :: Bool -> [(Int,String)] -> IO ()-  doit18b _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit18b b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "1"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "1 (but \"# with subpattern\" warning)"-                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "1 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit18b: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = expTJ_5  -- J2 (1, J4 (__, K2)) False-                let pat = compilePat patstr-                let get = getJ'-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = J2 (1, J4 (__, K2)) False"-                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."---                putStrLn "get (J2 (n, J4 (_, K2)) False) = show n"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit18b False t-----------------------------------------------------------------------------------  doit18c :: Bool -> [(Int,String)] -> IO ()-  doit18c _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit18c b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "1"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "1 (but \"# with subpattern\" warning)"-                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "1 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit18c: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = expTJ_6  -- J4 (__, K2)-                let pat = compilePat patstr-                let get = getJ6-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = J4 (__, K2)"-                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."---                putStrLn "get (J4 (_, K2)) = show n"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit18c False t-----------------------------------------------------------------------------------  doit18d :: Bool -> [(Int,String)] -> IO ()-  doit18d _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit18d b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "1"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "1 (but \"# with subpattern\" warning)"-                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "1 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit18d: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = expTJ_7  -- (__, K2)-                let pat = compilePat patstr-                let get = getJ7-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = (__, K2)"-                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit18d False t-----------------------------------------------------------------------------------  doit18e :: Bool -> [(Int,String)] -> IO ()-  doit18e _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit18e b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "1"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "1 (but \"# with subpattern\" warning)"-                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "1 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit18e: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = expTJ_8  -- __ :: TJ-                let pat = compilePat patstr-                let get = getJ8-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = __ :: TJ"-                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit18e False t-----------------------------------------------------------------------------------  doit18f :: Bool -> [(Int,String)] -> IO ()-  doit18f _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit18f b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "okay"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "okay (but \"# with subpattern\" warning)"-                  6 -> "okay (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "okay (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit18f: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = (K5 (__::TJ))-                let pat = compilePat patstr-                let get _ = "okay"-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = (K5 (__::TJ))"-                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit18f False t------------------------------------------------------------------------------------  doit18g :: Bool -> [(Int,String)] -> IO ()-  doit18g _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit18g b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "okay"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "okay (but \"# with subpattern\" warning)"-                  6 -> "okay (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "okay (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit18g: unexpected code " ++ show code-    s <- catch-           ( do-#if TRY_THIS-                let exp = K3 (__::TK) J3-#else-                let exp = K3 K2 (__::TJ)-#endif-                let pat = compilePat patstr-                let get _ = "okay"-                if b-                then do-                  putStrLn "==================================================="-#if TRY_THIS-                  putStrLn "exp = K3 (__::TK) J3"-#else-                  putStrLn "exp = K3 K2 (__::TJ)"-#endif-                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit18g False t-----------------------------------------------------------------------------------  doit19 :: Bool -> [(Int,String)] -> IO ()-  doit19 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit19 b ((code,patstr):t) = do---  let expstr = "True"-    let expstr = "5.6"-    let expect = case code of-                  1 -> expstr-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> expstr ++ " (but \"# with subpattern\" warning)"-                  6 -> expstr ++ " (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> expstr ++ " (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit19: unexpected code " ++ show code-    s <- catch-           ( do---              let exp = expTL_1  -- L1 5.6 (M1 True)-                let exp = expTL_2  -- L1 5.6 (M1 __)---              let exp = expTL_3  -- L1 5.6 __---              let exp = expTL_4  -- L1 __ (M1 True)-                let pat = compilePat patstr-                let get = getL---              let get = getL'-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = L1 5.6 (M1 __)"---                putStrLn "exp = L1 5.6 __"---                putStrLn "exp = L1 __ (M1 True)"-                  putStrLn "get (L1 f (M1 _)) = show f"---                putStrLn "get (L1 f _) = show f"---                putStrLn "get (L1 _ (M1 b)) = show b"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit19 False t-----------------------------------------------------------------------------------  doit20 :: Bool -> [(Int,String)] -> IO ()-  doit20 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit20 b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "4.5"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "4.5 (but \"# with subpattern\" warning)"-                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "4.5 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit20: unexpected code " ++ show code-    s <- catch-           ( do---              let exp = expTK_1  -- K3 K2 (J1 4.5)-                let exp = expTK_2  -- K3 __ (J1 4.5)-                let pat = compilePat patstr-                let get = getK-                if b-                then do-                  putStrLn "==================================================="---                putStrLn "exp = K3 K2 (J1 4.5)"-                  putStrLn "exp = K3 __ (J1 4.5)"-                  putStrLn "get = (K3 _ (J1 f)) = show f"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  "expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit20 False t-----------------------------------------------------------------------------------  doit23 :: String-  doit23 = show $ fg23 exp23---doit23 = show $ get23 $ forcepDyn' fg23 exp23-   where-    exp23 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]-    get23 xs = (((xs!!1)!!2)!!0)-#if 0-    fg23 :: forall a. (Generic a, HasDatatypeInfo a) => a -> DatatypeInfo (Code a)-    fg23 d = dti-#else-    fg23 :: forall a. (Generic a, HasDatatypeInfo a, All2 Show (Code a), Typeable a) => a -> PatNode-#if 1-    fg23 d = doit23' dti proxy_a d (from d)-#else-    fg23 d | cname == "[[Int]]"  = WI-           | otherwise           = WR-#endif-#endif-     where---    ADT mname tname (Constructor cname :* _) = dti---    ADT mname tname (Constructor cname :* _) = dti :: DatatypeInfo (Code a)---    (mname,tname,cname) = case dti of ...---    ADT mname tname (Constructor cname :* (Infix ":" RightAssociative 5 :* Nil)) = dti-      dti = datatypeInfo proxy_a-      proxy_a = Proxy :: Proxy a-      xrep = from d--  doit23' :: forall a.-             (-               Generic a-             , HasDatatypeInfo a---           , All2 NFDataP (Code a)-             , All2 Show (Code a)-             , Typeable a---           , NFDataN a---           , NFDataP a-             ) =>-                     DatatypeInfo (Code a)-                  -> Proxy a-                  -> a-                  -> Rep a-                  -> PatNode-  doit23' (ADT     _ _ cs) proxy_a x xrep-   = doit23'' cs         proxy_a x xrep-  doit23' (Newtype _ _ c ) proxy_a x xrep-   = doit23'' (c :* Nil) proxy_a x xrep--  doit23'' :: forall a xss.-            (-              Generic a-            , HasDatatypeInfo a-            , All2 Show xss-            ) =>-                    NP ConstructorInfo xss-                 -> Proxy a-                 -> a-                 -> SOP I xss-                 -> PatNode-  doit23'' (m :* _) proxy_a x (SOP (Z xs))-   | tx == "[[Int]]"  = WI-   | otherwise        = WR-   where-    !_ = trace ("*** "++tx) $ ()-    tx | (Constructor n) <- m  = n-       | (Infix n _ _) <- m    = n-       | (Record n _) <- m     = n-  doit23'' (m :* ms) proxy_a x (SOP (S xss))-   = doit23'' ms proxy_a x (SOP xss)-  doit23'' _ _ _ _ = error "doit23'': unexpected case!!"-----------------------------------------------------------------------------------#endif--  doit24 :: Bool -> [(Int,Int,(Float,[Int],Bool))] -> IO ()-  doit24 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit24 b ((code,ident,exp):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "7 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit24: unexpected code " ++ show code-    s <- catch-           ( do---              let exp = force_ Propagate (force_ Propagate 3.4, force_ Propagate (force_ Propagate 5 : (force_ Propagate __ : (force_ Propagate 7 : force_ Propagate []))), force_ Propagate __) :: (Float, [Int], Bool)---              let seq_exp = mkSeqableHarness exp---              let pat = compilePat patstr-                let get (_,xs,_) = show $ (xs!!2)-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = <refer to test code>"-                  putStrLn "get (_,xs,_) = show $ (xs!!2)"-                  putStrLn "? = get $! exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"---              putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  show ident ++ " expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat---              putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  show ident ++ " expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr $ show ident ++ " actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit24 False t-----------------------------------------------------------------------------------  doit25 :: Bool -> [(Int,Int,(Float,(Bool,Int),Bool))] -> IO ()-  doit25 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit25 b ((code,ident,exp):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "7 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit25: unexpected code " ++ show code-    s <- catch-           ( do---              let exp = force_ Propagate (force_ Propagate 3.4, force_ Propagate (force_ Propagate 5 : (force_ Propagate __ : (force_ Propagate 7 : force_ Propagate []))), force_ Propagate __) :: (Float, [Int], Bool)---              let seq_exp = mkSeqableHarness exp---              let pat = compilePat patstr-                let get (_,(_,x),_) = show x-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = <refer to test code>"-                  putStrLn "get (_,(_,x),_) = show x"-                  putStrLn "? = get $! exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"---              putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  show ident ++ " expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat---              putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  show ident ++ " expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr $ show ident ++ " actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit25 False t-----------------------------------------------------------------------------------#if USE_SOP--  doit26 :: Bool -> [(Int,Int,(Float,[Int],Bool))] -> IO ()-  doit26 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit26 b ((code,ident,exp):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "7 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit26: unexpected code " ++ show code-    s <- catch-           ( do---              let exp = force_ Propagate (force_ Propagate 3.4, force_ Propagate (force_ Propagate 5 : (force_ Propagate __ : (force_ Propagate 7 : force_ Propagate []))), force_ Propagate __) :: (Float, [Int], Bool)---              let seq_exp = mkSeqableHarness exp---              let pat = compilePat patstr-                let get (_,xs,_) = show $ (xs!!2)-                if b-                then do-                  putStrLn "==================================================="-                  putStrLn "exp = <refer to test code>"-                  putStrLn "get (_,xs,_) = show $ (xs!!2)"-                  putStrLn "? = get $! exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"---              putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  show ident ++ " expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat---              putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  show ident ++ " expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr $ show ident ++ " actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit26 False t-----------------------------------------------------------------------------------  doit27 :: Bool -> [(Int,Int,TJ)] -> IO ()-  doit27 _ [] = do-                   putStrLn "--------------------------------------------------"-                   return ()-  doit27 b ((code,ident,exp):t) = do-    let expect = case code of-                  1 -> "4.5"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "4.5 (but \"# with subpattern\" warning)"-                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "4.5 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit27: unexpected code " ++ show code-    s <- catch-           ( do---              let exp = expTJ_1  -- J2 (1, J4 (J3, K3 K2 (J1 4.5))) False---              let exp = expTJ_2  -- J2 (1, J4 (J3, K3 __ (J1 4.5))) False---              let exp = expTJ_3  -- J2 (1, J4 (__, K3 K2 (J1 4.5))) False---              let exp = expTJ_4  -- J2 (1, J4 (__, K3 __ (J1 4.5))) __---              let pat = compilePat patstr-                let get = getJ-                if b-                then do-                  putStrLn "==================================================="---                putStrLn "exp = J2 (1, J4 (J3, K3 K2 (J1 4.5))) False"---                putStrLn "exp = J2 (1, J4 (J3, K3 __ (J1 4.5))) False"---                putStrLn "exp = J2 (1, J4 (__, K3 K2 (J1 4.5))) False"-                  putStrLn "exp = J2 (1, J4 (__, K3 __ (J1 4.5))) __"-                  putStrLn "get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f"-                  putStrLn "? = get exp"-                  putStrLn "==================================================="-                else do-                  putStrLn "---------------------------------------------------"---              putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                then putStrLn $  show ident ++ " expected value           = " ++ expect-                else return ()---              putStrLn $ "pat = " ++ show pat---              putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                then putStrLn $  show ident ++ " expected value           = " ++ expect-                else return ()-                s1 <- catch-                        ( return $! force $! get $! exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr $ show ident ++ " actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit27 False t-----------------------------------------------------------------------------------#endif-
− test/Blah98.hs 
@@ -1,1093 +0,0 @@------------------------------------------------------------------------------------- This is a pared-down version of Blah.hs, for testing--- deepseq-bounded when built with the HASKELL98_FRAGMENT--- flag set.  See Blah.hs for comments and other "flesh".-----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-----------------------------------------------------------------------------------#define FOCUS_TEST 0-#define USE_TRACE 0-----------------------------------------------------------------------------------  module Blah98 ( run_tests ) where-----------------------------------------------------------------------------------  import Foo--  import Control.DeepSeq.Bounded hiding ( F )--  import Data.Maybe--  import Control.Exception---import Control.Monad ( guard )-  import Control.Monad ( replicateM )-  import Control.Monad ( when )--  import Data.Typeable ( Typeable )-  import Data.Typeable ( typeOf )----import Util ( spoor )-  import Debug.Trace ( trace )-  import Control.DeepSeq--  import Data.Typeable ( Proxy(..) )--  import System.IO.Unsafe ( unsafePerformIO )-----------------------------------------------------------------------------------  -- For convenience in GHCi interactive sessions:-  cp = compilePat-  ip = intersectPats-  isp = isSubPatOf-----------------------------------------------------------------------------------  run_tests = do-    putStr "\n"-    -- So can notice the start when scrollback, esp. in ghci reload/reruns.---  replicateM 50 $ putStrLn "################################################################################"-    putStrLn "\nTesting.\n"--#if ! FOCUS_TEST--#if 1---  let shp s = s ++ replicate (30 - length s) ' ' ++ show (compilePat s)-    let shp s = -         unsafePerformIO $-         catch-          ( return $! force $ s ++ replicate (30 - length s) ' ' ++ show (compilePat s) )-          ( \e -> do let err = show (e :: ErrorCall)-                     return err )--    putStrLn "Pattern                       Compiles to"---  putStrLn $ shp ""  -- empty pattern syntax error-    putStrLn $ shp "*"  -- Node WW []---  putStrLn $ shp "@"  -- Node WS []  -- obsoleted (use "." w/o children)-    putStrLn $ shp "#"  -- Node I []  -- no parent to absorb (should be error)-    putStrLn $ shp "."  -- Node WS []---  putStrLn $ shp "**"  -- Node WS []  -- "disconnected pattern (not rooted)"---  putStrLn $ shp ".*"  -- Node WS []  -- "disconnected pattern (not rooted)"---  putStrLn $ shp "*."  -- Node WS []  -- "disconnected pattern (not rooted)"-    putStrLn $ shp ".{}"  -- Node WR []-    putStrLn $ shp ".{*}"  -- Node WR [Node WW []]-    putStrLn $ shp ".{**}"  -- Node WR [Node WW [],Node WW []]-    putStrLn $ shp ".{.*}"  -- Node WR [Node WS [],Node WW []]-    putStrLn $ shp ".{#.}"  -- Node WR [Node I [],Node WS []]-    putStrLn $ shp ".{#{#}}"  -- Node WR [Node I []] with warning-    putStrLn $ shp ".{.{#}}"  -- Node WR [Node WR [Node I []]]-    putStrLn $ shp ".{*#*#*#**#*#*}"  -- looks fine-    putStrLn $ shp ".{*#.{*#.{*#}*}*{#*}#*}"  -- warning about *{...}-    putStrLn $ shp ".{*#.{*#.{*#}*}*#*}"---  putStrLn $ shp ".{*#.{*#.{*#}*}{*}{#*}#*}"  -- }{ syntax error--- [old comment for that last:] NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil],NodeM WW [],NodeM WW [],Nil,NodeM WW []],Nil,NodeM WW []] -- was wrong but is fixed I think-    putStrLn $ shp ".{.*.{*23*}}"-#endif--#if 1-    let test_patterns10 = [-           (4,  "")  -- syntax error-         , (4,  ".##")  -- syntax error (disconnected pattern)-         , (1,  ".{.##}")  -- fail-         , (5,  ".{.{}#{}#{}}")-         , (2,  "*")-         , (2,  ".{***}")-         , (1,  ".{###}")-         , (1,  ".{*##}")-         , (2,  ".{**#}")-         , (2,  ".{##*}")--           -- Remember, [a] is a recursive binary ctor app!...-           -- The next four tests give instance errors for [a], but if-           -- testing expTG_* (GNFDataP/grnfp) then it's no longer a list...-         , (13, ".{..{*#*}#}")-         , (13, ".{..{*###}#}")-         , (13, ".{..{*####}#}")-         , (23, ".{..{*####}.}")--         , (2,  ".{..{*#}*}")-         , (1,  ".{..{*#}#}")-         , (1,  ".{..{*.{#*}}#}")-         , (2,  ".{..{*.{*#}}#}")-         , (13, ".{..{.{..{#*}}}#}")  -- See above comment about [a] instance-         , (2,  ".{#.{..{..{#*}}}#}")--           -- (See Book, p.84.)-         , (1,  ".{..{..{#.{..}}}#}")-         , (1,  ".{..{..{#*}}#}")-         , (1,  ".{*.{*.{#*}}#}")-         , (2,  ".{##*}")-         , (2,  ".{*#*}")-         , (1,  ".:Tuple3{*.{*.{#*}}#}")  -- oops...-         , (1,  ".:(,,){*.{*.{#*}}#}")-         , (2,  ".:(,,){*.{*.{.*}}#}")-         , (1,  ".:Bool{***}")  -- XXX makes no sense (but works) -- oh well;-                                  -- this is an important point to note in-                                  -- docs/blog also...-         , (1,  "*:Bool")-         , (2,  "*:(,,)")-         , (2,  ".{*#.}")-         , (2,  ".{*#.:Bool}")  -- XXX this gives parse error on 2nd .-         , (2,  ".{*#.:Bool{}}")  -- XXX this gives no parse error; if it does what-                                  -- it says, it will only match a childless Bool node-         , (1,  ".{*#.:Int{}}")  -- still need to implement # when not in type-         , (1,  ".{*#.:(,){}}")  -- still need to implement # when not in type-         , (1,  ".{*#.:Int }")  -- still need to implement # when not in type-         , (1,  ".{*#.:Int'}")  -- still need to implement # when not in type-         , (1,  ".{*##:Bool}")-         , (2,  ".{*##:Int}")-         , (2,  ".{*##:(,)}")-         , (1,  ".{*##:Bool{}}")-         , (2,  ".{*##:Int{}}")-         , (2,  ".{*##:(,){}}")-         , (1,  ".{**2#}")-         , (2,  ".{**3#}")-         , (1,  ".{*#:G2{}#}")-         , (1,  ".{*#:Int{}#}")-         ]-    doit14 True test_patterns10---  doit10 True test_patterns10-#endif--#endif--------------------------------------------------- Later: Oh! Don't be silly -- it's all compile-time, and the--- size or shape of the list is irrelevant -- which rules--- will fire depends on THIS FILE'S SOURCE CODE (not it's--- data, including static values)!--- XXX Even with empty list, the same rule firings occur!...--- If comment out this block however, the rules do not fire!-#if 1-    -- Testing composition and union:-    let test_patterns11 = [-           (1, ".", ".")-         , (2, ".", "*")-         , (2, "*", ".")-         , (2, "*", "*")-         , (2, ".{...}", ".{*..}")-         , (2, ".{*..}", ".{..*}")-         , (2, ".{.*#}", ".{.#.}")-         ]-    doit11 True test_patterns11-#endif--#if 1-    -- Testing splicePats-    let test_patterns12 = [-#if 1-           (1, ".", [], [(0,"*")])-         , (1, ".{}", [], [(0,"*")])-         , (1, ".", [0], [(0,"*")])-         , (1, ".{..}", [], [(0,"*")])-         , (1, ".{..}", [0], [(0,"*")])-         , (1, ".{..}", [2], [(0,"*")])-         , (1, ".{..}", [], [(0,"*"),(0,"#")])-         , (1, ".{..}", [], [(0,"*"),(1,"#")])-         , (1, ".{..}", [], [(1,"#"),(0,"*")])-         , (1, ".{..}", [], [(0,"*"),(2,"#")])-         , (1, ".{..}", [], [(2,"*"),(2,"#"),(2,"#")])-         , (1, ".{..}", [], [(-1,"*")])-         , (1, ".{..}", [], [(0,"*")])-         , (1, ".{..}", [], [(1,"*")])-         , (1, ".{..}", [], [(2,"*")])-         , (1, ".{..}", [], [(3,"*")])-         , (1, ".{..{..}.}", [1], [(0,"*")])-         , (1, ".{..{..}.}", [1], [(0,"*3"),(1,"#"),(2,"*")])-         , (1, ".{..{..}.}", [1,0], [(0,"*"),(0,"#")])-         , (1, ".{.{...}.{.{}.}.}", [1], [(0,"*"),(0,"#")])-         , (1, ".{.{...}.{.{}.}.}", [1,0], [(0,"*"),(0,"#")])-         , (1, ".{.{###}.{.{}#}#}", [1,0], [(0,"*"),(0,"#")])-         , (1, ".{.:(,,){###}.{.{}#}#}", [1,0], [(0,"*"),(0,"#")])-#else-           (1, ".", ".{}", [(0,"*")])-         , (1, ".{}", ".{}", [(0,"*")])-         , (1, ".", ".{.{}}", [(0,"*")])  -- added later, did uncover a bug! (irrefutable pattern failure)-         , (1, ".{..}", ".{}", [(0,"*")])-         , (1, ".{..}", ".{.{}}", [(0,"*")])-         , (1, ".{..}", ".{...{}}", [(0,"*")])-         , (1, ".{..}", ".{}", [(0,"*"),(0,"#")])-         , (1, ".{..}", ".{}", [(0,"*"),(1,"#")])-         , (1, ".{..}", ".{}", [(1,"#"),(0,"*")])-         , (1, ".{..}", ".{}", [(0,"*"),(2,"#")])-         , (1, ".{..}", ".{}", [(2,"*"),(2,"#"),(2,"#")])-         , (1, ".{..}", ".{}", [(-1,"*")])-         , (1, ".{..}", ".{}", [(0,"*")])-         , (1, ".{..}", ".{}", [(1,"*")])-         , (1, ".{..}", ".{}", [(2,"*")])-         , (1, ".{..}", ".{}", [(3,"*")])-         , (1, ".{..{..}.}", ".{..{}.}", [(0,"*")])-         , (1, ".{..{..}.}", ".{..{}.}", [(0,"*3"),(1,"#"),(2,"*")])-         , (1, ".{..{..}.}", ".{..{.{}.}.}", [(0,"*"),(0,"#")])-         , (1, ".{..{..}.}", ".{..{.{}}}", [(0,"*"),(0,"#")])-         , (1, ".{.{...}.{.{}.}.}", ".{..{}}", [(0,"*"),(0,"#")])-         , (1, ".{.{...}.{.{}.}.}", ".{..{.{}}}", [(0,"*"),(0,"#")])-         , (1, ".{.{###}.{.{}#}#}", ".{..{.{}}}", [(0,"*"),(0,"#")])-         , (1, ".{.:(,,){###}.{.{}#}#}", ".{..{.{}}}", [(0,"*"),(0,"#")])-#endif-         ]-    doit12 True test_patterns12-#endif--#if ! FOCUS_TEST--#if 1-    -- Testing anything else we can with a single function!-    -- (Getting sick of this cloning.)-    -- Functions are listed in (current) export order.-    -- Things still needing testing are >'d.-    -- Things tested but failing some tests have a *.-    -- -    -- XXX Wow does this ever look cleaner with "Pat" instead of "Pattern"!...-    -- Fortunately splicePats is already tested separately; the rest-    -- we need to test deal only in Pat args (or list of same), so-    -- we can pass a couple [Pat] to test13 along with an Int code-    -- to control delegation.-    --  1    unionPats       :: [ Pat ] -> Pat-    --  2    intersectPats   :: [ Pat ] -> Pat-    --  3    isSubPatOf      :: Pat -> Pat -> Bool---  --  4    unionPatsStr    :: [ String ] -> String-    --  5    emptyPat        :: Pat---  --  6    mkPat           :: forall d. Data d => d -> Pat---  --  7    growPat         :: forall d. Data d => Pat -> d -> Pat-    --  8    shrinkPat       :: Pat -> Pat-    --  9    liftPats        :: [ Pat ] -> Pat-    -- 10    splicePats      :: Pat -> Pat -> [(Int, Pat)] -> Pat-    -- 11    isPath          :: Pat -> Bool-    let test_patterns13 = [-           ( 1, [".{...}", ".{.#}"], "")-         , ( 2, [".{...}", ".{.#}"], "")-         , ( 3, [".", "."], "True")-         , ( 3, ["#", "#"], "True")-         , ( 3, ["*", "*"], "True")-         , ( 3, [".", ".{}"], "True")-         , ( 3, [".{}", "."], "False")-         , ( 3, [".{}", ".{.}"], "False")-         , ( 3, [".{.}", ".{.}"], "True")-         , ( 3, [".{.}", ".{..}"], "False")-         , ( 3, [".{.}", ".{.{.}}"], "True")-         , ( 3, [".{..}", ".{.#}"], "False")-         , ( 3, [".{.#}", ".{..}"], "True")-         , ( 3, [".{..}", ".{...}"], "False")-         , ( 3, [".{}", ".{...}"], "False")-         , ( 3, [".", ".{*.#}"], "True")-         , ( 3, ["#", ".{*.#}"], "True")-         , ( 3, ["*", ".{*.#}"], "False")-         , ( 3, ["*", ".{*}"], "False")-         , ( 3, ["*", ".{**}"], "False")-         , ( 4, [".{...}", ".{.#}"], "")-         , ( 5, [".{...}", ".{.#}"], "")-#if 0-         , ( 6, [".{...}", ".{.#}"], "")-         -- matching against val = ([1,2,3::Int],(False,"foo"))-         -- mkPat val = ".{.{..{..{..}}}.{..{..{..{..}}}}}"-#endif-#if 0-         , ( 7, [".{.{..{..}}.{..{..}}}"], "")-         , ( 7, [".{.{..{..{..}}}.{..{..{..}}}}"], "")-         , ( 7, [".{.{..{..{..}}}.{..{..{..{..}}}}}"], "")-#endif-         , ( 8, [".{.{..{..{..}}}.{..{..{..{..}}}}}"], "")-         , ( 8, [".{.{..{..{..}}}.{..{..{..}}}}"], "")-         , ( 8, [".{.{..{..}}.{..{..}}}"], "")-         , ( 8, [".{.{#.{..}}.{#.{*3.}}}"], "")-         , ( 8, [".{.{#.}.{#.}}"], "")-         , ( 8, [".{..}"], "")-         , ( 8, ["."], "")-         , ( 9, [".{...}", ".{.#}"], "")-         , (10, [".{...}", ".{.#}"], "")-         , (11, [".{...}", ".{.#}"], "")-         ]-    putStrLn "===================================================="-    putStrLn "Testing miscellaneous NFDataP functions..."-    doit13 True test_patterns13-#endif--#if 1-    -- Testing fusion-    putStrLn "\nTesting fusion\n-fenable-rewrite-rules -O -ddump-rules -ddump-simpl-stats -ddump-rule-firings\n"-    let exp12 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-    let get12 (_,xs,_) = (xs!!2)-    putStrLn $ show $ get12 $ ( forcep ".:Bool" . forcep ".:Int" ) exp12-    putStrLn $ show $ get12 $ ( forcep ".:Bool" . forcep_ (compilePat ".:Int") ) exp12-    putStrLn $ show $ get12 $ ( forcep_ (compilePat ".:Bool") . forcep ".:Int" ) exp12-    putStrLn $ show $ get12 $ ( forcep_ (compilePat ".:Bool") . forcep_ (compilePat ".:Int") ) exp12-#endif--#if 1-    putStrLn "\n\-  expN_1 = [__] :: [Int]\n\-  expN_2 = [0,1,__,3] :: [Int]\n\-  expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)\n\-  expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)\n\-\n\-  getN_1 xs = show $ ()\n\---getN_1 xs = show $ head xs\n\---getN_2 xs = show $ (xs!!1)\n\-  getN_2 xs = show $ (xs!!3)\n\-  getN_3 (_,xs,_) = show $ (xs!!2)\n"-    doit5 1 0 1 "" >>= putStrLn-    doit6 1 0 1 "" >>= putStrLn-    doit7 1 0 1 "" >>= putStrLn-    doit8 1 0 1 "" >>= putStrLn-#if 0-    doit9 >>= putStrLn  -- XXX broken (whatever it is)-#endif-#endif--#if 0-    s4 <- doit4 1 0 1 ""-    putStrLn s4-#endif--#if 0-    putStrLn $ ""-           ++ "expBase1 = ([True,False],3,Just \"fox\")         :: ([Bool],Int,Maybe String)\n"-           ++ "expBase2 = ([True,False],__,Just \"fox\")        :: ([Bool],Int,Maybe String)\n"-           ++ "expBase3 = ([True,__],3,Just \"fox\")            :: ([Bool],Int,Maybe String)\n"-           ++ "expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)\n"-           ++ "expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)\n"-           ++ "expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)\n"-           ++ "get1 ((x:_),_,_) = x           -- True\n"-           ++ "get2 (_,x,_) = x               -- 3\n"-           ++ "get3 (_,_,x) = fromJust x      -- \"fox\"\n"-           ++ "get4 (_,_,Just (x:_)) = x      -- 'f'\n"-    s1 <- doit1 1 1 1 ""-    putStrLn s1-#endif--#endif-----------------------------------------------------------------------------------  hline :: String-  hline = "----------------------------------------------------\n"-  hdline :: String-  hdline = "====================================================\n"-----------------------------------------------------------------------------------  doit1 :: Int -> Int -> Int -> String -> IO String-  doit1 i j k acc-   -- this glitch (the exception that seemingly escapes my catch)-   -- happens just for these combos (and for all j):--- | i == 3 && k == 4  = doit1 (1+i) j k acc  -- trying to avoid a glitch...--- | i == 3 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...--- | i == 3 && j < 4 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...-   | k == 7  = return acc-   | j == 6  = doit1 1 1 (1+k) acc-   | i == 5  = doit1 1 (1+j) k acc-   | otherwise  = do-      fexp <- catch-               -- The semantics of the !'s here are not what they were,-               -- since forcing in some places. [?] But at least the-               -- first one seems definitely still needed...-               -- LATER: The second one is also needed, finally seen!-               -- (It is needed for a version of getE _ = "getee", only.)-               -- XXX I'm just not sure whether the second ! is better-               -- to leave in or leave out...-               ( return $! get $! forcen dep exp )-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)---    doit1 (1+i) j k $! force $ acc-      doit1 (1+i) j k $! acc---    doit1 (1+i) j k $ acc-        ++ "( get" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k ++ " )  "-        ++ fexp ++ "\n"-   where-    exp = case k of-            1 -> expBase1-            2 -> expBase2-            3 -> expBase3-            4 -> expBase4-            5 -> expBase5-            6 -> expBase6-    get = case i of-           1 -> get1-           2 -> get2---         3 -> unsafePerformIO . get3  -- yeesh!...---         3 -> get3-           3 -> get3 (i,j,k)-           4 -> get4-    dep = j--#if 0-  -- XXX All this fuss to deal with the case that the-  -- entire argument m is undefined (or whatever is going-  -- for "undefined" at the moment...) -- but, none of-  -- the expBase[1-5] have this! ch.-  myFromJust :: Maybe a -> IO (Either () a)-  myFromJust m = do-                    putStrLn "Boo!"-                    catch-                      (myFromJust' m)-                      (\e -> do putStrLn $! show (e::BottomedOut)-                                putStrLn "HERE!"-                                return $! Left ())-  myFromJust' :: Maybe a -> IO (Either () a)-  myFromJust' Nothing = do---                         throw BottomedOut-                           return $! Left ()-  myFromJust' (Just x) = return $! Right x---myFromJust _ = throw BottomedOut-#endif------------------------------------#if 0-  doit2 :: Int -> Int -> Int -> String -> IO String-  doit2 i j k acc--- | k == 2  = {- trace (show (i,j,k)) $ -} return acc--- | k == 7  = return acc-   | k == 27  = return acc--- | k == 21  = return acc--- | k == 5  = return acc--- | j == 15  = doit2 1 0 (1+k) acc-   | j == 11  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc--- | j == 8  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc--- | j == 3  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc--- | i == 3  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc-#else-   | i == 2  = doit2 1 (1+j) k acc--- | i == 3  = doit2 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )---             ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit2 (1+i) j k $! acc-        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expTB_" ++ show (k'-6) ++ " )  "---      ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expBase" ++ show k' ++ " )  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            7 -> expBase7-            8 -> expBase8-            9 -> expBase9-            10 -> expBase10-            11 -> expBase11-            12 -> expBase12-            13 -> expBase13-            14 -> expBase14-            15 -> expBase15-            16 -> expBase16-            17 -> expBase17-            18 -> expBase18-            19 -> expBase19-            20 -> expBase20-            21 -> expBase20  -- fudge it!!-            22 -> expBase22-            23 -> expBase23-            24 -> expBase24-            25 -> expBase25-            26 -> expBase26-            27 -> expBase27-            28 -> expBase28-            29 -> expBase29-            30 -> expBase30-            31 -> expBase31-            32 -> expBase32-    get = case i of-           1 -> if k' >= 27 then getB_3 else getB_1-           2 -> getB_2-    dep = j'-    j' = j---  j' = j+11---  k' = k+26-    k' = k+6-#endif--#if 0-  doit3 :: Int -> Int -> Int -> String -> IO String-  doit3 i j k acc-   | k == 2  = return acc-   | j == 8  = {- trace (show (i,j,k)) $ -} doit3 1 1 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit3 1 (1+j) k acc-#else-   | i == 2  = doit3 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit3 (1+i) j k $! acc-        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k' ++ " )  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            21 -> expBase21-    get = case i of-           1 -> getA-    dep = j'-    i' = i-    j' = j-    k' = k+20-#endif--#if 0-  doit4 :: Int -> Int -> Int -> String -> IO String-  doit4 i j k acc--- | k == 2  = return acc-   | k == 4  = return acc-   | j == 8  = {- trace (show (i,j,k)) $ -} doit4 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit4 1 (1+j) k acc-#else-   | i == 2  = doit4 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit4 (1+i) j k $! acc-        ++ "( getE $ forcen " ++ show dep ++ " expTE_" ++ show k' ++ " )  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            1 -> expTE_1-            2 -> expTE_2-            3 -> expTE_3-    get = case i of-           1 -> getE-    dep = j'-    i' = i-    j' = j-    k' = k-#endif-----------------------------------------------------------------------------------  doit5 :: Int -> Int -> Int -> String -> IO String-  doit5 i j k acc-   | k == 2  = return acc-   | j == 5  = {- trace (show (i,j,k)) $ -} doit5 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit5 1 (1+j) k acc-#else-   | i == 2  = doit5 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit5 (1+i) j k $! acc-        ++ "forcen " ++ show dep ++ " expN_" ++ show k' ++ " `seq` ()  =  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            1 -> expN_1-    get = case i of-           1 -> getN_1-    dep = j'-    i' = i-    j' = j-    k' = k-----------------------------------------------------------------------------------  doit6 :: Int -> Int -> Int -> String -> IO String-  doit6 i j k acc-   | k == 2  = return acc-   | j == 5  = {- trace (show (i,j,k)) $ -} doit6 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit6 1 (1+j) k acc-#else-   | i == 2  = doit6 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit6 (1+i) j k $! acc-        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            _ -> expN_2-    get = case i of-           _ -> getN_2-    dep = j'-    i' = i+1-    j' = j-    k' = k+1-----------------------------------------------------------------------------------  doit7 :: Int -> Int -> Int -> String -> IO String-  doit7 i j k acc-   | k == 2  = return acc-   | j == 5  = {- trace (show (i,j,k)) $ -} doit7 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit7 1 (1+j) k acc-#else-   | i == 2  = doit7 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit7 (1+i) j k $! acc-        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            _ -> expN_3-    get = case i of-           _ -> getN_3-    dep = j'-    i' = i+2-    j' = j-    k' = k+2-----------------------------------------------------------------------------------  doit8 :: Int -> Int -> Int -> String -> IO String-  doit8 i j k acc-   | k == 2  = return acc-   | j == 5  = {- trace (show (i,j,k)) $ -} doit8 1 0 (1+k) acc-#if USE_TRACE-   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit8 1 (1+j) k acc-#else-   | i == 2  = doit8 1 (1+j) k acc-#endif-   | otherwise  = do-      fexp <- catch-               ( return $! get $! forcen dep exp )-               -- ErrorCall if use __ = undefined-               -- BottomedOut if use __ = throw BottomedOut-               (\e -> do let err = show (e :: ErrorCall)---             (\e -> do let err = show (e :: BottomedOut)-                         return err)-      doit8 (1+i) j k $! acc-        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "-        ++ fexp ++ "\n"-   where-    exp = case k' of-            _ -> expN_4-    get = case i of-           _ -> getN_3-    dep = j'-    i' = i+2-    j' = j-    k' = k+3-----------------------------------------------------------------------------------#if 0--#if 0-  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-  patP_1 = Node (TR [typeOf ((__,__,__)::(Float, [Int], Bool))])-             [ Node (TR [typeOf (__::Bool)]) []---           [ Node (TR [typeOf (__::Float)]) []---           [ Node (NTR [typeOf (__::Bool)]) []---           [ Node (NTR [typeOf (__::Float)]) []---           , Node WS []-             , Node (TW [typeOf ([__]::[Int])]) []---           , Node (TR [typeOf ([__]::[Int])]) []---           , Node (TR [typeOf ([__]::[Int])]) [ Node WS [], Node WS [] ]  -- why not?-             , Node WW []---           , Node I []-             ]-  getP_1 (_,xs,_) = show $ (xs!!2)-#endif--  doit9 :: IO String-  doit9 = do-#if 0-    putStrLn "\-  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)\n\-  patP_1 = Node (T [typeOf ((__,__,__)::(Float, [Int], Bool))])\n\-             [ Node W []\n\-             , Node (T [typeOf ([__]::[Int])]) []\n\-             , Node I []\n\-             ]\n\-  getP_1 (_,xs,_) = show $ (xs!!2)\n"-    putStrLn "getP_1 $ forcep patP_1 expP_1"-#endif-    s <- catch-             ( return $! getP_1 $! forcep patP_1 expP_1 )---           ( return $! getP_2 $! forcep patP_2 expP_2 )---           ( return $! getP_3 $! forcep patP_3 expP_3 )-             -- ErrorCall if use __ = undefined-             -- BottomedOut if use __ = throw BottomedOut-             (\e -> do let err = show (e :: ErrorCall)---           (\e -> do let err = show (e :: BottomedOut)-                       return err)-    return s--#endif-----------------------------------------------------------------------------------  doit10 :: Bool -> [(Int,String)] -> IO ()-  doit10 _ [] = do-                   putStrLn "----------------------------------------------------"-                   return ()-  doit10 b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "7 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit10: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-                let pat = compilePat patstr-                let get (_,xs,_) = show $ (xs!!2)-                if b-                 then do-                  putStrLn "===================================================="-                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"-                  putStrLn "get (_,xs,_) = show $ (xs!!2)"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "===================================================="-                 else do-                  putStrLn "----------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                 then putStrLn $  "expected value           = " ++ expect-                 else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                 then putStrLn $  "expected value           = " ++ expect-                 else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit10 False t-----------------------------------------------------------------------------------  doit11 :: Bool -> [(Int,String,String)] -> IO ()-  doit11 _ [] = do-                   putStrLn "----------------------------------------------------"-                   return ()-  doit11 b ((code,patstr1,patstr2):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  _ -> error $ "doit11: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-                let patstrU = showPat $ unionPats [compilePat patstr1, compilePat patstr2]-                let pat1 = compilePat patstr1-                let pat2 = compilePat patstr2-                let patU = unionPats [pat1,pat2]-                let get (_,xs,_) = show $ (xs!!2)-                if b-                 then do-                  putStrLn "===================================================="-                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"-                  putStrLn "get (_,xs,_) = show $ (xs!!2)"-                  putStrLn "? = get $ ( forcep patstr2 . forcep patstr1 ) exp"---                putStrLn "? = get $ ( forcep ( unionPatsStr [ patstr1, patstr2 ] ) ) exp"-                  putStrLn "? = get $! ( forcep_ ( unionPats [ pat1, pat2 ] ) ) exp"-                  putStrLn "(Results were more interesting with a previous semantics...)."-                  putStrLn "===================================================="-                 else do-                  putStrLn "----------------------------------------------------"-                putStrLn $ "patstr1                     = " ++ patstr1-                putStrLn $ "patstr2                     = " ++ patstr2-                putStrLn $ "patstrU                     = " ++ patstrU-                if code > 4-                 then putStrLn $  "expected value              = " ++ expect-                 else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat patstr1  = " ++ showPat pat1-                putStrLn $ "showPat.compilePat patstr2  = " ++ showPat pat2-                putStrLn $ "showPat.compilePat patstrU  = " ++ showPat patU-                if code <= 4-                 then putStrLn $  "expected value              = " ++ expect-                 else return ()-                putStr "actual value                = "-                let s1 = get $! ( forcep patstr2 . forcep patstr1 ) exp-                putStrLn s1-                putStr "actual value                = "-                let s2 = get $! forcep patstrU exp-#if 1-                let s3 = s2-#else-                putStrLn s2-                let s3 = get $! forcep_ ( unionPats [ pat1, pat2 ] ) exp-#endif-                return $! s3-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit11 False t-----------------------------------------------------------------------------------  doit12 :: Bool -> [(Int,String,[Int],[(Int,String)])] -> IO ()---doit12 :: Bool -> [(Int,String,String,[(Int,String)])] -> IO ()-  doit12 _ [] = do-                   return ()-  doit12 b ((code,patstr1,path,isibs'):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  _ -> error $ "doit12: unexpected code " ++ show code-    s <- catch-           ( do-                let target = compilePat patstr1---              let path = compilePat patstr2-                let isibs = map (\ (x,y) -> (x,compilePat y)) isibs'-                if b-                 then do-                  putStr hdline-                  putStrLn "Testing splicePats."-                  putStr hline-                 else return ()-                putStrLn $ "target       " ++ patstr1-                putStrLn $ "path         " ++ show path---              putStrLn $ "path         " ++ patstr2-                putStrLn $ "isibs        " ++ show isibs'-                let s1 = force $ showPat $ splicePats target path isibs---              let s1 = showPat $! splicePats target path isibs---              let s1 = showPat $ splicePats target path isibs-                putStr "result       "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    if null t then return () else putStr hline-    doit12 False t-----------------------------------------------------------------------------------  doit13 :: Bool -> [(Int,[String],String)] -> IO ()-  doit13 _ [] = do-                   putStr hline-                   return ()-  doit13 b ((code,patstrlst,expectstr):t) = do-    s <- catch-           ( do-                s1 <- case code of--- Where were they done already?--- Oh, in doit11 and doit12 above...-                       1 -> error $ hline ++ "unionPats test already done test13-1!"---                     4 -> error $ hline ++ "unionPatsStr test already done test13-4!"-                       10 -> error $ hline ++ "splicePats test already done test13-10!"-                       11 -> error $ hline ++ "isPath test already done test13-11!"-    --  1    unionPats        :: [ Pat ] -> Pat-    --  2  * intersectPats :: [ Pat ] -> Pat-    --  3  * isSubPatOf      :: Pat -> Pat -> Bool---  --  4    unionPatsStr     :: [ String ] -> String-    --  5  * emptyPat        :: Pat---  --  6  * mkPat           :: forall d. Data d => d -> Pat---  --  7  * growPat         :: forall d. Data d => Pat -> d -> Pat-    --  8  * shrinkPat       :: Pat -> Pat-    --  9  * liftPats         :: [ Pat ] -> Pat-    -- 10    splicePats       :: Pat -> Pat -> [(Int, Pat)] -> Pat-    -- 11    isPath          :: Pat -> Bool-                       2 -> do-                               let patA = patstrlst!!0-                               let patB = patstrlst!!1-                               putStr hline-                               putStrLn "Testing      intersectPats [patA, patB]"-                               putStrLn $ "patA         " ++ patA-                               putStrLn $ "patB         " ++ patB-                               putStr $ "result       "-                               let s1 = force $ showPat $ intersectPats [compilePat patA, compilePat patB]-                               return s1-                       3 -> do-                               let patA = patstrlst!!0-                               let patB = patstrlst!!1-                               putStr hline-                               putStrLn "Testing      isSubPatOf patA patB"-                               putStrLn $ "patA         " ++ patA-                               putStrLn $ "patB         " ++ patB-                               let s1 = force $ show $ isSubPatOf (compilePat patA) (compilePat patB)-                               if s1 /= expectstr-                                then do putStrLn $ "expect       " ++ expectstr-                                        putStr $ "result       "-                                else putStr $ "as expected  "-                               return s1-                       5 -> do-                               putStr hline-                               putStrLn "Testing      emptyPat"-                               putStr $ "result       "-                               let s1 = force $ showPat $ emptyPat-                               return s1-                       6 -> do-#if 0-                               putStr hline-                               putStrLn "Testing      mkPat ([1,2,3],(False,\"foo\"))"-                               putStr $ "result       "-                               let s1 = force $ showPat $ mkPat ([1,2,3::Int],(False,"foo"))-                               return s1-#else-                               return ""-#endif-                       7 -> do-#if 0-                               let patA = patstrlst!!0-                               putStr hline-                               putStrLn "Testing      growPat patA ([1,2,3],(False,\"foo\"))"-                               putStrLn $ "patA         " ++ patA-                               putStr $ "result       "-                               let s1 = force $ showPat $ growPat (compilePat patA) ([1,2,3::Int],(False,"foo"))-                               return s1-#else-                               return ""-#endif-                       8 -> do-                               let patA = patstrlst!!0-                               putStr hline-                               putStrLn "Testing      shrinkPat patA"-                               putStrLn $ "patA         " ++ patA-                               putStr $ "result       "-                               let s1 = force $ showPat $ shrinkPat (compilePat patA)-                               return s1-                       9 -> do-                               putStr hline-                               putStrLn "Testing      liftPats patstrlst"-                               putStrLn $ "patstrs      " ++ show patstrlst-                               putStr $ "result       "-                               let s1 = force $ showPat $ liftPats $ map compilePat patstrlst-                               return s1-                       _ -> error $ "doit13: unexpected code " ++ show code-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit13 False t-----------------------------------------------------------------------------------  -- This is an adaptation of doit10 to user-defined datatypes,-  -- for testing GNFDataP, which is finally within reach thanks-  -- to SOP!-  doit14 :: Bool -> [(Int,String)] -> IO ()-  doit14 _ [] = do-                   putStrLn "----------------------------------------------------"-                   return ()-  doit14 b ((code,patstr):t) = do-    let expect = case code of-                  1 -> "7"-                  2 -> "Prelude.undefined"-                  3 -> "pattern-match failure"-                  4 -> "syntax error"-                  5 -> "7 (but \"# with subpattern\" warning)"-                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"-                  13 -> "7 (but with pattern-match failure warning)"-                  23 -> "Prelude.undefined (but with pattern-match failure warning)"-                  _ -> error $ "doit14: unexpected code " ++ show code-    s <- catch-           ( do-                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-                let pat = compilePat patstr-                let get (_,xs,_) = show $ (xs!!2)-                if b-                 then do-                  putStrLn "===================================================="-                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"-                  putStrLn "get (_,xs,_) = show $ (xs!!2)"-                  putStrLn "? = get $ forcep patstr exp"-                  putStrLn "===================================================="-                 else do-                  putStrLn "----------------------------------------------------"-                putStrLn $ "patstr                   = " ++ patstr-                if code > 4-                 then putStrLn $  "expected value           = " ++ expect-                 else return ()---              putStrLn $ "pat = " ++ show pat-                putStrLn $ "showPat.compilePat       = " ++ showPat pat-                if code <= 4-                 then putStrLn $  "expected value           = " ++ expect-                 else return ()-                s1 <- catch-                        ( return $! force $! get $! forcep patstr exp )-                        (\e -> do let err = show (e :: ErrorCall)---                      (\e -> do let err = show (e :: BottomedOut)-                                  return err)-                putStr "actual value             = "-                return $! s1-           )-           -- ErrorCall if use __ = undefined-           -- BottomedOut if use __ = throw BottomedOut-           (\e -> do let err = show (e :: ErrorCall)---         (\e -> do let err = show (e :: BottomedOut)-                     return err)-    putStrLn s-    doit14 False t----------------------------------------------------------------------------------
− test/Bottom.hs 
@@ -1,52 +0,0 @@---- XXX This file could be cleaned up a lot, but that's--- not quite a priority at this moment...--  {-# LANGUAGE CPP #-}--  {-# LANGUAGE DeriveDataTypeable #-}-----------------------------------------------------------------------------------#define USE_TRACE 1--- This so can get an honest comparison for the user-defined datatypes;--- if this is 0, the NFDataN instances will be derived via GHC.Generics.--- (The NFData instances are derived in any case.)-#define USE_MANUAL_INSTANCES 0-----------------------------------------------------------------------------------  module Bottom where-----------------------------------------------------------------------------------  import Data.Maybe--  import Control.Exception---import Control.Monad ( guard )-  import Data.Typeable ( Typeable )-  import Data.Typeable ( typeOf )----import Util-  import Debug.Trace ( trace )-  import Control.DeepSeq--  import System.IO.Unsafe ( unsafePerformIO )-----------------------------------------------------------------------------------  __ :: a---bt'm = undefined-  __ = undefined---__ = throw BottomedOut-----------------------------------------------------------------------------------  data BottomedOut = BottomedOut---data BottomedOut = ThisException | ThatException-    deriving (Show, Typeable)--  instance Exception BottomedOut----------------------------------------------------------------------------------
− test/Foo.hs 
@@ -1,265 +0,0 @@---- XXX This file could be cleaned up a lot, but that's--- not quite a priority at this moment...--  {-# LANGUAGE CPP #-}-----------------------------------------------------------------------------------#define USE_TRACE 1--- This so can get an honest comparison for the user-defined datatypes;--- if this is 0, the NFDataN instances will be derived via GHC.Generics.--- (The NFData instances are derived in any case.)-#define USE_MANUAL_INSTANCES 0-----------------------------------------------------------------------------------  module Foo where------------------------------------------------------------------------------------- TABLE OF EXPECTED AND ACTUAL RESULTS--- (Only recording "BOT" or "ok".)------ The expressions and getters are effectively:------ expBase1 = ([True,False],3,Just "fox")         :: ([Bool],Int,Maybe String)--- expBase2 = ([True,False],__,Just "fox")        :: ([Bool],Int,Maybe String)--- expBase3 = ([True,__],3,Just "fox")            :: ([Bool],Int,Maybe String)--- expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)--- expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)--- expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)--- get1 ((x:_),_,_) = x           -- True--- get2 (_,x,_) = x               -- 3--- get3 (_,_,x) = fromJust x      -- "fox"--- get4 (_,_,Just (x:_)) = x      -- 'f'------ These match like Haskell pattern-matching -- the higher will--- be matched first; the lower will pick up what trickles through.------  (i,j,k)         Expected           Actual---   * * 1            ok                 ok---   2 1 2            BOT                BOT---   * 1 2            ok                 ok---   * * 2            BOT                BOT---   * 4 3            BOT                BOT---   * 5 3            BOT                BOT---   * * 3            ok                 ok---   1 1 4            ok                 ok---   1 2 4            ok                 ok---   * * 4            BOT                BOT---   3 * 5            BOT                BOT---   * 5 5            BOT                BOT---   * * 5            ok                 ok---- AND, SOLVED -- by forcing that show!--- Great! And it's the USE_EXCEPTION branch too, which I prefer--- in principle.  Now to consider the output...---- It seems that this difference decides whether escapee exception--- happens of (3,1,4) or (3,1,5):---     doit (1+i) j k $! acc---  -- doit (1+i) j k $ acc--- What I don't understand is why "show" which is part of get3--- doesn't force it where the handler can catch it...---- What a confusion!--- So, if you also insert some tracing, you can see all (i,j,k)--- indices traced, yet the exception still occurs.--- I suppose this is because the acc string isn't forced--- until later, and meanwhile the trace lines are free to--- be printed. (This is the explanation for sure.)---   But just forcing acc is not the same thing?...--- If force acc, you see nothing at all printed except the--- trace lines. All of [ABC](3,1,5) are printed, and then--- the escapee exception rises.---- And anyhow, now it passes 4 but not 5, and I don't even know--- how/why? I'm not using overridden fromJust anymore...--- (i=3 k=5 exception still escapes in any case!)---- By overriding fromJust I was able to get past expBase4,--- but i=3 k=5 exception still escapes!...---- STILL not getting it -- I can run the gamut, just using--- putStrLn (as we're in IO anyhow since started fussing--- with exception catching).  And it says we bottom out--- a few times, with proper interleaving -- but these are--- only when /get/ requests a __ value; it doesn't seem--- to do anything when forcen supposedly forces it.---   And yet, when run with USE_EXCEPTION, we do see these--- extra bottom-outs -- unfortunately, the "exceptional--- exception" occurs and the darned thing doesn't run to--- completion.---- Having some problems.--- Same results if use ErrorCall or use custom BottomedOut,--- namely, get as far as:---   ( get3 $ forcen 1 expBase4 )---   t: BottomedOut--- The "t: " is significant, since normally when hit--- the "potholes" my exception handler prints only "BottomedOut".--- And this also terminates the testing.--- So clearly, my (own, custom, even -- good to know) exception--- is escaping the handler.  How can this be?  Esp. as it seems--- nothing much changes from one test to another.--- The only thing that comes to mind is, we don't catch ASYNCHRONOUS--- exceptions this way? Why should an asynch. exception be raised--- in this case. Trying one more thing: define __ to be trace--- and just trace the fact it was evaluated...---- XXX Regarding the use of undefined, I think this is not--- working well for catching all exceptions? Would we have--- better luck throwing a custom exception type? How do you--- do that? "throw BottomedOut" in the component of the tuple?...--  import Data.Maybe--  import Control.Exception---import Control.Monad ( guard )-  import Data.Typeable ( Typeable )-  import Data.Typeable ( typeOf )----import Util-  import Debug.Trace ( trace )-  import Control.DeepSeq--#if ! HASKELL98_FRAGMENT-  -- Custom exception requires -XDerivingDataTypeable it seems. [?]-  import Bottom-#endif--  import System.IO.Unsafe ( unsafePerformIO )-----------------------------------------------------------------------------------#if HASKELL98_FRAGMENT-  __ = undefined-#else--- imported from Bottom (sorry)-#endif-----------------------------------------------------------------------------------  expN_1 = [__] :: [Int]-  expN_2 = [0,1,__,3] :: [Int]-  expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)-  expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)--  getN_1 xs = show $ ()---getN_1 xs = show $ head xs---getN_2 xs = show $ (xs!!1)-  getN_2 xs = show $ (xs!!3)-  getN_3 (_,xs,_) = show $ (xs!!2)-----------------------------------------------------------------------------------#if 0--  -- Should be able to dodge the third component with a pattern.---expP_1 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)-  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)-  patP_1 = Node (TR [typeOf ((__,__,__)::(Float, [Int], Bool))])-             [ Node (TR [typeOf (__::Bool)]) []---           [ Node (TR [typeOf (__::Float)]) []---           [ Node (NTR [typeOf (__::Bool)]) []---           [ Node (NTR [typeOf (__::Float)]) []---           , Node WS []-             , Node (TW [typeOf ([__]::[Int])]) []---           , Node (TR [typeOf ([__]::[Int])]) []---           , Node (TR [typeOf ([__]::[Int])]) [ Node WS [], Node WS [] ]  -- why not?-             , Node WW []---           , Node I []-             ]-  getP_1 (_,xs,_) = show $ (xs!!2)--  expP_2 = 23 :: Int---expP_2 = [1,__,3] :: [Int]-  patP_2 = Node WW []---patP_2 = Node (TR [typeOf ([__]::[Int])]) []-  getP_2 x = show x--#if 1--- Fuck, this works too... (the only one of all of 'em, except bare 23)--- See NFDataP.hs for expansion of PatNode constructors...--- (It's hardly going to be that useful if you have to specify--- one constructor per node in whole data structure, rather than--- just match the top bit you want as one expects with patterns.)--- So I'm basically committed to this expansion...-  expP_3 = (3.4, (5,__), __) :: (Float, (Int,Int), Bool)-  patP_3 = Node (TR [typeOf ((__,__,__)::(Float, (Int,Int), Bool))])-#if 0-             [ Node W []-             , Node I [ Node W [], Node W [] ]  -- works---           , Node I []                        -- doesn't work-             , Node W []-             ]-#else-             [ Node WR []-             , Node WR [ Node WR [], Node WR [] ]  -- works---           , Node WR []                        -- doesn't work-             , Node WR []-             ]-#endif-  getP_3 (_,(_,x),_) = show x-#else-  expP_3 = (3.4, (5,__), __) :: (Float, (Int,Int), Bool)-  patP_3 = Node (T [typeOf ((__,__,__)::(Float, (Int,Int), Bool))])-             [ Node (T [typeOf (__::Float)]) []---           [ Node W []-             , Node (T [typeOf ((__,__)::(Int,Int))]) []-             , Node I []-             ]-  getP_3 (_,(_,x),_) = show x-#endif--#endif-----------------------------------------------------------------------------------  expBase1 = ([True,False],3,Just "fox")         :: ([Bool],Int,Maybe String)-  expBase2 = ([True,False],__,Just "fox")        :: ([Bool],Int,Maybe String)-  expBase3 = ([True,__],3,Just "fox")            :: ([Bool],Int,Maybe String)-  expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)-  expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)-  expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)--#if 1-  get1 ((x:_),_,_) = show x         -- True-  get2 (_,x,_) = show x             -- 3-#if 0-#if 0-  get3 (_,_,x) = do-                    es <- myFromJust x  -- "fox"-                    case es of-                     Left () -> return ""-                     Right s -> return $! show s---get3 (_,_,x) = show $! myFromJust x  -- "fox"-#else-  get3 (_,_,x) = return $! show $! fromJust x  -- "fox"---get3 (_,_,x) = return $ show $ fromJust x  -- "fox"-#endif-#else-  get3 ijk (_,_,x) = force $ show $ fromJust x  -- "fox"---get3 ijk (_,_,x) = trace ("A"++show ijk) ( force $ show $! trace ("B"++show ijk) $ fromJust $! trace ("C"++show ijk) $ x )  -- "fox"---get3 (_,_,x) = show $! fromJust x  -- "fox"---get3 (_,_,x) = show $ fromJust x  -- "fox"-#endif-  get4 (_,_,Just (x:_)) = show x    -- 'f'-#else-  get1 ((x:_),_,_) = x       -- True-  get2 (_,x,_) = x           -- 3-  get3 (_,_,x) = fromJust x  -- "fox"-  get4 (_,_,Just (x:_)) = x  -- 'f'-#endif--#if 0-  -- oops, these are just what you DON'T want!-  get1 (_,x,_) = x  -- 3-  get2 (_:x:_) = x  -- False-  get3 (_,_,x) = fromJust x  -- "fox"-  get4 (_,_,(_:x:_)) = x  -- 'o'-#endif----------------------------------------------------------------------------------
− test/FooG.hs 
@@ -1,612 +0,0 @@---- XXX This file could be cleaned up a lot, but that's--- not quite a priority at this moment...--  {-# LANGUAGE CPP #-}-----------------------------------------------------------------------------------#define USE_TRACE 1--- This so can get an honest comparison for the user-defined datatypes;--- if this is 0, the NFDataN instances will be derived via GHC.Generics.--- (The NFData instances are derived in any case.)-#define USE_MANUAL_INSTANCES 0-----------------------------------------------------------------------------------#if USE_SOP-  {-# LANGUAGE DataKinds #-}-  {-# LANGUAGE TypeFamilies #-}-  {-# LANGUAGE TemplateHaskell #-}-#else-  {-# LANGUAGE DeriveGeneric #-}-#endif--  {-# LANGUAGE DeriveGeneric #-}  -- still needed to derive NFData...--  {-# LANGUAGE DeriveDataTypeable #-}  -- to make BottomedOut-----------------------------------------------------------------------------------  module FooG where-------------------------------------------------------------------------------------import     Control.DeepSeq.Generics-  import Control.DeepSeq.Bounded hiding ( F )-  import Control.DeepSeq.Bounded.Generics--#if USE_SOP-  import Generics.SOP.TH-#else-  import GHC.Generics---import GHC.Generics ( Generic )-#endif--  import GHC.Generics ( Generic ) -- still needed to derive NFData...-  import Control.DeepSeq.Generics--  import Data.Maybe--  import Control.Exception---import Control.Monad ( guard )-  import Data.Typeable ( Typeable )-  import Data.Typeable ( typeOf )----import Util-  import Debug.Trace ( trace )-  import Control.DeepSeq--  import Bottom--  import System.IO.Unsafe ( unsafePerformIO )-----------------------------------------------------------------------------------  data TA = A1 Bool Int-          | A4 (Float,TB,Int)  -- (testing reordering!)-          | A2 Int-          | A3 TB Bool-          | A5 (Int,Float)-#if USE_SOP-    deriving (Show)-#else-    deriving (Show,Generic)-#endif---instance NFData TA where rnf = genericRnf-#if USE_MANUAL_INSTANCES-  instance NFDataN TA where-    rnfn n (A1 x y)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y-    rnfn n (A2 x)-     | n <= 0     = ()-     | otherwise  = rnfn (-1+n) x-    rnfn n (A3 x y)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y-    rnfn n (A4 x)-     | n <= 0     = ()-     | otherwise  = rnfn (-1+n) x-#else-#if USE_SOP-  instance NFDataN TA where rnfn = grnfn-#else-  instance NFDataN TA where rnfn = genericRnfn-#endif-#endif-  expTA = A1 __ 3--  data TB = B1 Bool TA-          | B2 TA TB-          | B3 Bool TA Int-          | B4 Bool Int TA-          | B5 Bool Int Float-          | B6 TA-          | B7 TB-          | B8 (Int,Float)-          | B9 Bool (Int,Float) Int-          | B10 (Int,Int,(Int,Int,Int,Int),Int)-          | B11 Bool (Int,Int,(Int,Int,Int,Int),Int)-#if USE_SOP-    deriving (Show)-#else-    deriving (Show,Generic)-#endif---instance NFData TB where rnf = genericRnf-#if USE_MANUAL_INSTANCES-  instance NFDataN TB where-    rnfn n (B1 x y)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y-    rnfn n (B2 x y)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y-    rnfn n (B3 x y z)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y `seq` rnfn n' z-    rnfn n (B4 x y z)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y `seq` rnfn n' z-    rnfn n (B5 x y z)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y `seq` rnfn n' z-    rnfn n (B6 x)-     | n <= 0     = ()-     | otherwise  = rnfn (-1+n) x-#else-#if USE_SOP-  instance NFDataN TB where rnfn = grnfn-#else-  instance NFDataN TB where rnfn = genericRnfn-#endif-#endif--#if USE_SOP-  deriveGeneric ''TA-  deriveGeneric ''TB-#endif--  expTB_1 = B2 (A1 True 4) (B1 True (A2 23))---expTB_1 = B2 (A1 True 4) (B1 True (A2 __))-  expTB_2 = B2 (A1 __   4) (B1 True (A2 __))-  expTB_3 = B2 (A1 __   4) (B1 __   (A2 __))---expTB_4 = B2 (A1 True 4) (B1 True (A2 __))---expTB_4 = B2 (A1 True 4) (B1 __   (A2 __))-  expTB_4 = B2 (A1 True 4) (B1 __   (A2 23))-  expTB_5-   = B2-        (A3 (B1 False (A2 __)) True)-        (B1 True (A1 False 4))-  expTB_6-   = B2-        (A3 (B1 __ (A2 3)) True)-        (B1 True (A1 False 4))-  expTB_7-   = B2-        (A3 (B1 False (A2 3)) True)-        (B1 __ (A1 False 4))-  expTB_8-   = B2-        (A3 (B1 False (A2 3)) True)-        (B1 True (A1 __ 4))-  expTB_9-   = B2-        (A3 (B3 False __ 5) True)-        (B1 True (A1 False 4))-  expTB_10                                                -- 5  .-   = B2-        (A3 (B3 False (A2 3) 5) True)-        (B1 True (A4 (2.3, B1 False (A1 True 4), __)))-  expTB_11-   = B2-        (A3 (B3 False (A2 3) 5) True)-        (B1 True (A4 (__, B1 False (A1 True 4), 6)))-  expTB_12-   = B2-        (A3 (B3 False (A2 3) 5) True)-        (B1 True (A4 (2.3, B1 False (A1 __ 4), 6)))-  expTB_13-   = B2-        (A3 (B3 False (A2 3) __) True)-        (B1 True (A1 False 4))-  expTB_14-   = B2-        (A3 (B3 False (A2 __) 5) True)-        (B1 True (A1 False 4))-  expTB_15 = A3 (B3 False __ 5) False  -- not expTB actually-                             -- For the non-combinator SOP recursion version:-  expTB_16 = B3 False (A2 __) 5   -- E/A =  3  .   B3 Bool TA Int---expTB_16 = B7 (B3 False __ 5)   -- E/A =  3  .   B3 Bool TA Int---expTB_16 = B3 False __ 5        -- E/A =  2  .   B3 Bool TA Int-  expTB_17 = B4 False 5 __        -- E/A =  2  .   B4 Bool Int TA-  expTB_18 = B5 False 5 __        -- E/A =  2  .   B5 Bool Int Float-  expTB_19 = B1 False __          -- E/A =  2  .   B1 Bool TA-  expTB_20 = B6 __                -- E/A =  2  .   B6 TA----data TA = A1 Bool Int---        | A4 (Float,TB,Int)---        | A2 Int---        | A3 TB Bool---        | A5 (Int,Float)---data TB = B1 Bool TA---        | B2 TA TB---        | B3 Bool TA Int---        | B4 Bool Int TA---        | B5 Bool Int Float---        | B6 TA---        | B7 TB---        | B8 (Int,Float)---        | B9 Bool (Int,Float) Int-  expTB_21 = B7 (B7 (B5 __ 5 2.3))    -- E/A =  4  .-  expTB_22 = B7 (B7 (B5 True 5 __))   -- E/A =  4  .-  expTB_23 = B1-                True-                (A4-                    ( 2.3-                    , B2-                         -- forcen 4 takes you to here (unwrapping B2).-                                                     -- Bottoms-out at n=?-                                                     -- (X Y) = SOP recurs.-                                                     -- E(xpect) A(ctual)-                                                     -- E  A (. if A=E)---                       (A3 (B6 (A2 __)) False)     -- 8  .-                         (A3 (B6 (A2 7)) False)      -- never-                         (B3 True (A2 5) __)         -- 6  8  ( 6  . )---                       (B9 True (2,__) 6)          -- 7  .  ( 7  . )---                       (B9 True (__,3.4) 6)        -- 7  .  ( 7  . )---                       (B9 True __ 6)              -- 6  7  ( 6  . )---                       (B3 True __ 6)              -- 6  7  ( 6  . )---                       (B3 True (A2 __) 6)         -- 7  .  ( 7  . )---                       (B3 __ (A2 5) 6)            -- 6  .  ( 6  . )---                       (B3 True (A2 5) 6)          -- never-                    , 7))-                                                           -- E  A---expTB_24 = B10 (1,2,(3,__,5,6),7)                        -- 4  .-  expTB_24 = B11 False (1,2,(3,__,5,6),7)                  -- 4  .-  expTB_25 = B9 True __ 6                                  -- 2  .---expTB_25 = B9 __ (1,2.3) 6                               -- 2  .---expTB_26 = B7 (B9 True __ 6)                             -- 3  .---expTB_26 = B7 (B7 (B7 (B7 (B9 True __ 6))))              -- 6  .-  expTB_26 = B2 (A2 8) (B7 (B7 (B7 (B7 (B9 True __ 6)))))  -- 7  .--  getA (A3 _ b) = show b--  expBase7 = expTB_1-  expBase8 = expTB_2-  expBase9 = expTB_3-  expBase10 = expTB_4-  expBase11 = expTB_5-  expBase12 = expTB_6-  expBase13 = expTB_7-  expBase14 = expTB_8-  expBase15 = expTB_9-  expBase16 = expTB_10-  expBase17 = expTB_11-  expBase18 = expTB_12-  expBase19 = expTB_13-  expBase20 = expTB_14-  expBase21 = expTB_15-  expBase22 = expTB_16-  expBase23 = expTB_17-  expBase24 = expTB_18-  expBase25 = expTB_19-  expBase26 = expTB_20--  expBase27 = expTB_21-  expBase28 = expTB_22-  expBase29 = expTB_23-  expBase30 = expTB_24-  expBase31 = expTB_25-  expBase32 = expTB_26-----------------------------------------------------------------------------------#if 1-  getB_1 :: TB -> String-  getB_1 (B1 b _) = show b-  getB_1 (B2 _ (B1 b _)) = show b-  getB_1 (B3 _ _ n) = show n-  getB_1 (B4 _ n _) = show n-  getB_1 (B5 _ n _) = show n-  getB_1 (B6 _) = "beesix"---getB_1 (B7 x) = getB_1 x-  getB_1 _ = error "!"-  getB_2 :: TB -> String-  getB_2 (B1 b _) = show b-  getB_2 (B2 (A1 _ n) _) = show n-  getB_2 (B2 (A3 _ b) _) = show b-  getB_2 (B3 _ _ n) = show n-  getB_2 (B4 _ n _) = show n-  getB_2 (B5 _ n _) = show n-  getB_2 (B6 _) = "beesix"-  getB_2 _ = error "!"-  getB_3 _ = "<bah>"-#else-  getB_1 :: TB -> Bool-  getB_1 (B2 _ (B1 b _)) = b-  getB_1 _ = error "!"-  getB_2 :: TB -> Int-  getB_2 (B2 (A1 _ n) _) = n-  getB_2 _ = error "!"-#endif-----------------------------------------------------------------------------------  data TC = C Int Bool-#if USE_SOP-    deriving (Show)-#else-    deriving (Show,Generic)-#endif---instance NFData TC where rnf = genericRnf-#if USE_MANUAL_INSTANCES-  instance NFDataN TC where-    rnfn n (C x y)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y-#else-#if USE_SOP-  deriveGeneric ''TC-  instance NFDataN TC where rnfn = grnfn-#else-  instance NFDataN TC where rnfn = genericRnfn-#endif-#endif-  expTC = C __ True-  getC (C _ x) = x--  data TD = D1 Int Bool-          | D2 Int Bool-#if USE_SOP-    deriving (Show)-#else-    deriving (Show,Generic)-#endif---instance NFData TD where rnf = genericRnf-#if USE_MANUAL_INSTANCES-  instance NFDataN TD where-    rnfn n (D1 x y)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y-    rnfn n (D2 x y)-     | n <= 0     = ()-     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y-#else-#if USE_SOP-  deriveGeneric ''TD-  instance NFDataN TD where rnfn = grnfn-#else-  instance NFDataN TD where rnfn = genericRnfn-#endif-#endif-  expTD_1 = D1 __ True-  expTD_2 = D2 __ True-  getD (D1 _ x) = x-  getD (D2 _ x) = x-----------------------------------------------------------------------------------  data TE = E TF-#if USE_SOP-    deriving (Show)-#else-    deriving (Show,Generic)-#endif---instance NFData TE where rnf = genericRnf-#if USE_MANUAL_INSTANCES-  instance NFDataN TE where-    rnfn n (E x)-     | n <= 0     = ()-     | otherwise  = rnfn (-1+n) x-#else-#if USE_SOP-  instance NFDataN TE where rnfn = grnfn-#else-  instance NFDataN TE where rnfn = genericRnfn-#endif-#endif--  data TF = F Int-#if USE_SOP-    deriving (Show)-#else-    deriving (Show,Generic)-#endif---instance NFData TF where rnf = genericRnf-#if USE_MANUAL_INSTANCES-  instance NFDataN TF where-    rnfn n (F x)-     | n <= 0     = ()-     | otherwise  = rnfn (-1+n) x-#else-#if USE_SOP-  instance NFDataN TF where rnfn = grnfn-#else-  instance NFDataN TF where rnfn = genericRnfn-#endif-#endif--#if USE_SOP-  deriveGeneric ''TE-  deriveGeneric ''TF-#endif--  expTE_1 = E (F 23)-  expTE_2 = E (F __)-  expTE_3 = E __--#if 1-  -- These all produce the same, unexpected result; so maybe the-  -- pattern-matching isn't implicated?...-  getE (E _) = "getee"---getE (E ~_) = "getee"---getE (E ~x) = "getee"-#else-  -- In order for this not to just print "getee" every time,-  -- you need to make "get $ " to "get $! " everywhere it-  -- occurs in Main.hs.-  getE _ = "getee"  -- making sure the (E _) isn't triggering...-#endif-----------------------------------------------------------------------------------#if USE_SOP--  -- Following the shape of the base-typed test expression-  -- used in Blah.doit10:  (_, [_,_,_], _) :: (Float, [Int], Bool)--  data TG = G1 | G2 Int Int Int-    deriving (Show,Generic,Typeable)---  deriving (Show,Generic)---  deriving (Show)---instance NFData TG where rnf = genericRnf-  instance NFDataP TG where rnfp = grnfp-  instance NFDataN TG where rnfn = grnfn-  instance NFData TG where rnf = genericRnf--  deriveGeneric ''TG--  expTG_1 = ( G1, G2 5 6 7, True )-  expTG_2 = ( __, G2 __ __ 7, __ )-  expTG_3 = ( G1, G2 __ __ 7, __ )-  expTG_4 = ( G1, G2 5 6 7, __ )-  expTG_5 = ( G1, G2 5 __ 7, __ )   -- this is the analogue of doit10 exp--  getG :: (TG,TG,Bool) -> String-  getG (_,(G2 _ _ n),_) = show n---getG (_,(G2 _ _ _),_) = "getG-G2"-  getG _ = "getG-!"--  expTG_6 = G2 5 __ 7-  getG' :: TG -> String-  getG' (G2 _ _ n) = show n--#endif-----------------------------------------------------------------------------------#if USE_SOP--  -- A more elaborate shape for more thorough testing!--  data TH = H1 Float | H2 Int [TH] Bool | H3 | H4 (TH,TI)-    deriving (Show,Generic,Typeable)-  instance NFDataP TH where rnfp = grnfp-  instance NFDataN TH where rnfn = grnfn-  instance NFData  TH where rnf  = genericRnf--  data TI = I1 (Bool,TH) | I2 | I3 TI TH-    deriving (Show,Generic,Typeable)-  instance NFDataP TI where rnfp = grnfp-  instance NFDataN TI where rnfn = grnfn-  instance NFData  TI where rnf  = genericRnf--  deriveGeneric ''TH-  deriveGeneric ''TI--  expTH_1 = H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False-  expTH_2 = H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] False-  expTH_3 = H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] __-  expTH_4 = H2 1 [H1 2.3, H3, H4 (__, I3 __ (H1 4.5))] __--  getH :: TH -> String-  getH (H2 _ [_, _, H4 (_, I3 _ (H1 f))] _) = show f-  getH _ = "getH-!"--#endif-----------------------------------------------------------------------------------#if USE_SOP--  -- A more elaborate shape for more thorough testing!--  data TJ = J1 Float | J2 (Int,TJ) Bool | J3 | J4 (TJ,TK) | J5 Int | J6 TK-    deriving (Show,Generic,Typeable)-  instance NFDataP TJ where rnfp = grnfp-  instance NFDataN TJ where rnfn = grnfn-  instance NFData  TJ where rnf  = genericRnf--  data TK = K1 (Bool,TJ) | K2 | K3 TK TJ | K4 Int Bool | K5 TJ | K6 Float Int Bool | K7 TJ TJ-    deriving (Show,Generic,Typeable)-  instance NFDataP TK where rnfp = grnfp-  instance NFDataN TK where rnfn = grnfn-  instance NFData  TK where rnf  = genericRnf--  deriveGeneric ''TJ-  deriveGeneric ''TK--  expTJ_1 = J2 (1, J4 (J3, K3 K2 (J1 4.5))) False-  expTJ_2 = J2 (1, J4 (J3, K3 __ (J1 4.5))) False-  expTJ_3 = J2 (1, J4 (__, K3 K2 (J1 4.5))) False-  expTJ_4 = J2 (1, J4 (__, K3 __ (J1 4.5))) __--  getJ :: TJ -> String-  getJ (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f-  getJ _ = "getJ-!"-  getJ' :: TJ -> String--  expTJ_5 = J2 (1, J4 (__, K2)) False--  getJ' ~_ = show 1---getJ' _ = show 1---getJ' (J2 ~(n, ~_) _) = show n---getJ' (J2 (n, _) _) = show n---getJ' (J2 (n, J4 (_, K2)) _) = show n---getJ' (J2 (n, J4 (_, K2)) False) = show n  -- most explicit-  getJ' _ = "getJ'-!"--  expTJ_6 = J4 (__, K2)-  getJ6 ~_ = show 1--  expTJ_7 = (__, K2) :: (TJ, TK)-  getJ7 ~_ = show 1--  expTJ_8 = __ :: TJ-  getJ8 ~_ = show 1--  expTK_1 = K3 K2 (J1 4.5)-  expTK_2 = K3 __ (J1 4.5)--  getK :: TK -> String-  getK (K3 _ (J1 f)) = show f-  getK _ = "getK-!"--#endif-----------------------------------------------------------------------------------#if USE_SOP--  -- Trying to find a minimal failing case now...--#if 1-  data TL = L1 TM Float-#else-  data TL = L1 Float TM-#endif-    deriving (Show,Generic,Typeable)-  instance NFDataP TL where rnfp = grnfp-  instance NFDataN TL where rnfn = grnfn-  instance NFData  TL where rnf  = genericRnf--  data TM = M1 Bool-    deriving (Show,Generic,Typeable)-  instance NFDataP TM where rnfp = grnfp-  instance NFDataN TM where rnfn = grnfn-  instance NFData  TM where rnf  = genericRnf--  deriveGeneric ''TL-  deriveGeneric ''TM--#if 1-  expTL_1 = L1 (M1 True) 5.6-  expTL_2 = L1 (M1 __) 5.6-  expTL_3 = L1 __ 5.6-  expTL_4 = L1 (M1 True) __--  getL :: TL -> String-  getL (L1 (M1 _) f) = show f-  getL _ = "getL-!"-  getL' :: TL -> String-  getL' (L1 (M1 b) _) = show b-  getL' _ = "getL'-!"-#else-  expTL_1 = L1 5.6 (M1 True)-  expTL_2 = L1 5.6 (M1 __)-  expTL_3 = L1 5.6 __-  expTL_4 = L1 __ (M1 True)--  getL :: TL -> String-  getL (L1 f (M1 _)) = show f-  getL _ = "getL-!"-  getL' :: TL -> String-  getL' (L1 _ (M1 b)) = show b-  getL' _ = "getL'-!"-#endif--#endif----------------------------------------------------------------------------------
− test/Main.hs 
@@ -1,36 +0,0 @@-----------------------------------------------------------------------------------  module Main ( main ) where-----------------------------------------------------------------------------------  import Foo----import     Control.DeepSeq.Generics-  import Control.DeepSeq.Bounded hiding ( F )-  import Control.DeepSeq.Bounded.Generics--  import GHC.Generics---import GHC.Generics ( Generic )--  import Data.Maybe--  import Control.Exception---import Control.Monad ( guard )-  import Data.Typeable ( Typeable )-  import Data.Typeable ( typeOf )----import Util ( spoor )-  import Debug.Trace ( trace )--  import System.IO.Unsafe ( unsafePerformIO )--  import Blah ( run_tests )-----------------------------------------------------------------------------------  main = run_tests----------------------------------------------------------------------------------
− test/Suite.hs 
@@ -1,54 +0,0 @@--{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric #-}--  module Main (main) where--#if 0--  import Control.Concurrent.MVar-  import Control.DeepSeq-  import Control.Exception-  import Control.Monad-  import Data.Bits-  import Data.IORef-  import Data.Typeable-  import Data.Word-  import GHC.Generics-  import System.IO.Unsafe (unsafePerformIO)--#if 0--- import Test.Framework (defaultMain, testGroup, testCase)-  import Test.Framework-  import Test.Framework.Providers.HUnit-#endif-  import Test.HUnit--#endif---- IUT-  import Control.DeepSeq.Bounded-#if ! HASKELL98_FRAGMENT-  import Control.DeepSeq.Bounded.Generics-#endif--  import Test.HUnit-  import System.Exit-  import System.IO ( stdout )-  import Debug.Trace ( trace )--  import qualified Tests------------------------------------------------  tests =-    "All" ~: [ Tests.tests-             ]--  main = do-            putStrLn "Running tests for deepseq-bounded..."---          putStrLn "Running tests for deepseq-bounded-generics..."-            counts <- runTestTT tests-            if failures counts > 0-              then exitFailure-                else exitSuccess-
− test/Tests.hs 
@@ -1,46 +0,0 @@---- Refer to /work/Projects/MiniProjects/SybShape/tests for--- more code in first HUnit example (which itself is still--- just fudging it)!--{-# LANGUAGE CPP #-}-----------------------------------------------------------------------------------  module Tests ( tests, main_tests ) where-----------------------------------------------------------------------------------  import Test.HUnit--  import System.IO.Unsafe ( unsafePerformIO )--#if HASKELL98_FRAGMENT-  import qualified Blah98 as Blah ( run_tests )-#else-  import qualified Blah           ( run_tests )-#endif-----------------------------------------------------------------------------------  main_tests :: IO Int-  main_tests = do-    Blah.run_tests-    return 0------------------------------------------------------------------------------------- XXX A better way to "fail on purpose" is to have the test--- return ExitFailure, no?...---tests = (unsafePerformIO main_tests == output) ~? "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!"  -- yeah but it wasn't printed-  tests = unsafePerformIO-            ( do n <- main_tests-                 putStrLn "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!\n"-                 return n )-            ~=? output-  output = 1::Int  -- force test to fail! (so we see the output!)---output = 0::Int---output = ()----------------------------------------------------------------------------------
− test/Util.hs 
@@ -1,112 +0,0 @@-----------------------------------------------------------------------------------{-  OPTIONS_GHC -O0 #-}  -- if want quick recompln.-{-  OPTIONS_GHC -package ghc #-}  -- (done via command-line/cabal)-{-# LANGUAGE CPP #-}--#define USE_ANSI_COLOUR_TERMINAL 0-----------------------------------------------------------------------------------  module Util (--    show_list ,-    trace ,-    trace_ ,-    trace' ,-    myTrace ,-    myTrace' ,-    spoor ,-    spoor' ,-    spoorf ,-#if 0-    spoorNF ,-#endif-    trayceIO ,--  ) where-----------------------------------------------------------------------------------  import System.IO--  import Data.List ( intersperse )--#if 0-  import Control.DeepSeq.Generics ( genericRnf )-  import Control.DeepSeq.Generics ( force )-  import Control.DeepSeq.Generics ( NFData(..) )-#endif--  import System.IO.Unsafe ( unsafePerformIO )  -- XXX for tracing only-----------------------------------------------------------------------------------  show_list lst = concat $ intersperse "\n" $ map show lst-----------------------------------------------------------------------------------  {-# NOINLINE trace #-}-  trace :: String -> a -> a-  trace s a = x `seq` a-   where x = unsafePerformIO $ do hPutStr stdout (s++"\n") ; hFlush stdout--  {-# NOINLINE trace_ #-}-  trace_ :: String -> a -> a-  trace_ s a = a--  {-# NOINLINE trace' #-}-  trace' :: String -> a -> a-  trace' s a = x `seq` a-   where x = unsafePerformIO $ do hPutStr stdout s ; hFlush stdout--  {-# NOINLINE myTrace #-}-  myTrace :: String -> a -> a-  myTrace s a = x `seq` a-   where x = unsafePerformIO $ do hPutStr stderr (s++"\n") ; hFlush stderr--  {-# NOINLINE myTrace' #-}-  myTrace' :: String -> a -> a-  myTrace' s a = x `seq` a-   where x = unsafePerformIO $ do hPutStr stderr s ; hFlush stderr--  -- These work reasonably well, but sometimes string's-  -- pile up, and then show expr's follow.  spoorNF is-  -- provided for these cases...--  {-# NOINLINE spoor #-}-  spoor :: Show a => String -> a -> a-  spoor string expr = unsafePerformIO $ do-    trayceIO $ string ++ show expr ++ "\n"-    return expr--  {-# NOINLINE spoor' #-}-  spoor' :: Show a => String -> a -> a-  spoor' string expr = unsafePerformIO $ do-    trayceIO $ string ++ show expr-    return expr--  {-# NOINLINE spoorf #-}-  spoorf :: Show b => String -> (a -> b) -> a -> a-  spoorf string f expr = unsafePerformIO $ do-    trayceIO $ string ++ show (f expr) ++ "\n"-    return expr--#if 0-  {-# NOINLINE spoorNF #-}-  spoorNF :: (Show b, NFData b) => String -> (a -> b) -> a -> a-  spoorNF string f expr = unsafePerformIO $ do-    let ss = string ++ show (f expr)-    trayceIO $ force ss-    return expr-#endif--  -- (There is no NOINLINE on this in Common.Trace.  And the-  -- code was templated from the Debug.Trace library.)-  trayceIO :: String -> IO ()-  trayceIO msg = do-    hPutStr stderr msg----------------------------------------------------------------------------------
+ tests/Blah.hs view
@@ -0,0 +1,27 @@++-------------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------++  module Blah ( run_tests ) where++-------------------------------------------------------------------------------++#if NEW_IMPROVED_PATTERN_GRAMMAR+-- XXX will find a solution not involving redundancy shortly.+-- There's no reason to offer the braces versions in tests actually.+-- But note that then the tests won't work in braces mode... Must warn.+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+#error To run the tests, you must build with the flag USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS set False (the default).+--import Blah_new_grammar_braces+#else+  import Blah_new_grammar+#endif+#else+  import Blah_old_grammar+#endif++-------------------------------------------------------------------------------+
+ tests/Blah98.hs view
@@ -0,0 +1,24 @@++-------------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------++  module Blah98 ( run_tests ) where++-------------------------------------------------------------------------------++#if NEW_IMPROVED_PATTERN_GRAMMAR+#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS+#error To run the tests, you must build with the flag USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS set False (the default).+--import Blah98_new_grammar_braces+#else+  import Blah98_new_grammar+#endif+#else+  import Blah98_old_grammar+#endif++-------------------------------------------------------------------------------+
+ tests/Blah98_new_grammar.hs view
@@ -0,0 +1,1102 @@++-------------------------------------------------------------------------------++-- This is a pared-down version of Blah.hs, for testing+-- deepseq-bounded when built with the HASKELL98_FRAGMENT+-- flag set.  See Blah.hs for comments and other "flesh".++-------------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------++#define FOCUS_TEST 0+#define USE_TRACE 0++-------------------------------------------------------------------------------++  module Blah98_new_grammar ( run_tests ) where++-------------------------------------------------------------------------------++--import Common+  import Foo++  import Control.DeepSeq.Bounded hiding ( F )++  import Data.Maybe++  import Control.Exception+--import Control.Monad ( guard )+  import Control.Monad ( replicateM )+  import Control.Monad ( when )++  import Data.Typeable ( Typeable )+  import Data.Typeable ( typeOf )++--import Util ( spoor )+  import Debug.Trace ( trace )+  import Control.DeepSeq++  import Data.Typeable ( Proxy(..) )++  import Data.List ( intercalate )++  import System.IO.Unsafe ( unsafePerformIO )++-------------------------------------------------------------------------------++  -- For convenience in GHCi interactive sessions:+  cp = compilePat+--cp = compilePat+  ip = intersectPats+  isp = subPat++-------------------------------------------------------------------------------++  run_tests :: IO Int+  run_tests = do+    putStr "\n"+    -- So can notice the start when scrollback, esp. in ghci reload/reruns.+--  replicateM 50 $ putStrLn "################################################################################"+    putStrLn "\nTesting.\n"++#if ! FOCUS_TEST++#if 1+--  let shp s = s ++ replicate (30 - length s) ' ' ++ show (compilePat s)+    let shp s = +         unsafePerformIO $+         catch+          ( return $! force $ s ++ replicate (30 - length s) ' ' ++ show (compilePat s) )+          ( \e -> do let err = show (e :: ErrorCall)+                     return err )++    putStrLn "Pattern                       Compiles to"+--  putStrLn $ shp ""  -- empty pattern syntax error+    putStrLn $ shp "*"  -- Node WW []+--  putStrLn $ shp "@"  -- Node WS []  -- obsoleted (use "." w/o children)+    putStrLn $ shp "."  -- Node I []  -- no parent to absorb (should be error)+    putStrLn $ shp "!"  -- Node WS []+--  putStrLn $ shp "**"  -- Node WS []  -- "disconnected pattern (not rooted)"+--  putStrLn $ shp "!*"  -- Node WS []  -- "disconnected pattern (not rooted)"+--  putStrLn $ shp "*!"  -- Node WS []  -- "disconnected pattern (not rooted)"+    putStrLn $ shp "()"  -- Node WR []+    putStrLn $ shp "(*)"  -- Node WR [Node WW []]+    putStrLn $ shp "(**)"  -- Node WR [Node WW [],Node WW []]+    putStrLn $ shp "(!*)"  -- Node WR [Node WS [],Node WW []]+    putStrLn $ shp "(.!)"  -- Node WR [Node I [],Node WS []]+    putStrLn $ shp "(.(.))"  -- Node WR [Node I []] with warning+    putStrLn $ shp "((.))"  -- Node WR [Node WR [Node I []]]+    putStrLn $ shp "(*.*.*.**.*.*)"  -- looks fine+    putStrLn $ shp "(*.(*.(*.)*)*(.*).*)"  -- warning about *{...}+    putStrLn $ shp "(*.(*.(*.)*)*.*)"+--  putStrLn $ shp "(*.(*.(*.)*)(*)(.*).*)"  -- }{ syntax error+-- [old comment for that last:] NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil],NodeM WW [],NodeM WW [],Nil,NodeM WW []],Nil,NodeM WW []] -- was wrong but is fixed I think+    putStrLn $ shp "(!*(*23*))"+#endif++#if 1+    let test_patterns10 = [+           (4,  "")  -- syntax error+         , (4,  "!..")  -- syntax error (disconnected pattern)+         , (1,  "(!..)")  -- fail+         , (5,  "(().().())")+         , (2,  "*")+         , (2,  "(***)")+         , (1,  "(...)")+         , (1,  "(*..)")+         , (2,  "(**.)")+         , (2,  "(..*)")++           -- Remember, [a] is a recursive binary ctor app!...+           -- The next four tests give instance errors for [a], but if+           -- testing expTG_* (GNFDataP/grnfp) then it's no longer a list...+         , (13, "(!(*.*).)")+         , (13, "(!(*...).)")+         , (13, "(!(*....).)")+         , (23, "(!(*....)!)")++         , (2,  "(!(*.)*)")+         , (1,  "(!(*.).)")+         , (1,  "(!(*(.*)).)")+         , (2,  "(!(*(*.)).)")+         , (13, "(!((!(.*))).)")  -- See above comment about [a] instance+         , (2,  "(.(!(!(.*))).)")++           -- (See Book, p.84.)+         , (1,  "(!(!(.(!!))).)")+         , (1,  "(!(!(.*)).)")+         , (1,  "(*(*(.*)).)")+         , (2,  "(..*)")+         , (2,  "(*.*)")+         , (1,  ":Tuple3:!(*(*(.*)).)")  -- oops...+         , (1,  ":(,,):!(*(*(.*)).)")+         , (2,  ":(,,):!(*(*(!*)).)")+         , (1,  ":Bool:!(***)")  -- XXX makes no sense (but works) -- oh well;+                                 -- this is an important point to note in+                                 -- docs/blog also...+         , (1,  ":Bool:*")+         , (2,  ":(,,):*")+         , (2,  "(*.!)")+         , (2,  "(*.:Bool:!)")  -- expect parse error+         , (1,  "(*.:Int:!)")  -- still need to implement . when not in type+         , (1,  "(*.:(,):!)")  -- still need to implement . when not in type+         , (1,  "(*.:Int:!)")  -- still need to implement . when not in type+         , (1,  "(*.:Int':!)")  -- still need to implement . when not in type+         , (1,  "(*.:Bool:.)")+         , (2,  "(*.:Int:.)")+         , (2,  "(*.:(,):.)")+         , (1,  "(*.:Bool:.)")+         , (2,  "(*.:Int:.)")+         , (2,  "(*.:(,):.)")+         , (1,  "(**2.)")+         , (2,  "(**3.)")+         , (1,  "(*:G2:.().)")+         , (1,  "(*:Int:.().)")+         ]+    doit14 True test_patterns10+--  doit10 True test_patterns10+#endif++#endif++---------------------------------------------++-- Later: Oh! Don't be silly -- it's all compile-time, and the+-- size or shape of the list is irrelevant -- which rules+-- will fire depends on THIS FILE'S SOURCE CODE (not it's+-- data, including static values)!+-- XXX Even with empty list, the same rule firings occur!...+-- If comment out this block however, the rules do not fire!+#if 1+    -- Testing composition and union:+    let test_patterns11 = [+           (1, "!", "!")+         , (2, "!", "*")+         , (2, "*", "!")+         , (2, "*", "*")+         , (2, "(!!!)", "(*!!)")+         , (2, "(*!!)", "(!!*)")+         , (2, "(!*.)", "(!.!)")+         ]+    doit11 True test_patterns11+#endif++#if 1+    -- Testing splicePats+    let test_patterns12 = [+#if 1+           (1, "!", [], [(0,"*")])+         , (1, "()", [], [(0,"*")])+         , (1, "!", [0], [(0,"*")])+         , (1, "(!!)", [], [(0,"*")])+         , (1, "(!!)", [0], [(0,"*")])+         , (1, "(!!)", [2], [(0,"*")])+         , (1, "(!!)", [], [(0,"*"),(0,".")])+         , (1, "(!!)", [], [(0,"*"),(1,".")])+         , (1, "(!!)", [], [(1,"."),(0,"*")])+         , (1, "(!!)", [], [(0,"*"),(2,".")])+         , (1, "(!!)", [], [(2,"*"),(2,"."),(2,".")])+         , (1, "(!!)", [], [(-1,"*")])+         , (1, "(!!)", [], [(0,"*")])+         , (1, "(!!)", [], [(1,"*")])+         , (1, "(!!)", [], [(2,"*")])+         , (1, "(!!)", [], [(3,"*")])+         , (1, "(!(!!)!)", [1], [(0,"*")])+         , (1, "(!(!!)!)", [1], [(0,"*3"),(1,"."),(2,"*")])+         , (1, "(!(!!)!)", [1,0], [(0,"*"),(0,".")])+         , (1, "((!!!)(()!)!)", [1], [(0,"*"),(0,".")])+         , (1, "((!!!)(()!)!)", [1,0], [(0,"*"),(0,".")])+         , (1, "((...)(().).)", [1,0], [(0,"*"),(0,".")])+         , (1, "(:(,,):!(...)(().).)", [1,0], [(0,"*"),(0,".")])+#else+           (1, "!", "()", [(0,"*")])+         , (1, "()", "()", [(0,"*")])+         , (1, "!", "(())", [(0,"*")])  -- added later, did uncover a bug! (irrefutable pattern failure)+         , (1, "(!!)", "()", [(0,"*")])+         , (1, "(!!)", "(())", [(0,"*")])+         , (1, "(!!)", "(!!())", [(0,"*")])+         , (1, "(!!)", "()", [(0,"*"),(0,".")])+         , (1, "(!!)", "()", [(0,"*"),(1,".")])+         , (1, "(!!)", "()", [(1,"."),(0,"*")])+         , (1, "(!!)", "()", [(0,"*"),(2,".")])+         , (1, "(!!)", "()", [(2,"*"),(2,"."),(2,".")])+         , (1, "(!!)", "()", [(-1,"*")])+         , (1, "(!!)", "()", [(0,"*")])+         , (1, "(!!)", "()", [(1,"*")])+         , (1, "(!!)", "()", [(2,"*")])+         , (1, "(!!)", "()", [(3,"*")])+         , (1, "(!(!!)!)", "(!()!)", [(0,"*")])+         , (1, "(!(!!)!)", "(!()!)", [(0,"*3"),(1,"."),(2,"*")])+         , (1, "(!(!!)!)", "(!(()!)!)", [(0,"*"),(0,".")])+         , (1, "(!(!!)!)", "(!(()))", [(0,"*"),(0,".")])+         , (1, "((!!!)(()!)!)", "(!())", [(0,"*"),(0,".")])+         , (1, "((!!!)(()!)!)", "(!(()))", [(0,"*"),(0,".")])+         , (1, "((...)(().).)", "(!(()))", [(0,"*"),(0,".")])+         , (1, "(:(,,):!(...)(().).)", "(!(()))", [(0,"*"),(0,".")])+#endif+         ]+    doit12 True test_patterns12+#endif++#if ! FOCUS_TEST++#if 1+    -- Testing anything else we can with a single function!+    -- (Getting sick of this cloning.)+    -- Functions are listed in (current) export order.+    -- Things still needing testing are >'d.+    -- Things tested but failing some tests have a *.+    -- +    -- XXX Wow does this ever look cleaner with "Pat" instead of "Pattern"!...+    -- Fortunately splicePats is already tested separately; the rest+    -- we need to test deal only in Pat args (or list of same), so+    -- we can pass a couple [Pat] to test13 along with an Int code+    -- to control delegation.+    --  1    unionPats       :: [ Pat ] -> Pat+    --  2    intersectPats   :: [ Pat ] -> Pat+    --  3    subPat          :: Pat -> Pat -> Bool+--  --  4    unionPatsStr    :: [ String ] -> String+    --  5    emptyPat        :: Pat+--  --  6    mkPat           :: forall d. Data d => d -> Pat+--  --  7    growPat         :: forall d. Data d => Pat -> d -> Pat+    --  8    shrinkPat       :: Pat -> Pat+    --  9    liftPats        :: [ Pat ] -> Pat+    -- 10    splicePats      :: Pat -> Pat -> [(Int, Pat)] -> Pat+    -- 11    isPath          :: Pat -> Bool+    let test_patterns13 = [+           ( 1, ["(!!!)", "(!.)"], "")+         , ( 2, ["(!!!)", "(!.)"], "")+         , ( 3, ["!", "!"], "True")+         , ( 3, [".", "."], "True")+         , ( 3, ["*", "*"], "True")+         , ( 3, ["!", "()"], "True")+         , ( 3, ["()", "!"], "False")+         , ( 3, ["()", "(!)"], "False")+         , ( 3, ["(!)", "(!)"], "True")+         , ( 3, ["(!)", "(!!)"], "False")+         , ( 3, ["(!)", "((!))"], "True")+         , ( 3, ["(!!)", "(!.)"], "False")+         , ( 3, ["(!.)", "(!!)"], "True")+         , ( 3, ["(!!)", "(!!!)"], "False")+         , ( 3, ["()", "(!!!)"], "False")+         , ( 3, ["!", "(*!.)"], "True")+         , ( 3, [".", "(*!.)"], "True")+         , ( 3, ["*", "(*!.)"], "False")+         , ( 3, ["*", "(*)"], "False")+         , ( 3, ["*", "(**)"], "False")+         , ( 4, ["(!!!)", "(!.)"], "")+         , ( 5, ["(!!!)", "(!.)"], "")+#if 0+         , ( 6, ["(!!!)", "(!.)"], "")+         -- matching against val = ([1,2,3::Int],(False,"foo"))+         -- mkPat val = "((!(!(!!)))(!(!(!(!!)))))"+#endif+#if 0+         , ( 7, ["((!(!!))(!(!!)))"], "")+         , ( 7, ["((!(!(!!)))(!(!(!!))))"], "")+         , ( 7, ["((!(!(!!)))(!(!(!(!!)))))"], "")+#endif+         , ( 8, ["((!(!(!!)))(!(!(!(!!)))))"], "")+         , ( 8, ["((!(!(!!)))(!(!(!!))))"], "")+         , ( 8, ["((!(!!))(!(!!)))"], "")+         , ( 8, ["((.(!!))(.(*3!)))"], "")+         , ( 8, ["((.!)(.!))"], "")+         , ( 8, ["(!!)"], "")+         , ( 8, ["!"], "")+         , ( 9, ["(!!!)", "(!.)"], "")+         , (10, ["(!!!)", "(!.)"], "")+         , (11, ["(!!!)", "(!.)"], "")+         ]+    putStrLn "===================================================="+    putStrLn "Testing miscellaneous NFDataP functions..."+    doit13 True test_patterns13+#endif++#if 1+    -- Testing fusion+    putStrLn "\nTesting fusion\n-fenable-rewrite-rules -O -ddump-rules -ddump-simpl-stats -ddump-rule-firings\n"+    let exp12 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+    let get12 (_,xs,_) = (xs!!2)+    putStrLn $ show $ get12 $ ( forcep ":Bool:*" . forcep ":Int:*" ) exp12+    putStrLn $ show $ get12 $ ( forcep ":Bool:*" . forcep_ (compilePat ":Int:*") ) exp12+    putStrLn $ show $ get12 $ ( forcep_ (compilePat ":Bool:*") . forcep ":Int:*" ) exp12+    putStrLn $ show $ get12 $ ( forcep_ (compilePat ":Bool:*") . forcep_ (compilePat ":Int:*") ) exp12+#endif++#if 1+    putStrLn $ intercalate "\n"+     [ ""+     , "expN_1 = [__] :: [Int]"+     , "expN_2 = [0,1,__,3] :: [Int]"+     , "expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)"+     , "expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+     , ""+     , "getN_1 xs = show $ ()"+--   , "getN_1 xs = show $ head xs"+--   , "getN_2 xs = show $ (xs!!1)"+     , "getN_2 xs = show $ (xs!!3)"+     , "getN_3 (_,xs,_) = show $ (xs!!2)"+     ]+    doit5 1 0 1 "" >>= putStrLn+    doit6 1 0 1 "" >>= putStrLn+    doit7 1 0 1 "" >>= putStrLn+    doit8 1 0 1 "" >>= putStrLn+#if 0+    doit9 >>= putStrLn  -- XXX broken (whatever it is)+#endif+#endif++#if 0+    s4 <- doit4 1 0 1 ""+    putStrLn s4+#endif++#if 0+    putStrLn $ ""+           ++ "expBase1 = ([True,False],3,Just \"fox\")         :: ([Bool],Int,Maybe String)\n"+           ++ "expBase2 = ([True,False],__,Just \"fox\")        :: ([Bool],Int,Maybe String)\n"+           ++ "expBase3 = ([True,__],3,Just \"fox\")            :: ([Bool],Int,Maybe String)\n"+           ++ "expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)\n"+           ++ "expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)\n"+           ++ "expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)\n"+           ++ "get1 ((x:_),_,_) = x           -- True\n"+           ++ "get2 (_,x,_) = x               -- 3\n"+           ++ "get3 (_,_,x) = fromJust x      -- \"fox\"\n"+           ++ "get4 (_,_,Just (x:_)) = x      -- 'f'\n"+    s1 <- doit1 1 1 1 ""+    putStrLn s1+#endif++#endif++    return 0++-------------------------------------------------------------------------------++  hline :: String+  hline = "----------------------------------------------------\n"+  hdline :: String+  hdline = "====================================================\n"++-------------------------------------------------------------------------------++  doit1 :: Int -> Int -> Int -> String -> IO String+  doit1 i j k acc+   -- this glitch (the exception that seemingly escapes my catch)+   -- happens just for these combos (and for all j):+-- | i == 3 && k == 4  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+-- | i == 3 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+-- | i == 3 && j < 4 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+   | k == 7  = return acc+   | j == 6  = doit1 1 1 (1+k) acc+   | i == 5  = doit1 1 (1+j) k acc+   | otherwise  = do+      fexp <- catch+               -- The semantics of the !'s here are not what they were,+               -- since forcing in some places. [?] But at least the+               -- first one seems definitely still needed...+               -- LATER: The second one is also needed, finally seen!+               -- (It is needed for a version of getE _ = "getee", only.)+               -- XXX I'm just not sure whether the second ! is better+               -- to leave in or leave out...+               ( return $! get $! forcen dep exp )+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+--    doit1 (1+i) j k $! force $ acc+      doit1 (1+i) j k $! acc+--    doit1 (1+i) j k $ acc+        ++ "( get" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k of+            1 -> expBase1+            2 -> expBase2+            3 -> expBase3+            4 -> expBase4+            5 -> expBase5+            6 -> expBase6+    get = case i of+           1 -> get1+           2 -> get2+--         3 -> unsafePerformIO . get3  -- yeesh!...+--         3 -> get3+           3 -> get3 (i,j,k)+           4 -> get4+    dep = j++#if 0+  -- XXX All this fuss to deal with the case that the+  -- entire argument m is undefined (or whatever is going+  -- for "undefined" at the moment...) -- but, none of+  -- the expBase[1-5] have this! ch.+  myFromJust :: Maybe a -> IO (Either () a)+  myFromJust m = do+                    putStrLn "Boo!"+                    catch+                      (myFromJust' m)+                      (\e -> do putStrLn $! show (e::BottomedOut)+                                putStrLn "HERE!"+                                return $! Left ())+  myFromJust' :: Maybe a -> IO (Either () a)+  myFromJust' Nothing = do+--                         throw BottomedOut+                           return $! Left ()+  myFromJust' (Just x) = return $! Right x+--myFromJust _ = throw BottomedOut+#endif++--------------------------------++#if 0+  doit2 :: Int -> Int -> Int -> String -> IO String+  doit2 i j k acc+-- | k == 2  = {- trace (show (i,j,k)) $ -} return acc+-- | k == 7  = return acc+   | k == 27  = return acc+-- | k == 21  = return acc+-- | k == 5  = return acc+-- | j == 15  = doit2 1 0 (1+k) acc+   | j == 11  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+-- | j == 8  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+-- | j == 3  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc+-- | i == 3  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc+#else+   | i == 2  = doit2 1 (1+j) k acc+-- | i == 3  = doit2 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+--             ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit2 (1+i) j k $! acc+        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expTB_" ++ show (k'-6) ++ " )  "+--      ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expBase" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            7 -> expBase7+            8 -> expBase8+            9 -> expBase9+            10 -> expBase10+            11 -> expBase11+            12 -> expBase12+            13 -> expBase13+            14 -> expBase14+            15 -> expBase15+            16 -> expBase16+            17 -> expBase17+            18 -> expBase18+            19 -> expBase19+            20 -> expBase20+            21 -> expBase20  -- fudge it!!+            22 -> expBase22+            23 -> expBase23+            24 -> expBase24+            25 -> expBase25+            26 -> expBase26+            27 -> expBase27+            28 -> expBase28+            29 -> expBase29+            30 -> expBase30+            31 -> expBase31+            32 -> expBase32+    get = case i of+           1 -> if k' >= 27 then getB_3 else getB_1+           2 -> getB_2+    dep = j'+    j' = j+--  j' = j+11+--  k' = k+26+    k' = k+6+#endif++#if 0+  doit3 :: Int -> Int -> Int -> String -> IO String+  doit3 i j k acc+   | k == 2  = return acc+   | j == 8  = {- trace (show (i,j,k)) $ -} doit3 1 1 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit3 1 (1+j) k acc+#else+   | i == 2  = doit3 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit3 (1+i) j k $! acc+        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            21 -> expBase21+    get = case i of+           1 -> getA+    dep = j'+    i' = i+    j' = j+    k' = k+20+#endif++#if 0+  doit4 :: Int -> Int -> Int -> String -> IO String+  doit4 i j k acc+-- | k == 2  = return acc+   | k == 4  = return acc+   | j == 8  = {- trace (show (i,j,k)) $ -} doit4 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit4 1 (1+j) k acc+#else+   | i == 2  = doit4 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit4 (1+i) j k $! acc+        ++ "( getE $ forcen " ++ show dep ++ " expTE_" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            1 -> expTE_1+            2 -> expTE_2+            3 -> expTE_3+    get = case i of+           1 -> getE+    dep = j'+    i' = i+    j' = j+    k' = k+#endif++-------------------------------------------------------------------------------++  doit5 :: Int -> Int -> Int -> String -> IO String+  doit5 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit5 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit5 1 (1+j) k acc+#else+   | i == 2  = doit5 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit5 (1+i) j k $! acc+        ++ "forcen " ++ show dep ++ " expN_" ++ show k' ++ " `seq` ()  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            1 -> expN_1+    get = case i of+           1 -> getN_1+    dep = j'+    i' = i+    j' = j+    k' = k++-------------------------------------------------------------------------------++  doit6 :: Int -> Int -> Int -> String -> IO String+  doit6 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit6 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit6 1 (1+j) k acc+#else+   | i == 2  = doit6 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit6 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_2+    get = case i of+           _ -> getN_2+    dep = j'+    i' = i+1+    j' = j+    k' = k+1++-------------------------------------------------------------------------------++  doit7 :: Int -> Int -> Int -> String -> IO String+  doit7 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit7 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit7 1 (1+j) k acc+#else+   | i == 2  = doit7 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit7 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_3+    get = case i of+           _ -> getN_3+    dep = j'+    i' = i+2+    j' = j+    k' = k+2++-------------------------------------------------------------------------------++  doit8 :: Int -> Int -> Int -> String -> IO String+  doit8 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit8 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit8 1 (1+j) k acc+#else+   | i == 2  = doit8 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit8 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_4+    get = case i of+           _ -> getN_3+    dep = j'+    i' = i+2+    j' = j+    k' = k+3++-------------------------------------------------------------------------------++#if 0++#if 0+  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+  patP_1 = Node (TR [typeOf ((__,__,__)::(Float, [Int], Bool))])+             [ Node (TR [typeOf (__::Bool)]) []+--           [ Node (TR [typeOf (__::Float)]) []+--           [ Node (NTR [typeOf (__::Bool)]) []+--           [ Node (NTR [typeOf (__::Float)]) []+--           , Node WS []+             , Node (TW [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) [ Node WS [], Node WS [] ]  -- why not?+             , Node WW []+--           , Node I []+             ]+  getP_1 (_,xs,_) = show $ (xs!!2)+#endif++  doit9 :: IO String+  doit9 = do+#if 0+    putStrLn $ intercalate "\n"+     [ ""+     , "expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+     , "patP_1 = Node (T [typeOf ((__,__,__)::(Float, [Int], Bool))])"+     , "           [ Node W []"+     , "           , Node (T [typeOf ([__]::[Int])]) []"+     , "           , Node I []"+     , "           ]"+     , "getP_1 (_,xs,_) = show $ (xs!!2)"+     ]+    putStrLn "getP_1 $ forcep patP_1 expP_1"+#endif+    s <- catch+             ( return $! getP_1 $! forcep patP_1 expP_1 )+--           ( return $! getP_2 $! forcep patP_2 expP_2 )+--           ( return $! getP_3 $! forcep patP_3 expP_3 )+             -- ErrorCall if use __ = undefined+             -- BottomedOut if use __ = throw BottomedOut+             (\e -> do let err = show (e :: ErrorCall)+--           (\e -> do let err = show (e :: BottomedOut)+                       return err)+    return s++#endif++-------------------------------------------------------------------------------++  doit10 :: Bool -> [(Int,String)] -> IO ()+  doit10 _ [] = do+                   putStrLn "----------------------------------------------------"+                   return ()+  doit10 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit10: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                 then do+                  putStrLn "===================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "===================================================="+                 else do+                  putStrLn "----------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                 then putStrLn $  "expected value           = " ++ expect+                 else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                 then putStrLn $  "expected value           = " ++ expect+                 else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit10 False t++-------------------------------------------------------------------------------++  doit11 :: Bool -> [(Int,String,String)] -> IO ()+  doit11 _ [] = do+                   putStrLn "----------------------------------------------------"+                   return ()+  doit11 b ((code,patstr1,patstr2):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit11: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let patstrU = showPat $ unionPats [compilePat patstr1, compilePat patstr2]+                let pat1 = compilePat patstr1+                let pat2 = compilePat patstr2+                let patU = unionPats [pat1,pat2]+                let get (_,xs,_) = show $ (xs!!2)+                if b+                 then do+                  putStrLn "===================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ ( forcep patstr2 . forcep patstr1 ) exp"+--                putStrLn "? = get $ ( forcep ( unionPatsStr [ patstr1, patstr2 ] ) ) exp"+                  putStrLn "? = get $! ( forcep_ ( unionPats [ pat1, pat2 ] ) ) exp"+                  putStrLn "(Results were more interesting with a previous semantics...)."+                  putStrLn "===================================================="+                 else do+                  putStrLn "----------------------------------------------------"+                putStrLn $ "patstr1                     = " ++ patstr1+                putStrLn $ "patstr2                     = " ++ patstr2+                putStrLn $ "patstrU                     = " ++ patstrU+                if code > 4+                 then putStrLn $  "expected value              = " ++ expect+                 else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat patstr1  = " ++ showPat pat1+                putStrLn $ "showPat.compilePat patstr2  = " ++ showPat pat2+                putStrLn $ "showPat.compilePat patstrU  = " ++ showPat patU+                if code <= 4+                 then putStrLn $  "expected value              = " ++ expect+                 else return ()+                putStr "actual value                = "+                let s1 = get $! ( forcep patstr2 . forcep patstr1 ) exp+                putStrLn s1+                putStr "actual value                = "+                let s2 = get $! forcep patstrU exp+#if 1+                let s3 = s2+#else+                putStrLn s2+                let s3 = get $! forcep_ ( unionPats [ pat1, pat2 ] ) exp+#endif+                return $! s3+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit11 False t++-------------------------------------------------------------------------------++  doit12 :: Bool -> [(Int,String,[Int],[(Int,String)])] -> IO ()+--doit12 :: Bool -> [(Int,String,String,[(Int,String)])] -> IO ()+  doit12 _ [] = do+                   return ()+  doit12 b ((code,patstr1,path,isibs'):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit12: unexpected code " ++ show code+    s <- catch+           ( do+                let target = compilePat patstr1+--              let path = compilePat patstr2+                let isibs = map (\ (x,y) -> (x,compilePat y)) isibs'+                if b+                 then do+                  putStr hdline+                  putStrLn "Testing splicePats."+                  putStr hline+                 else return ()+                putStrLn $ "target       " ++ patstr1+                putStrLn $ "path         " ++ show path+--              putStrLn $ "path         " ++ patstr2+                putStrLn $ "isibs        " ++ show isibs'+                let s1 = force $ showPat $ splicePats target path isibs+--              let s1 = showPat $! splicePats target path isibs+--              let s1 = showPat $ splicePats target path isibs+                putStr "result       "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    if null t then return () else putStr hline+    doit12 False t++-------------------------------------------------------------------------------++  doit13 :: Bool -> [(Int,[String],String)] -> IO ()+  doit13 _ [] = do+                   putStr hline+                   return ()+  doit13 b ((code,patstrlst,expectstr):t) = do+    s <- catch+           ( do+                s1 <- case code of+-- Where were they done already?+-- Oh, in doit11 and doit12 above...+                       1 -> error $ hline ++ "unionPats test already done test13-1!"+--                     4 -> error $ hline ++ "unionPatsStr test already done test13-4!"+                       10 -> error $ hline ++ "splicePats test already done test13-10!"+                       11 -> error $ hline ++ "isPath test already done test13-11!"+    --  1    unionPats       :: [ Pat ] -> Pat+    --  2  * intersectPats   :: [ Pat ] -> Pat+    --  3  * subPat          :: Pat -> Pat -> Bool+--  --  4    unionPatsStr    :: [ String ] -> String+    --  5  * emptyPat        :: Pat+--  --  6  * mkPat           :: forall d. Data d => d -> Pat+--  --  7  * growPat         :: forall d. Data d => Pat -> d -> Pat+    --  8  * shrinkPat       :: Pat -> Pat+    --  9  * liftPats        :: [ Pat ] -> Pat+    -- 10    splicePats      :: Pat -> Pat -> [(Int, Pat)] -> Pat+    -- 11    isPath          :: Pat -> Bool+                       2 -> do+                               let patA = patstrlst!!0+                               let patB = patstrlst!!1+                               putStr hline+                               putStrLn "Testing      intersectPats [patA, patB]"+                               putStrLn $ "patA         " ++ patA+                               putStrLn $ "patB         " ++ patB+                               putStr $ "result       "+                               let s1 = force $ showPat $ intersectPats [compilePat patA, compilePat patB]+                               return s1+                       3 -> do+                               let patA = patstrlst!!0+                               let patB = patstrlst!!1+                               putStr hline+                               putStrLn "Testing      subPat patA patB"+                               putStrLn $ "patA         " ++ patA+                               putStrLn $ "patB         " ++ patB+                               let s1 = force $ show $ subPat (compilePat patA) (compilePat patB)+                               if s1 /= expectstr+                                then do putStrLn $ "expect       " ++ expectstr+                                        putStr $ "result       "+                                else putStr $ "as expected  "+                               return s1+                       5 -> do+                               putStr hline+                               putStrLn "Testing      emptyPat"+                               putStr $ "result       "+                               let s1 = force $ showPat $ emptyPat+                               return s1+                       6 -> do+#if 0+                               putStr hline+                               putStrLn "Testing      mkPat ([1,2,3],(False,\"foo\"))"+                               putStr $ "result       "+                               let s1 = force $ showPat $ mkPat ([1,2,3::Int],(False,"foo"))+                               return s1+#else+                               return ""+#endif+                       7 -> do+#if 0+                               let patA = patstrlst!!0+                               putStr hline+                               putStrLn "Testing      growPat patA ([1,2,3],(False,\"foo\"))"+                               putStrLn $ "patA         " ++ patA+                               putStr $ "result       "+                               let s1 = force $ showPat $ growPat (compilePat patA) ([1,2,3::Int],(False,"foo"))+                               return s1+#else+                               return ""+#endif+                       8 -> do+                               let patA = patstrlst!!0+                               putStr hline+                               putStrLn "Testing      shrinkPat patA"+                               putStrLn $ "patA         " ++ patA+                               putStr $ "result       "+                               let s1 = force $ showPat $ shrinkPat (compilePat patA)+                               return s1+                       9 -> do+                               putStr hline+                               putStrLn "Testing      liftPats patstrlst"+                               putStrLn $ "patstrs      " ++ show patstrlst+                               putStr $ "result       "+                               let s1 = force $ showPat $ liftPats $ map compilePat patstrlst+                               return s1+                       _ -> error $ "doit13: unexpected code " ++ show code+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit13 False t++-------------------------------------------------------------------------------++  -- This is an adaptation of doit10 to user-defined datatypes,+  -- for testing GNFDataP, which is finally within reach thanks+  -- to SOP!+  doit14 :: Bool -> [(Int,String)] -> IO ()+  doit14 _ [] = do+                   putStrLn "----------------------------------------------------"+                   return ()+  doit14 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit14: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                 then do+                  putStrLn "===================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "===================================================="+                 else do+                  putStrLn "----------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                 then putStrLn $  "expected value           = " ++ expect+                 else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                 then putStrLn $  "expected value           = " ++ expect+                 else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit14 False t++-------------------------------------------------------------------------------+
+ tests/Blah98_old_grammar.hs view
@@ -0,0 +1,1102 @@++-------------------------------------------------------------------------------++-- This is a pared-down version of Blah.hs, for testing+-- deepseq-bounded when built with the HASKELL98_FRAGMENT+-- flag set.  See Blah.hs for comments and other "flesh".++-------------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------++#define FOCUS_TEST 0+#define USE_TRACE 0++-------------------------------------------------------------------------------++  module Blah98_old_grammar ( run_tests ) where++-------------------------------------------------------------------------------++  import Foo++  import Control.DeepSeq.Bounded hiding ( F )++  import Data.Maybe++  import Control.Exception+--import Control.Monad ( guard )+  import Control.Monad ( replicateM )+  import Control.Monad ( when )++  import Data.Typeable ( Typeable )+  import Data.Typeable ( typeOf )++--import Util ( spoor )+  import Debug.Trace ( trace )+  import Control.DeepSeq++  import Data.Typeable ( Proxy(..) )++  import Data.List ( intercalate )++  import System.IO.Unsafe ( unsafePerformIO )++-------------------------------------------------------------------------------++  -- For convenience in GHCi interactive sessions:+  cp = compilePat+  ip = intersectPats+  isp = subPat++-------------------------------------------------------------------------------++  run_tests :: IO Int+  run_tests = do+    putStr "\n"+    -- So can notice the start when scrollback, esp. in ghci reload/reruns.+--  replicateM 50 $ putStrLn "################################################################################"+    putStrLn "\nTesting.\n"++#if ! FOCUS_TEST++#if 1+--  let shp s = s ++ replicate (30 - length s) ' ' ++ show (compilePat s)+    let shp s = +         unsafePerformIO $+         catch+          ( return $! force $ s ++ replicate (30 - length s) ' ' ++ show (compilePat s) )+          ( \e -> do let err = show (e :: ErrorCall)+                     return err )++    putStrLn "Pattern                       Compiles to"+--  putStrLn $ shp ""  -- empty pattern syntax error+    putStrLn $ shp "*"  -- Node WW []+--  putStrLn $ shp "@"  -- Node WS []  -- obsoleted (use "." w/o children)+    putStrLn $ shp "#"  -- Node I []  -- no parent to absorb (should be error)+    putStrLn $ shp "."  -- Node WS []+--  putStrLn $ shp "**"  -- Node WS []  -- "disconnected pattern (not rooted)"+--  putStrLn $ shp ".*"  -- Node WS []  -- "disconnected pattern (not rooted)"+--  putStrLn $ shp "*."  -- Node WS []  -- "disconnected pattern (not rooted)"+    putStrLn $ shp ".{}"  -- Node WR []+    putStrLn $ shp ".{*}"  -- Node WR [Node WW []]+    putStrLn $ shp ".{**}"  -- Node WR [Node WW [],Node WW []]+    putStrLn $ shp ".{.*}"  -- Node WR [Node WS [],Node WW []]+    putStrLn $ shp ".{#.}"  -- Node WR [Node I [],Node WS []]+    putStrLn $ shp ".{#{#}}"  -- Node WR [Node I []] with warning+    putStrLn $ shp ".{.{#}}"  -- Node WR [Node WR [Node I []]]+    putStrLn $ shp ".{*#*#*#**#*#*}"  -- looks fine+    putStrLn $ shp ".{*#.{*#.{*#}*}*{#*}#*}"  -- warning about *{...}+    putStrLn $ shp ".{*#.{*#.{*#}*}*#*}"+--  putStrLn $ shp ".{*#.{*#.{*#}*}{*}{#*}#*}"  -- }{ syntax error+-- [old comment for that last:] NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil],NodeM WW [],NodeM WW [],Nil,NodeM WW []],Nil,NodeM WW []] -- was wrong but is fixed I think+    putStrLn $ shp ".{.*.{*23*}}"+#endif++#if 1+    let test_patterns10 = [+           (4,  "")  -- syntax error+         , (4,  ".##")  -- syntax error (disconnected pattern)+         , (1,  ".{.##}")  -- fail+         , (5,  ".{.{}#{}#{}}")+         , (2,  "*")+         , (2,  ".{***}")+         , (1,  ".{###}")+         , (1,  ".{*##}")+         , (2,  ".{**#}")+         , (2,  ".{##*}")++           -- Remember, [a] is a recursive binary ctor app!...+           -- The next four tests give instance errors for [a], but if+           -- testing expTG_* (GNFDataP/grnfp) then it's no longer a list...+         , (13, ".{..{*#*}#}")+         , (13, ".{..{*###}#}")+         , (13, ".{..{*####}#}")+         , (23, ".{..{*####}.}")++         , (2,  ".{..{*#}*}")+         , (1,  ".{..{*#}#}")+         , (1,  ".{..{*.{#*}}#}")+         , (2,  ".{..{*.{*#}}#}")+         , (13, ".{..{.{..{#*}}}#}")  -- See above comment about [a] instance+         , (2,  ".{#.{..{..{#*}}}#}")++           -- (See Book, p.84.)+         , (1,  ".{..{..{#.{..}}}#}")+         , (1,  ".{..{..{#*}}#}")+         , (1,  ".{*.{*.{#*}}#}")+         , (2,  ".{##*}")+         , (2,  ".{*#*}")+         , (1,  ".:Tuple3{*.{*.{#*}}#}")  -- oops...+         , (1,  ".:(,,){*.{*.{#*}}#}")+         , (2,  ".:(,,){*.{*.{.*}}#}")+         , (1,  ".:Bool{***}")  -- XXX makes no sense (but works) -- oh well;+                                  -- this is an important point to note in+                                  -- docs/blog also...+         , (1,  "*:Bool")+         , (2,  "*:(,,)")+         , (2,  ".{*#.}")+         , (2,  ".{*#.:Bool}")  -- XXX this gives parse error on 2nd .+         , (2,  ".{*#.:Bool{}}")  -- XXX this gives no parse error; if it does what+                                  -- it says, it will only match a childless Bool node+         , (1,  ".{*#.:Int{}}")  -- still need to implement # when not in type+         , (1,  ".{*#.:(,){}}")  -- still need to implement # when not in type+         , (1,  ".{*#.:Int }")  -- still need to implement # when not in type+         , (1,  ".{*#.:Int'}")  -- still need to implement # when not in type+         , (1,  ".{*##:Bool}")+         , (2,  ".{*##:Int}")+         , (2,  ".{*##:(,)}")+         , (1,  ".{*##:Bool{}}")+         , (2,  ".{*##:Int{}}")+         , (2,  ".{*##:(,){}}")+         , (1,  ".{**2#}")+         , (2,  ".{**3#}")+         , (1,  ".{*#:G2{}#}")+         , (1,  ".{*#:Int{}#}")+         ]+    doit14 True test_patterns10+--  doit10 True test_patterns10+#endif++#endif++---------------------------------------------++-- Later: Oh! Don't be silly -- it's all compile-time, and the+-- size or shape of the list is irrelevant -- which rules+-- will fire depends on THIS FILE'S SOURCE CODE (not it's+-- data, including static values)!+-- XXX Even with empty list, the same rule firings occur!...+-- If comment out this block however, the rules do not fire!+#if 1+    -- Testing composition and union:+    let test_patterns11 = [+           (1, ".", ".")+         , (2, ".", "*")+         , (2, "*", ".")+         , (2, "*", "*")+         , (2, ".{...}", ".{*..}")+         , (2, ".{*..}", ".{..*}")+         , (2, ".{.*#}", ".{.#.}")+         ]+    doit11 True test_patterns11+#endif++#if 1+    -- Testing splicePats+    let test_patterns12 = [+#if 1+           (1, ".", [], [(0,"*")])+         , (1, ".{}", [], [(0,"*")])+         , (1, ".", [0], [(0,"*")])+         , (1, ".{..}", [], [(0,"*")])+         , (1, ".{..}", [0], [(0,"*")])+         , (1, ".{..}", [2], [(0,"*")])+         , (1, ".{..}", [], [(0,"*"),(0,"#")])+         , (1, ".{..}", [], [(0,"*"),(1,"#")])+         , (1, ".{..}", [], [(1,"#"),(0,"*")])+         , (1, ".{..}", [], [(0,"*"),(2,"#")])+         , (1, ".{..}", [], [(2,"*"),(2,"#"),(2,"#")])+         , (1, ".{..}", [], [(-1,"*")])+         , (1, ".{..}", [], [(0,"*")])+         , (1, ".{..}", [], [(1,"*")])+         , (1, ".{..}", [], [(2,"*")])+         , (1, ".{..}", [], [(3,"*")])+         , (1, ".{..{..}.}", [1], [(0,"*")])+         , (1, ".{..{..}.}", [1], [(0,"*3"),(1,"#"),(2,"*")])+         , (1, ".{..{..}.}", [1,0], [(0,"*"),(0,"#")])+         , (1, ".{.{...}.{.{}.}.}", [1], [(0,"*"),(0,"#")])+         , (1, ".{.{...}.{.{}.}.}", [1,0], [(0,"*"),(0,"#")])+         , (1, ".{.{###}.{.{}#}#}", [1,0], [(0,"*"),(0,"#")])+         , (1, ".{.:(,,){###}.{.{}#}#}", [1,0], [(0,"*"),(0,"#")])+#else+           (1, ".", ".{}", [(0,"*")])+         , (1, ".{}", ".{}", [(0,"*")])+         , (1, ".", ".{.{}}", [(0,"*")])  -- added later, did uncover a bug! (irrefutable pattern failure)+         , (1, ".{..}", ".{}", [(0,"*")])+         , (1, ".{..}", ".{.{}}", [(0,"*")])+         , (1, ".{..}", ".{...{}}", [(0,"*")])+         , (1, ".{..}", ".{}", [(0,"*"),(0,"#")])+         , (1, ".{..}", ".{}", [(0,"*"),(1,"#")])+         , (1, ".{..}", ".{}", [(1,"#"),(0,"*")])+         , (1, ".{..}", ".{}", [(0,"*"),(2,"#")])+         , (1, ".{..}", ".{}", [(2,"*"),(2,"#"),(2,"#")])+         , (1, ".{..}", ".{}", [(-1,"*")])+         , (1, ".{..}", ".{}", [(0,"*")])+         , (1, ".{..}", ".{}", [(1,"*")])+         , (1, ".{..}", ".{}", [(2,"*")])+         , (1, ".{..}", ".{}", [(3,"*")])+         , (1, ".{..{..}.}", ".{..{}.}", [(0,"*")])+         , (1, ".{..{..}.}", ".{..{}.}", [(0,"*3"),(1,"#"),(2,"*")])+         , (1, ".{..{..}.}", ".{..{.{}.}.}", [(0,"*"),(0,"#")])+         , (1, ".{..{..}.}", ".{..{.{}}}", [(0,"*"),(0,"#")])+         , (1, ".{.{...}.{.{}.}.}", ".{..{}}", [(0,"*"),(0,"#")])+         , (1, ".{.{...}.{.{}.}.}", ".{..{.{}}}", [(0,"*"),(0,"#")])+         , (1, ".{.{###}.{.{}#}#}", ".{..{.{}}}", [(0,"*"),(0,"#")])+         , (1, ".{.:(,,){###}.{.{}#}#}", ".{..{.{}}}", [(0,"*"),(0,"#")])+#endif+         ]+    doit12 True test_patterns12+#endif++#if ! FOCUS_TEST++#if 1+    -- Testing anything else we can with a single function!+    -- (Getting sick of this cloning.)+    -- Functions are listed in (current) export order.+    -- Things still needing testing are >'d.+    -- Things tested but failing some tests have a *.+    -- +    -- XXX Wow does this ever look cleaner with "Pat" instead of "Pattern"!...+    -- Fortunately splicePats is already tested separately; the rest+    -- we need to test deal only in Pat args (or list of same), so+    -- we can pass a couple [Pat] to test13 along with an Int code+    -- to control delegation.+    --  1    unionPats       :: [ Pat ] -> Pat+    --  2    intersectPats   :: [ Pat ] -> Pat+    --  3    subPat          :: Pat -> Pat -> Bool+--  --  4    unionPatsStr    :: [ String ] -> String+    --  5    emptyPat        :: Pat+--  --  6    mkPat           :: forall d. Data d => d -> Pat+--  --  7    growPat         :: forall d. Data d => Pat -> d -> Pat+    --  8    shrinkPat       :: Pat -> Pat+    --  9    liftPats        :: [ Pat ] -> Pat+    -- 10    splicePats      :: Pat -> Pat -> [(Int, Pat)] -> Pat+    -- 11    isPath          :: Pat -> Bool+    let test_patterns13 = [+           ( 1, [".{...}", ".{.#}"], "")+         , ( 2, [".{...}", ".{.#}"], "")+         , ( 3, [".", "."], "True")+         , ( 3, ["#", "#"], "True")+         , ( 3, ["*", "*"], "True")+         , ( 3, [".", ".{}"], "True")+         , ( 3, [".{}", "."], "False")+         , ( 3, [".{}", ".{.}"], "False")+         , ( 3, [".{.}", ".{.}"], "True")+         , ( 3, [".{.}", ".{..}"], "False")+         , ( 3, [".{.}", ".{.{.}}"], "True")+         , ( 3, [".{..}", ".{.#}"], "False")+         , ( 3, [".{.#}", ".{..}"], "True")+         , ( 3, [".{..}", ".{...}"], "False")+         , ( 3, [".{}", ".{...}"], "False")+         , ( 3, [".", ".{*.#}"], "True")+         , ( 3, ["#", ".{*.#}"], "True")+         , ( 3, ["*", ".{*.#}"], "False")+         , ( 3, ["*", ".{*}"], "False")+         , ( 3, ["*", ".{**}"], "False")+         , ( 4, [".{...}", ".{.#}"], "")+         , ( 5, [".{...}", ".{.#}"], "")+#if 0+         , ( 6, [".{...}", ".{.#}"], "")+         -- matching against val = ([1,2,3::Int],(False,"foo"))+         -- mkPat val = ".{.{..{..{..}}}.{..{..{..{..}}}}}"+#endif+#if 0+         , ( 7, [".{.{..{..}}.{..{..}}}"], "")+         , ( 7, [".{.{..{..{..}}}.{..{..{..}}}}"], "")+         , ( 7, [".{.{..{..{..}}}.{..{..{..{..}}}}}"], "")+#endif+         , ( 8, [".{.{..{..{..}}}.{..{..{..{..}}}}}"], "")+         , ( 8, [".{.{..{..{..}}}.{..{..{..}}}}"], "")+         , ( 8, [".{.{..{..}}.{..{..}}}"], "")+         , ( 8, [".{.{#.{..}}.{#.{*3.}}}"], "")+         , ( 8, [".{.{#.}.{#.}}"], "")+         , ( 8, [".{..}"], "")+         , ( 8, ["."], "")+         , ( 9, [".{...}", ".{.#}"], "")+         , (10, [".{...}", ".{.#}"], "")+         , (11, [".{...}", ".{.#}"], "")+         ]+    putStrLn "===================================================="+    putStrLn "Testing miscellaneous NFDataP functions..."+    doit13 True test_patterns13+#endif++#if 1+    -- Testing fusion+    putStrLn "\nTesting fusion\n-fenable-rewrite-rules -O -ddump-rules -ddump-simpl-stats -ddump-rule-firings\n"+    let exp12 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+    let get12 (_,xs,_) = (xs!!2)+    putStrLn $ show $ get12 $ ( forcep ".:Bool{}" . forcep ".:Int{}" ) exp12+    putStrLn $ show $ get12 $ ( forcep ".:Bool{}" . forcep_ (compilePat ".:Int{}") ) exp12+    putStrLn $ show $ get12 $ ( forcep_ (compilePat ".:Bool{}") . forcep ".:Int{}" ) exp12+    putStrLn $ show $ get12 $ ( forcep_ (compilePat ".:Bool{}") . forcep_ (compilePat ".:Int{}") ) exp12+#endif++#if 1+    putStrLn $ intercalate "\n"+     [ ""+     , "expN_1 = [__] :: [Int]"+     , "expN_2 = [0,1,__,3] :: [Int]"+     , "expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)"+     , "expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+     , ""+     , "getN_1 xs = show $ ()"+--   , "getN_1 xs = show $ head xs"+--   , "getN_2 xs = show $ (xs!!1)"+     , "getN_2 xs = show $ (xs!!3)"+     , "getN_3 (_,xs,_) = show $ (xs!!2)"+     ]+    doit5 1 0 1 "" >>= putStrLn+    doit6 1 0 1 "" >>= putStrLn+    doit7 1 0 1 "" >>= putStrLn+    doit8 1 0 1 "" >>= putStrLn+#if 0+    doit9 >>= putStrLn  -- XXX broken (whatever it is)+#endif+#endif++#if 0+    s4 <- doit4 1 0 1 ""+    putStrLn s4+#endif++#if 0+    putStrLn $ ""+           ++ "expBase1 = ([True,False],3,Just \"fox\")         :: ([Bool],Int,Maybe String)\n"+           ++ "expBase2 = ([True,False],__,Just \"fox\")        :: ([Bool],Int,Maybe String)\n"+           ++ "expBase3 = ([True,__],3,Just \"fox\")            :: ([Bool],Int,Maybe String)\n"+           ++ "expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)\n"+           ++ "expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)\n"+           ++ "expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)\n"+           ++ "get1 ((x:_),_,_) = x           -- True\n"+           ++ "get2 (_,x,_) = x               -- 3\n"+           ++ "get3 (_,_,x) = fromJust x      -- \"fox\"\n"+           ++ "get4 (_,_,Just (x:_)) = x      -- 'f'\n"+    s1 <- doit1 1 1 1 ""+    putStrLn s1+#endif++#endif++    return 0++-------------------------------------------------------------------------------++  hline :: String+  hline = "----------------------------------------------------\n"+  hdline :: String+  hdline = "====================================================\n"++-------------------------------------------------------------------------------++  doit1 :: Int -> Int -> Int -> String -> IO String+  doit1 i j k acc+   -- this glitch (the exception that seemingly escapes my catch)+   -- happens just for these combos (and for all j):+-- | i == 3 && k == 4  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+-- | i == 3 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+-- | i == 3 && j < 4 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+   | k == 7  = return acc+   | j == 6  = doit1 1 1 (1+k) acc+   | i == 5  = doit1 1 (1+j) k acc+   | otherwise  = do+      fexp <- catch+               -- The semantics of the !'s here are not what they were,+               -- since forcing in some places. [?] But at least the+               -- first one seems definitely still needed...+               -- LATER: The second one is also needed, finally seen!+               -- (It is needed for a version of getE _ = "getee", only.)+               -- XXX I'm just not sure whether the second ! is better+               -- to leave in or leave out...+               ( return $! get $! forcen dep exp )+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+--    doit1 (1+i) j k $! force $ acc+      doit1 (1+i) j k $! acc+--    doit1 (1+i) j k $ acc+        ++ "( get" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k of+            1 -> expBase1+            2 -> expBase2+            3 -> expBase3+            4 -> expBase4+            5 -> expBase5+            6 -> expBase6+    get = case i of+           1 -> get1+           2 -> get2+--         3 -> unsafePerformIO . get3  -- yeesh!...+--         3 -> get3+           3 -> get3 (i,j,k)+           4 -> get4+    dep = j++#if 0+  -- XXX All this fuss to deal with the case that the+  -- entire argument m is undefined (or whatever is going+  -- for "undefined" at the moment...) -- but, none of+  -- the expBase[1-5] have this! ch.+  myFromJust :: Maybe a -> IO (Either () a)+  myFromJust m = do+                    putStrLn "Boo!"+                    catch+                      (myFromJust' m)+                      (\e -> do putStrLn $! show (e::BottomedOut)+                                putStrLn "HERE!"+                                return $! Left ())+  myFromJust' :: Maybe a -> IO (Either () a)+  myFromJust' Nothing = do+--                         throw BottomedOut+                           return $! Left ()+  myFromJust' (Just x) = return $! Right x+--myFromJust _ = throw BottomedOut+#endif++--------------------------------++#if 0+  doit2 :: Int -> Int -> Int -> String -> IO String+  doit2 i j k acc+-- | k == 2  = {- trace (show (i,j,k)) $ -} return acc+-- | k == 7  = return acc+   | k == 27  = return acc+-- | k == 21  = return acc+-- | k == 5  = return acc+-- | j == 15  = doit2 1 0 (1+k) acc+   | j == 11  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+-- | j == 8  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+-- | j == 3  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc+-- | i == 3  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc+#else+   | i == 2  = doit2 1 (1+j) k acc+-- | i == 3  = doit2 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+--             ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit2 (1+i) j k $! acc+        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expTB_" ++ show (k'-6) ++ " )  "+--      ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expBase" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            7 -> expBase7+            8 -> expBase8+            9 -> expBase9+            10 -> expBase10+            11 -> expBase11+            12 -> expBase12+            13 -> expBase13+            14 -> expBase14+            15 -> expBase15+            16 -> expBase16+            17 -> expBase17+            18 -> expBase18+            19 -> expBase19+            20 -> expBase20+            21 -> expBase20  -- fudge it!!+            22 -> expBase22+            23 -> expBase23+            24 -> expBase24+            25 -> expBase25+            26 -> expBase26+            27 -> expBase27+            28 -> expBase28+            29 -> expBase29+            30 -> expBase30+            31 -> expBase31+            32 -> expBase32+    get = case i of+           1 -> if k' >= 27 then getB_3 else getB_1+           2 -> getB_2+    dep = j'+    j' = j+--  j' = j+11+--  k' = k+26+    k' = k+6+#endif++#if 0+  doit3 :: Int -> Int -> Int -> String -> IO String+  doit3 i j k acc+   | k == 2  = return acc+   | j == 8  = {- trace (show (i,j,k)) $ -} doit3 1 1 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit3 1 (1+j) k acc+#else+   | i == 2  = doit3 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit3 (1+i) j k $! acc+        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            21 -> expBase21+    get = case i of+           1 -> getA+    dep = j'+    i' = i+    j' = j+    k' = k+20+#endif++#if 0+  doit4 :: Int -> Int -> Int -> String -> IO String+  doit4 i j k acc+-- | k == 2  = return acc+   | k == 4  = return acc+   | j == 8  = {- trace (show (i,j,k)) $ -} doit4 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit4 1 (1+j) k acc+#else+   | i == 2  = doit4 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit4 (1+i) j k $! acc+        ++ "( getE $ forcen " ++ show dep ++ " expTE_" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            1 -> expTE_1+            2 -> expTE_2+            3 -> expTE_3+    get = case i of+           1 -> getE+    dep = j'+    i' = i+    j' = j+    k' = k+#endif++-------------------------------------------------------------------------------++  doit5 :: Int -> Int -> Int -> String -> IO String+  doit5 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit5 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit5 1 (1+j) k acc+#else+   | i == 2  = doit5 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit5 (1+i) j k $! acc+        ++ "forcen " ++ show dep ++ " expN_" ++ show k' ++ " `seq` ()  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            1 -> expN_1+    get = case i of+           1 -> getN_1+    dep = j'+    i' = i+    j' = j+    k' = k++-------------------------------------------------------------------------------++  doit6 :: Int -> Int -> Int -> String -> IO String+  doit6 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit6 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit6 1 (1+j) k acc+#else+   | i == 2  = doit6 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit6 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_2+    get = case i of+           _ -> getN_2+    dep = j'+    i' = i+1+    j' = j+    k' = k+1++-------------------------------------------------------------------------------++  doit7 :: Int -> Int -> Int -> String -> IO String+  doit7 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit7 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit7 1 (1+j) k acc+#else+   | i == 2  = doit7 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit7 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_3+    get = case i of+           _ -> getN_3+    dep = j'+    i' = i+2+    j' = j+    k' = k+2++-------------------------------------------------------------------------------++  doit8 :: Int -> Int -> Int -> String -> IO String+  doit8 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit8 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit8 1 (1+j) k acc+#else+   | i == 2  = doit8 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit8 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_4+    get = case i of+           _ -> getN_3+    dep = j'+    i' = i+2+    j' = j+    k' = k+3++-------------------------------------------------------------------------------++#if 0++#if 0+  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+  patP_1 = Node (TR [typeOf ((__,__,__)::(Float, [Int], Bool))])+             [ Node (TR [typeOf (__::Bool)]) []+--           [ Node (TR [typeOf (__::Float)]) []+--           [ Node (NTR [typeOf (__::Bool)]) []+--           [ Node (NTR [typeOf (__::Float)]) []+--           , Node WS []+             , Node (TW [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) [ Node WS [], Node WS [] ]  -- why not?+             , Node WW []+--           , Node I []+             ]+  getP_1 (_,xs,_) = show $ (xs!!2)+#endif++  doit9 :: IO String+  doit9 = do+#if 0+    putStrLn $ intercalate "\n"+     [ ""+     , "expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+     , "patP_1 = Node (T [typeOf ((__,__,__)::(Float, [Int], Bool))])"+     , "           [ Node W []"+     , "           , Node (T [typeOf ([__]::[Int])]) []"+     , "           , Node I []"+     , "           ]"+     , "getP_1 (_,xs,_) = show $ (xs!!2)"+     ]+    putStrLn "getP_1 $ forcep patP_1 expP_1"+#endif+    s <- catch+             ( return $! getP_1 $! forcep patP_1 expP_1 )+--           ( return $! getP_2 $! forcep patP_2 expP_2 )+--           ( return $! getP_3 $! forcep patP_3 expP_3 )+             -- ErrorCall if use __ = undefined+             -- BottomedOut if use __ = throw BottomedOut+             (\e -> do let err = show (e :: ErrorCall)+--           (\e -> do let err = show (e :: BottomedOut)+                       return err)+    return s++#endif++-------------------------------------------------------------------------------++  doit10 :: Bool -> [(Int,String)] -> IO ()+  doit10 _ [] = do+                   putStrLn "----------------------------------------------------"+                   return ()+  doit10 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit10: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                 then do+                  putStrLn "===================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "===================================================="+                 else do+                  putStrLn "----------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                 then putStrLn $  "expected value           = " ++ expect+                 else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                 then putStrLn $  "expected value           = " ++ expect+                 else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit10 False t++-------------------------------------------------------------------------------++  doit11 :: Bool -> [(Int,String,String)] -> IO ()+  doit11 _ [] = do+                   putStrLn "----------------------------------------------------"+                   return ()+  doit11 b ((code,patstr1,patstr2):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit11: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let patstrU = showPat $ unionPats [compilePat patstr1, compilePat patstr2]+                let pat1 = compilePat patstr1+                let pat2 = compilePat patstr2+                let patU = unionPats [pat1,pat2]+                let get (_,xs,_) = show $ (xs!!2)+                if b+                 then do+                  putStrLn "===================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ ( forcep patstr2 . forcep patstr1 ) exp"+--                putStrLn "? = get $ ( forcep ( unionPatsStr [ patstr1, patstr2 ] ) ) exp"+                  putStrLn "? = get $! ( forcep_ ( unionPats [ pat1, pat2 ] ) ) exp"+                  putStrLn "(Results were more interesting with a previous semantics...)."+                  putStrLn "===================================================="+                 else do+                  putStrLn "----------------------------------------------------"+                putStrLn $ "patstr1                     = " ++ patstr1+                putStrLn $ "patstr2                     = " ++ patstr2+                putStrLn $ "patstrU                     = " ++ patstrU+                if code > 4+                 then putStrLn $  "expected value              = " ++ expect+                 else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat patstr1  = " ++ showPat pat1+                putStrLn $ "showPat.compilePat patstr2  = " ++ showPat pat2+                putStrLn $ "showPat.compilePat patstrU  = " ++ showPat patU+                if code <= 4+                 then putStrLn $  "expected value              = " ++ expect+                 else return ()+                putStr "actual value                = "+                let s1 = get $! ( forcep patstr2 . forcep patstr1 ) exp+                putStrLn s1+                putStr "actual value                = "+                let s2 = get $! forcep patstrU exp+#if 1+                let s3 = s2+#else+                putStrLn s2+                let s3 = get $! forcep_ ( unionPats [ pat1, pat2 ] ) exp+#endif+                return $! s3+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit11 False t++-------------------------------------------------------------------------------++  doit12 :: Bool -> [(Int,String,[Int],[(Int,String)])] -> IO ()+--doit12 :: Bool -> [(Int,String,String,[(Int,String)])] -> IO ()+  doit12 _ [] = do+                   return ()+  doit12 b ((code,patstr1,path,isibs'):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit12: unexpected code " ++ show code+    s <- catch+           ( do+                let target = compilePat patstr1+--              let path = compilePat patstr2+                let isibs = map (\ (x,y) -> (x,compilePat y)) isibs'+                if b+                 then do+                  putStr hdline+                  putStrLn "Testing splicePats."+                  putStr hline+                 else return ()+                putStrLn $ "target       " ++ patstr1+                putStrLn $ "path         " ++ show path+--              putStrLn $ "path         " ++ patstr2+                putStrLn $ "isibs        " ++ show isibs'+                let s1 = force $ showPat $ splicePats target path isibs+--              let s1 = showPat $! splicePats target path isibs+--              let s1 = showPat $ splicePats target path isibs+                putStr "result       "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    if null t then return () else putStr hline+    doit12 False t++-------------------------------------------------------------------------------++  doit13 :: Bool -> [(Int,[String],String)] -> IO ()+  doit13 _ [] = do+                   putStr hline+                   return ()+  doit13 b ((code,patstrlst,expectstr):t) = do+    s <- catch+           ( do+                s1 <- case code of+-- Where were they done already?+-- Oh, in doit11 and doit12 above...+                       1 -> error $ hline ++ "unionPats test already done test13-1!"+--                     4 -> error $ hline ++ "unionPatsStr test already done test13-4!"+                       10 -> error $ hline ++ "splicePats test already done test13-10!"+                       11 -> error $ hline ++ "isPath test already done test13-11!"+    --  1    unionPats       :: [ Pat ] -> Pat+    --  2  * intersectPats   :: [ Pat ] -> Pat+    --  3  * subPat          :: Pat -> Pat -> Bool+--  --  4    unionPatsStr    :: [ String ] -> String+    --  5  * emptyPat        :: Pat+--  --  6  * mkPat           :: forall d. Data d => d -> Pat+--  --  7  * growPat         :: forall d. Data d => Pat -> d -> Pat+    --  8  * shrinkPat       :: Pat -> Pat+    --  9  * liftPats        :: [ Pat ] -> Pat+    -- 10    splicePats      :: Pat -> Pat -> [(Int, Pat)] -> Pat+    -- 11    isPath          :: Pat -> Bool+                       2 -> do+                               let patA = patstrlst!!0+                               let patB = patstrlst!!1+                               putStr hline+                               putStrLn "Testing      intersectPats [patA, patB]"+                               putStrLn $ "patA         " ++ patA+                               putStrLn $ "patB         " ++ patB+                               putStr $ "result       "+                               let s1 = force $ showPat $ intersectPats [compilePat patA, compilePat patB]+                               return s1+                       3 -> do+                               let patA = patstrlst!!0+                               let patB = patstrlst!!1+                               putStr hline+                               putStrLn "Testing      subPat patA patB"+                               putStrLn $ "patA         " ++ patA+                               putStrLn $ "patB         " ++ patB+                               let s1 = force $ show $ subPat (compilePat patA) (compilePat patB)+                               if s1 /= expectstr+                                then do putStrLn $ "expect       " ++ expectstr+                                        putStr $ "result       "+                                else putStr $ "as expected  "+                               return s1+                       5 -> do+                               putStr hline+                               putStrLn "Testing      emptyPat"+                               putStr $ "result       "+                               let s1 = force $ showPat $ emptyPat+                               return s1+                       6 -> do+#if 0+                               putStr hline+                               putStrLn "Testing      mkPat ([1,2,3],(False,\"foo\"))"+                               putStr $ "result       "+                               let s1 = force $ showPat $ mkPat ([1,2,3::Int],(False,"foo"))+                               return s1+#else+                               return ""+#endif+                       7 -> do+#if 0+                               let patA = patstrlst!!0+                               putStr hline+                               putStrLn "Testing      growPat patA ([1,2,3],(False,\"foo\"))"+                               putStrLn $ "patA         " ++ patA+                               putStr $ "result       "+                               let s1 = force $ showPat $ growPat (compilePat patA) ([1,2,3::Int],(False,"foo"))+                               return s1+#else+                               return ""+#endif+                       8 -> do+                               let patA = patstrlst!!0+                               putStr hline+                               putStrLn "Testing      shrinkPat patA"+                               putStrLn $ "patA         " ++ patA+                               putStr $ "result       "+                               let s1 = force $ showPat $ shrinkPat (compilePat patA)+                               return s1+                       9 -> do+                               putStr hline+                               putStrLn "Testing      liftPats patstrlst"+                               putStrLn $ "patstrs      " ++ show patstrlst+                               putStr $ "result       "+                               let s1 = force $ showPat $ liftPats $ map compilePat patstrlst+                               return s1+                       _ -> error $ "doit13: unexpected code " ++ show code+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit13 False t++-------------------------------------------------------------------------------++  -- This is an adaptation of doit10 to user-defined datatypes,+  -- for testing GNFDataP, which is finally within reach thanks+  -- to SOP!+  doit14 :: Bool -> [(Int,String)] -> IO ()+  doit14 _ [] = do+                   putStrLn "----------------------------------------------------"+                   return ()+  doit14 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit14: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                 then do+                  putStrLn "===================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "===================================================="+                 else do+                  putStrLn "----------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                 then putStrLn $  "expected value           = " ++ expect+                 else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                 then putStrLn $  "expected value           = " ++ expect+                 else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit14 False t++-------------------------------------------------------------------------------+
+ tests/Blah_new_grammar.hs view
@@ -0,0 +1,3325 @@++-------------------------------------------------------------------------------++-- Disclaimer: I've not used HUnit yet. I'm using it only+-- as a "hook" so can compile/test in less clock time...+-- (I forget the details of how/why.)+--+-- Obviously, this should use proper HUnit eventually.+-- And QuickCheck and SmallCheck, DEFINITELY!!!...+-- This is a great case for those; and shape-syb no less.+--+-- This file could be cleaned up a lot, but that's+-- not quite a priority at the moment...+--+-- The reason I shied away from making it real HUnit tests+-- is probably related to the fancy exception throwing/catching+-- and catching of all exceptions (including error), etc.+-- Which was aggravated by the nature of this project and+-- of its tests, which hit bottom as a matter of course...+--+-- Yeah; and looking at examples of QuickCheck and SmallCheck,+-- it's still not clear to me how to work bottoming-out+-- into my tests.+--   I guess I could catch the bottoms in my code, and return+-- some reserved value to indicate that it occurred?...++-------------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------++#define FOCUS_TEST 0+#define TRY_THIS 1+#define USE_TRACE 0++-------------------------------------------------------------------------------++-- Later: This may work with some versions of GHC, but I'm quite+-- sure I've seen it not work with some recent version...+-- Unfortunately, this doesn't work -- all pragmas are processed,+-- regardless of CPP (so CPP must run after).+-- The fact the CPP itself can be set via a pragma complicates this.+-- It could be made an exception, and the LANGUAGE CPP pragma could+-- be parsed regardless of CPP context (as all pragmas currently are).+-- As it is, we need separate source modules, and to switch at+-- import statements (and in the .cabal file).+-- THIS IS A BUG.+-- So anyhow, this is only here as a reminder:+---  #if ! HASKELL98_FRAGMENT+---  {-# LANGUAGE ... #-}+---  #endif+  {-# LANGUAGE DeriveGeneric #-}+  {-# LANGUAGE DeriveDataTypeable #-}  -- to make BottomedOut+  {-# LANGUAGE BangPatterns #-}++  {-# LANGUAGE Rank2Types #-}  -- for SYB (testing rnfpDyn and friends)++-------------------------------------------------------------------------------++  -- SOP pragmas:++  -- Not necessarily needed to work with SOP, but I think it'll+  -- be helpful here [?] ...+  {-# LANGUAGE ScopedTypeVariables #-}+  {-  LANGUAGE AllowAmbiguousTypes #-}++-- Actually, CPP doesn't work with Haskell (GHC) pragmas last I checked...+#if USE_SOP+  {-# LANGUAGE DataKinds #-}+  {-# LANGUAGE TypeFamilies #-}+  {-# LANGUAGE ConstraintKinds #-}+#if __GLASGOW_HASKELL__ < 708+  {-# LANGUAGE GADTs #-}+#endif+  {-# LANGUAGE TemplateHaskell #-}+#endif++-------------------------------------------------------------------------------++  module Blah_new_grammar ( run_tests ) where++-------------------------------------------------------------------------------++--import Common+  import Bottom+  import Foo+  import FooG++--import Control.DeepSeq.Generics+  import Control.DeepSeq.Bounded+--import Control.DeepSeq.Bounded hiding ( F )+  import Control.DeepSeq.Bounded.Generic++#if 0+  import GHC.Generics+--import GHC.Generics ( Generic )+#endif++  import Data.Maybe++  import Control.Exception+--import Control.Monad ( guard )+  import Control.Monad ( replicateM )+  import Control.Monad ( when )+  import Data.Typeable ( Typeable )+  import Data.Typeable ( typeOf )++  import Data.Data ( Data )++  import Data.Generics.Aliases ( mkQ, extQ, GenericQ )++--import Util ( spoor )+  import Debug.Trace ( trace )+  import Control.DeepSeq++#if __GLASGOW_HASKELL__ >= 708+  import Data.Typeable ( Proxy(..) )+#endif++#if USE_SOP+  import Generics.SOP hiding ( Shape )+#endif++  import System.Random++  import Data.List ( intercalate )++  import System.IO.Unsafe ( unsafePerformIO )++-------------------------------------------------------------------------------++  -- For convenience in GHCi interactive sessions:+  cp = compilePat+--cp = compilePat+  ip = intersectPats+  isp = subPat++  -- For more compact test expressions:+-- XXX Refer to Seqable.hs for comments about JUST_ALIAS_GSEQABLE.+#if 1+#if JUST_ALIAS_GSEQABLE+  fI :: forall a. Generic a => a -> a+  fI = force_ Insulate+  fP :: forall a. Generic a => a -> a+  fP = force_ Propagate+#else+  fI :: forall a. NFDataN a => a -> a+  fI = force_ Insulate+  fP :: forall a. NFDataN a => a -> a+  fP = force_ Propagate+#endif+#else+  fI = force_ Insulate+  fP = force_ Propagate+#endif++  gI :: forall a. Generic a => a -> a+  gI = gforce_ Insulate+  gP :: forall a. Generic a => a -> a+  gP = gforce_ Propagate++-------------------------------------------------------------------------------++  run_tests :: IO Int+  run_tests = do++    putStr "\n"+    -- So can notice the start when scrollback, esp. in ghci reload/reruns.+--  replicateM 50 $ putStrLn "################################################################################"+    putStrLn "\nTesting."+    putStrLn "\nNote that  __ = undefined  (abbrev. occurring in what follows)."++    -- XXX NOTE XXX+    --+    -- Most of the comments are pre-new-grammar (most of the comments+    -- are actually from no later than September 2014).  Some have been+    -- revised in light of the new grammar; many have not...++#if ! FOCUS_TEST++    let shs s p =+         unsafePerformIO $ +         catch+          ( return $! force $ "input:                       " ++ show p ++ "\n" ++ "expect: " ++ s ++ "\n   got: " ++ showPat p )+          ( \e -> do let err = show (e :: ErrorCall)+                     return err )++    let eas = emptyPatNodeAttrs+    let neas = eas { depth = 23 }+    let peas = eas { doSpark = True }+    let pneas = neas { doSpark = True }+    let teas = eas { doConstrainType = True, typeConstraints = ["Int"] }+    let nteas = teas { depth = 23 }+    let pteas = teas { doSpark = True }+    let pnteas = nteas { doSpark = True }+    let teas2 = eas { doConstrainType = True, typeConstraints = ["[Int]"] }+    let pteas2 = teas2 { doSpark = True }+    let ptneas2 = pteas2 { depth = 23 }+    let xxptneas2 = ptneas2 { doTrace = True, doPing = True }+    let xxpeas = eas { doSpark = True, doTrace = True, doPing = True }++    putStrLn "\nTesting showPat"+    putStrLn "---------------"++    putStrLn $ shs "*" $ Node (WW eas) []+    putStrLn $ shs "." $ Node (WI eas) []+    putStrLn $ shs "!" $ Node (WS eas) []+    putStrLn $ shs "()" $ Node (WR eas) []+    putStrLn $ shs "(*)" $ Node (WR eas) [Node (WW eas) []]+    putStrLn $ shs "(**)" $ Node (WR eas) [Node (WW eas) [],Node (WW eas) []]+    putStrLn $ shs "(!*)" $ Node (WR eas) [Node (WS eas) [],Node (WW eas) []]+    putStrLn $ shs "(.!)" $ Node (WR eas) [Node (WI eas) [],Node (WS eas) []]+    putStrLn $ shs "(.)" $ Node (WR eas) [Node (WI eas) []]+    putStrLn $ shs "((.))" $ Node (WR eas) [Node (WR eas) [Node (WI eas) []]]+    putStrLn $ shs "(*.(*.(*.)**.*).*)" $ Node (WR eas) [Node (WW eas) [],Node (WI eas) [],Node (WR eas) [Node (WW eas) [],Node (WI eas) [],Node (WR eas) [Node (WW eas) [],Node (WI eas) []],Node (WW eas) [],Node (WW eas) [],Node (WI eas) [],Node (WW eas) []],Node (WI eas) [],Node (WW eas) []]+    putStrLn $ shs "(.!(*23*))" $ Node (WR eas) [Node (WI eas) [],Node (WS eas) [],Node (WR eas) [Node (WN neas) [],Node (WW eas) []]]+#if PARALLELISM_EXPERIMENT+    putStrLn $ shs "(.=(=*23*)*)" $ Node (WR eas) [Node (WI eas) [],Node (WR peas) [Node (WN pneas) [],Node (WW eas) []],Node (WW eas) []]+#endif+    putStrLn $ shs ":Int:()"    $ Node (TR teas)  []+--- putStrLn $ shs ":Int:!"     $ Node (TS teas)  []+    putStrLn $ shs ":Int:*23"   $ Node (TN nteas) []+    putStrLn $ shs ":Int:*"     $ Node (TW teas)  []+    putStrLn $ shs ":Int:."     $ Node (TI teas)  []+    putStrLn $ shs "=:Int:()"    $ Node (TR pteas)  []+--- putStrLn $ shs "=:Int:!"     $ Node (TS pteas)  []+    putStrLn $ shs "=:Int:*23"   $ Node (TN pnteas) []+    putStrLn $ shs "=:Int:*"     $ Node (TW pteas)  []+    putStrLn $ shs "=:Int:."     $ Node (TI pteas)  []+    putStrLn $ shs "=:[Int]:()"   $ Node (TR pteas2)  []+    putStrLn $ shs "=:[Int]:*"   $ Node (TW pteas2)  []+    putStrLn $ shs "=:[Int]:*23"   $ Node (TN ptneas2)  []+    putStrLn $ shs "=+^()"        $ Node (WR xxpeas)  []  -- canonical ordering+--  putStrLn $ shs "+^=()"        $ Node (WR xxpeas)  []+    putStrLn $ shs "=+^:[Int]:*23"   $ Node (TN xxptneas2)  []++--  let shp s = s ++ replicate (30 - length s) ' ' ++ show (compilePat s)+    let shp s = +         unsafePerformIO $ do+           putStr $ s ++ replicate (30 - length s) ' '+           catch+            ( return $! force $ show (compilePat s) )+--          ( return $! force $ s ++ replicate (30 - length s) ' ' ++ show (compilePat s) )+            ( \e -> do let err = show (e :: ErrorCall)+                       return err )++    putStrLn "\nPattern                       Compiles to"+    putStrLn "-----------------------------------------"++--  putStrLn $ shp ""  -- empty pattern syntax error+    putStrLn $ shp "."  -- Node WI []  -- no parent to absorb (should be error)+    putStrLn $ shp "!"  -- Node WS []+    putStrLn $ shp "*"  -- Node WW []+    putStrLn $ shp "*!"  -- "disconnected pattern (not rooted)"+    putStrLn $ shp "()"  -- Node WR []+    putStrLn $ shp "(.)"  -- Node WR [Node WW []]+    putStrLn $ shp "(*)"  -- Node WR [Node WW []]+    putStrLn $ shp "(**)"  -- Node WR [Node WW [],Node WW []]+    putStrLn $ shp "(!*)"  -- Node WR [Node WS [],Node WW []]+    putStrLn $ shp "(.!)"  -- Node WR [Node WI [],Node WS []]+    putStrLn $ shp "(.(.))"  -- Node WR [Node WI [],Node WR [Node WI []]]+    putStrLn $ shp "((.))"  -- Node WR [Node WR [Node WI []]]+    putStrLn $ shp "(.(().))"  -- Node WR [Node WI [],Node WR [Node WR [],Node WI []]]+    putStrLn $ shp "(*.*.*.**.*.*)"+    putStrLn $ shp "(*.(*.(*.)*)*(.*).*)"+    putStrLn $ shp "(*.(*.(*.)*)*.*)"+    putStrLn $ shp "(*.(*.(*.)*)(*)(.*).*)"+    putStrLn $ shp "((!(!)(((!).!(!))))!(!(!)))"  -- of leaky fame+    putStrLn $ shp "*23"+    putStrLn $ shp "(.!(*23*))"+    putStrLn $ shp ":Int:"  -- see what happens+    putStrLn $ shp ":Int:()"+    putStrLn $ shp ":Int:!"  -- see what happens+    putStrLn $ shp ":Int."  -- see what happens+    putStrLn $ shp ":Int:."+    putStrLn $ shp ":Int:*"+    putStrLn $ shp ":Int*23"  -- see what happens+    putStrLn $ shp ":Int:*23"+#if PARALLELISM_EXPERIMENT+    putStrLn $ shp "=."  -- Node WI [] (doSpark=True)+    putStrLn $ shp "=!"  -- Node WS [] (doSpark=True)+    putStrLn $ shp "=*"  -- Node WW [] (doSpark=True)+    putStrLn $ shp "(.=(=*23*)*)"+    putStrLn $ shp "=:Int"  -- see what happens+    putStrLn $ shp "=:Int:()"+    putStrLn $ shp "=:Int:!"  -- see what happens+    putStrLn $ shp "=:Int:."+    putStrLn $ shp "=:Int:*"+    putStrLn $ shp "=:Int*23"  -- see what happens+    putStrLn $ shp "=:Int:*23"+    putStrLn $ shp "=:[Int]:()"+    putStrLn $ shp "=:[Int]:*"+    putStrLn $ shp "=:[Int]:*23"+    putStrLn $ shp "=+^()"+    putStrLn $ shp "+^=()"+    putStrLn $ shp "=+^:[Int]:*23"+#endif++    putStrLn ""+#endif++--  error "DEVEXIT"++#if ! FOCUS_TEST++#if 1+    let test_patterns10 = [+           (4,  "")  -- syntax error+         , (4,  "!..")  -- syntax error (disconnected pattern)+         , (1,  "(!..)")  -- fail+         , (5,  "(().().())")+         , (2,  "*")+         , (2,  "(***)")+         , (1,  "(...)")+         , (1,  "(*..)")+         , (2,  "(**.)")+         , (2,  "(..*)")++           -- Remember, [a] is a recursive binary ctor app!...+           -- The next four tests give instance errors for [a].+           -- (Later: Silent pattern-match failures, that is, because+           -- WARN_PATTERN_MATCH_FAILURE is False by default.)+           -- But if testing expTG_* (GNFDataP/grnfp) then+           -- it's no longer a list...+         , (13, "((*.*).)")+         , (13, "((*...).)")+         , (13, "((*....).)")+         , (13, "((*....)!)")  -- used to have "23" but that's incorrect++         , (1,  "((*.)*)")  -- used to have "2" but that's incorrect+         , (1,  "((*.).)")+         , (1,  "((*(.*)).)")+         , (1,  "((*(*.)).)")  -- used to have "2" but that's incorrect+         , (13, "((((.*))).)")  -- See above comment about [a] instance+         , (1,  "(.(((.*))).)")  -- used to have "2" but that's incorrect++           -- (See Book, p.84.)+         , (1,  "(!(!(.(!!))).)")+         , (1,  "(!(!(.*)).)")+         , (1,  "(*(*(.*)).)")+         , (2,  "(..*)")+         , (2,  "(*.*)")+         , (1,  ":Tuple3:(*(*(.*)).)")  -- oops...+         , (1,  ":(,,):(*(*(.*)).)")+         , (2,  ":(,,):(*(*(!*)).)")+         , (1,  ":Bool:(***)")  -- XXX makes no sense (but works) -- oh well;+                                -- this is an important point to note in+                                -- docs/blog also... [Later: old comment;+                                -- syntax has changed a lot since written...]+         , (4,  ":Bool*")  -- used to be 1, but now it's a syntax error+         , (1,  ":Bool:*")  -- new syntax requires terminating empty {}+         , (2,  ":(,,):*")+         , (2,  "(*.!)")++-- XXX OLD COMMENT BUT BEWARE... XXX+--   "This does what-- it says, it will only match a childless Bool node.+--    Still need to implement # when not in type."+-- Since {} are obligatory in the new grammar, for type-constrained * and #,+-- better make sure the semantics are implemented as specified. (They are+-- specified in the Pattern module Haddock API page.)++           -- New comment: Since #::typename can only choose+           -- between effectively behaving as either WI or WS,+           -- it is never recursive:  It forces at most one node!+         , (1,  "(*:Bool:..)")  -- was 2 which is incorrect+         , (1,  "(*:Int:..)")  -- was 2 which is incorrect+         , (1,  "(*:(,):..)")  -- was 2 which is incorrect+         , (1,  "(*:OutOfScopeType:..)")  -- was 2 which is incorrect+         , (1,  "(*:[Int]:..)")+         , (2,  "(*:[Int]:.!)")+         , (1,  "(*.:Bool:.)")+         , (2,  "(*.:Int:.)")+         , (2,  "(*.:(,):.)")+         , (2,  "(*.:OutOfScopeType:.)")+         , (2,  "(*.:[Int]:.)")++         , (2,  "(*:[Int]:*.)")+         , (1,  "(*:Bool:*.)")+         , (1,  "(*:Int:*.)")+         , (1,  "(*:(,):*.)")+         , (1,  "(*:OutOfScopeType:*.)")+         , (2,  "(*.:Bool:*)")+         , (1,  "(*.:Int:*)")+         , (1,  "(*.:(,):*)")++         , (1,  "(**2.)")+         , (2,  "(**3.)")+         , (1,  "(*:G2:..)")+         , (1,  "(*:Int:..)")+         ]+    doit14 True test_patterns10+--  doit10 True test_patterns10+#endif++#if USE_SOP++-- Seems fine; it's not a good test as the # in the middle+-- only forces one ctor when type doesn't match, and need+-- to force one more level to hit an undefined.+#if 1+    let test_patterns11 = [+           (4,  "")  -- syntax error++         , (1,  "(*:G2:..)")+         , (1,  "(*:Int:..)")+         ]+    doit15 True test_patterns11+#endif++#endif++#if USE_SOP++    -- exp = G2 5 __ 7 :: TG+-- All fine last checked.+#if 1+    let test_patterns12 = [++--         (4, "..")++           (2, "*")+         , (1, "*0")+         , (1, "*1")+         , (2, "*2")+         , (2, "*3")++         , (1, "(!.!)")+         , (2, "(!!!)")+         , (1, "(!!)")  -- due to patmatch failure+         , (2, "(!!!)")+         , (1, "(!!!!)")  -- due to patmatch failure++         , (1, ":G1:(!!)")+         , (1, ":G1:(!!!)")+         , (1, ":G2:(!!)")+         , (2, ":G2:(!!!)")+         , (1, ":TG:(!!!)")++         , (1, ":G1:*")+         , (2, ":G2:*")+         , (1, ":TG:*")+         , (2, ":Int:.")+         , (2, ":G1:.")+         , (1, ":G2:.")+         , (2, ":TG:.")+         , (1, ":Int:.")++         , (1, ":G1:.(!!)")  -- (used to be a syntax err)+         , (1, ":G1:*(!!)")  -- (used to be a syntax err)++         ]+    doit16 True test_patterns12++--  error "DEVEXIT"+#endif++#endif++#if USE_SOP++-- This should work, once the patterns are right for lists,+-- but until I get non-list generic tests working I'm not+-- going to struggle with this.+#if 0+    let test_patterns13 = [+-- expTH_1 = H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False    (for ref.)+-- expTH_4 = H2 1 [H1 2.3, H3, H4 (__, I3 __ (H1 4.5))] __       (in use)+           (4,  "")  -- syntax error+         , (1,  "(!(!(!((.(.!))!))).)")+         , (2,  "(!(!(!((!(.!))!))).)")+         , (2,  "(!(!(!((.(!!))!))).)")+         , (2,  "(!(!(!((.(.!))!)))!)")+         , (1,  "(!((!)(!((.(.(!)))!))).)")+         , (2,  "(!((!)(!((!(.(!)))!))).)")+         , (2,  "(!((!)(!((.(!(!)))!))).)")+         , (2,  "(!((!)(!((.(.(!)))!)))!)")+         , (2,  "(!((!)(!((.(.!(!)))!)))!)")+         ]+    doit17 True test_patterns13+#endif++#if 1+    let test_patterns14 = [+-- expTJ_1 = J2 ( 1, J4 ( J3, K3 K2 ( J1 4.5))) False     -- for ref.+-- expTJ_2 = J2 ( 1, J4 ( J3, K3 __ ( J1 4.5))) False+-- expTJ_3 = J2 ( 1, J4 ( __, K3 K2 ( J1 4.5))) False+-- expTJ_4 = J2 ( 1, J4 ( __, K3 __ ( J1 4.5))) __        -- in use+--           {  { {} {  { {}  {  {} { {  {} }}}}}}}+-- XXX The tuples are ctors, I forgot...+           (4 ,  "")  -- syntax error+#if 0+         , (1 ,  "!")+         , (13,  "()")+         , (13,  "(!)")+         , (2 ,  "(!!)")+         , (13,  "(!!!)")+         , (13,  "(!!!!)")+         , (13,  "(!!!!!)")+#endif+-- expTJ_1 = J2 ( 1, J4 ( J3, K3 K2 ( J1 4.5))) False     -- for ref.+--                J2 { (,) { I J4 { (,) { J3 K3 { K2 { J1 { 4.5 } } } } } } False }+--                .  {  .  { .  . {  .  { .  .  {  . { .  { .   } } } } } } . }+           -- this pattern also double-checked on paper+         , (2 ,  "((!((!(!(!)))))!)")+--       , (1 ,  "((!((!(.(!))))).)")  -- blows (in partic. expTJ_2)+         , (1 ,  "((!((.(!(!))))).)")  -- blows (in partic. expTJ_3)+--       , (1 ,  "((!((.(.(!))))).)")  -- blows (in partic. expTJ_4)+#if 0+         , (1 ,  "((!(.(..(..(.))))).)")  -- = "((!(.)).)" (no blow)+         , (1 ,  "((!(.(.(.(!))))).)")  -- = "((!(.)).)" (no blow)+         , (1 ,  "((!(.(!(.(!))))).)")  -- = "((!(.)).)" (no blow)+         , (1 ,  "((!((!(.(!))))).)")  -- blows+         , (1 ,  "((!((..(..(.))))).)")  -- blows+         , (1 ,  "((!(.)).)")             -- confirming (no blow)+#endif+#if 0+         , (2 ,  "((!((!(((!))))))!)")+         , (1 ,  "((!((.(.((!)))))).)")+         , (1 ,  ".(.(..(.(..(.(.(.)))))).)")+         , (1 ,  "(.(..(.(..(.(.(.)))))).)")+         , (1 ,  "((..(.(..(.(.(.)))))).)")+         , (1 ,  "((!(.(..(.(.(.)))))).)")+#endif+#if 0+         , (1,  "(!(.(.(!))).)")+         , (2,  "(!(!(!(!)))!)")+         , (2,  "*")+         , (2,  "(!*!)")+         , (2,  "(***)")+#endif+         ]+    doit18 True test_patterns14+#endif++#if 1+    let test_patterns14b = [+-- expTJ_5 = J2 ( 1, J4 ( __, K2 )) False+           (4 ,  "")  -- syntax error+         , (2 ,  "((!((!!)))!)")+         , (1 ,  "((!((.!)))!)")+         , (1 ,  "((!(.(!!)))!)")+         , (1 ,  "((!.((!!)))!)")+         ]+    doit18b True test_patterns14b+#endif++#if 1+    let test_patterns14c = [+-- expTJ_6 = J4 ( __, K2 ) False+           (4 ,  "")  -- syntax error+         , (2 ,  "((!!))")+         , (1 ,  "((.!))")+         , (1 ,  "(.(!!))")+         , (1 ,  ".((!!))")+         ]+    doit18c True test_patterns14c+#endif++#if 1+    let test_patterns14d = [+-- expTJ_7 = ( __, K2 )+           (4 ,  "")  -- syntax error+         , (2 ,  "(!!)")+         , (1 ,  "(.!)")+         , (1 ,  ".(!!)")+         ]+    doit18d True test_patterns14d+#endif++#if 1+    let test_patterns14e = [+-- expTJ_8 = __ :: TJ+           (4 ,  "")  -- syntax error+         , (2 ,  "!")+         , (1 ,  ".")+         ]+    doit18e True test_patterns14e+#endif++#if 1+    let test_patterns14f = [+-- expTJ_8 = (K5 (__::TJ))+           (4 ,  "")  -- syntax error+         , (1 ,  "!")+         , (1 ,  "(.)")+         , (2 ,  "(!)")+         , (1 ,  ".")+         ]+    doit18f True test_patterns14f+#endif++-- These work!+#if 1+    let test_patterns14g = [+#if TRY_THIS+-- exp = K3 (__::TK) J3+#else+-- exp = K3 K2 (__::TJ)+#endif+           (4 ,  "")  -- syntax error+         , (1 ,  "!")+#if TRY_THIS+         , (1 ,  "(.!)")+         , (2 ,  "(!.)")+#else+         , (2 ,  "(.!)")+         , (1 ,  "(!.)")+#endif+         , (2 ,  "(!!)")+         , (1 ,  ".")+         ]+    doit18g True test_patterns14g+#endif++-- Okay last I checked.+#if 1+    let test_patterns15 = [+-- expTL_1 = L1 5.6 (M1 True)+-- expTL_2 = L1 5.6 (M1 __)+-- expTL_3 = L1 5.6 __+-- expTL_4 = L1 __ (M1 True)+           (4 ,  "")  -- syntax error+#if 0+#elif 1+         , (1 ,  ".")+         , (5 ,  ".(!!)")+         , (1 ,  "(!!)")+         , (2 ,  "((!)!)")+         , (1 ,  "((.)!)")+#elif 0+         , (1 ,  ".")+         , (5 ,  ".(!!)")+         , (2 ,  "(!!)")+         , (1 ,  "(.(!))")+#elif 0+         , (1 ,  ".")+         , (5 ,  ".(!!)")+         , (2 ,  "(!!)")+         , (2 ,  "(!(!))")+         , (2 ,  "(!(.))")+#elif 0+         , (1 ,  ".")+         , (5 ,  ".(!!)")+         , (1 ,  "(!!)")+         , (2 ,  "(!(!))")+         , (1 ,  "(!(.))")+#endif+         ]+    doit19 True test_patterns15+#endif++-- Good test case for the problem. No tuples; every step is generic.+#if 1+    let test_patterns16 = [+-- expTK_1 = K3 K2 ( J1 4.5)     -- for ref.+-- expTK_2 = K3 __ ( J1 4.5)+--           {  {} { {  {} }}}+-- XXX Don't forget tuples are ctors...+           (4 ,  "")  -- syntax error+#if 0+         , (2 ,  "(!!)")+         , (1 ,  "(.!)")+         , (2 ,  "(!.)")+         , (1 ,  "(..)")+#else+         , (2 ,  "(!(!))")  -- ok+         , (1 ,  "(..)")     -- X+         , (1 ,  "(.!)")     -- X+         , (1 ,  "(.(.))")  -- X+         , (1 ,  "(.(!))")  -- X+         , (2 ,  "(!.(!))")  -- X  & this does give the . with subpat. warning!+         , (2 ,  "(!.(.))")  -- X  & why no warning about . with subpattern?+         , (1 ,  "(..(.))")  -- X  & why no warning about . with subpattern?+         , (1 ,  ".(..(.))")  -- ok & why no warning about . with subpattern?+#endif+         ]+    doit20 True test_patterns16+#endif++#endif++---------------------------------------------++#endif++#if 0 || ! FOCUS_TEST++-- Later: Oh! Don't be silly -- it's all compile-time, and the+-- size or shape of the list is irrelevant -- which rules+-- will fire depends on THIS FILE'S SOURCE CODE (not it's+-- data, including static values)!+-- XXX Even with empty list, the same rule firings occur!...+-- If comment out this block however, the rules do not fire!+#if 1+    -- Testing composition and union:+    let test_patterns11 = [+           (1, "!", "!")+         , (2, "!", "*")+         , (2, "*", "!")+         , (2, "*", "*")+         , (2, "(!!!)", "(*!!)")+         , (2, "(*!!)", "(!!*)")+         , (2, "(!*.)", "(!.!)")+         ]+    doit11 True test_patterns11+#endif++#endif++#if ! FOCUS_TEST++#if 1+    -- Testing splicePats+    let test_patterns12a = [+           (1, "!", [], [(0,"*")])+         , (1, "()", [], [(0,"*")])+         , (1, "!", [0], [(0,"*")])+         , (1, "(!!)", [], [(0,"*")])+         , (1, "(!!)", [0], [(0,"*")])+         , (1, "(!!)", [2], [(0,"*")])+         , (1, "(!!)", [], [(0,"*"),(0,".")])+         , (1, "(!!)", [], [(0,"*"),(1,".")])+         , (1, "(!!)", [], [(1,"."),(0,"*")])+         , (1, "(!!)", [], [(0,"*"),(2,".")])+         , (1, "(!!)", [], [(2,"*"),(2,"."),(2,".")])+         , (1, "(!!)", [], [(-1,"*")])+         , (1, "(!!)", [], [(0,"*")])+         , (1, "(!!)", [], [(1,"*")])+         , (1, "(!!)", [], [(2,"*")])+         , (1, "(!!)", [], [(3,"*")])+         , (1, "(!(!!)!)", [1], [(0,"*")])+         , (1, "(!(!!)!)", [1], [(0,"*3"),(1,"."),(2,"*")])+         , (1, "(!(!!)!)", [1,0], [(0,"*"),(0,".")])+         , (1, "((!!!)(()!)!)", [1], [(0,"*"),(0,".")])+         , (1, "((!!!)(()!)!)", [1,0], [(0,"*"),(0,".")])+         , (1, "((...)(().).)", [1,0], [(0,"*"),(0,".")])+         , (1, "(:(,,):(...)(().).)", [1,0], [(0,"*"),(0,".")])+         ]+    doit12 True test_patterns12a+#endif++#if 1+    -- Testing elidePats+    -- XXX There's a nice way to do this, by rewriting each test+    -- automatically (or via manual regex substitutions) so that+    -- the target is the result of the corresponding splicePats test.+    -- Unfortunately, the expected results are not encoded for+    -- the splicePats test, so oh well, for now at least, just+    -- build some fresh tests!+    let test_patterns12b = [+           (1, "((!!)!(!))", [], [0])+         , (1, "((!!)!(!))", [0], [0])+         , (1, "((!!)!(!))", [1], [0])+         , (1, "((!!)!(!))", [1], [1])+         ]+    doit12b True test_patterns12b+#endif++#endif++#if ! FOCUS_TEST++#if 1+    -- Testing erodePat+    -- XXX Note we toss the stdgen when done here...+    stdgen12c <- newStdGen+--  let stdgen12c = mkStdGen seed+    let test_patterns12c = [+           (1, "((!!)!(!))", [])  -- recursive test...+         ]+--  stdgen12c <- doit12c True test_patterns12c+#if 0+    stdgen12c' <- doit12c True test_patterns12c stdgen12c+    stdgen12c'' <- doit12c True test_patterns12c stdgen12c'+    stdgen12c''' <- doit12c True test_patterns12c stdgen12c''+    return ()+#else+#if 1+    stdgen12c' <- doit12c True test_patterns12c stdgen12c 5+    return ()+#else+    doit12c True test_patterns12c stdgen12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+#endif+#endif+#endif++#endif++#if 0 || ! FOCUS_TEST++#if 1+    -- Testing anything else we can with a single function!+    -- (Getting sick of this cloning.)+    -- Functions are listed in (current) export order.+    -- Things still needing testing are >'d.+    -- Things tested but failing some tests have a *.+    -- +    -- XXX Wow does this ever look cleaner with "Pat" instead of "Pattern"!...+    -- Fortunately splicePats is already tested separately; the rest+    -- we need to test deal only in Pat args (or list of same), so+    -- we can pass a couple [Pat] to test13 along with an Int code+    -- to control delegation.+    --  1    unionPats       :: [ Pat ] -> Pat+    --  2    intersectPats   :: [ Pat ] -> Pat+    --  3    subPat          :: Pat -> Pat -> Bool+--  --  4    unionPatssStr   :: [ String ] -> String+    --  5    emptyPat        :: Pat+    --  6    mkPat           :: forall d. Data d => d -> Pat+    --  7    growPat         :: forall d. Data d => Pat -> d -> Pat+    --  8    shrinkPat       :: Pat -> Pat+    --  9    liftPats        :: [ Pat ] -> Pat+    -- 10    splicePats      :: Pat -> [Int] -> [(Int, Pat)] -> Pat+    -- 11    isPath          :: Pat -> Bool+    -- 12    mkPatN          :: Int -> Pat -> Bool+    -- 13    elidePats       :: Pat -> Pat -> [Int] -> Pat+    -- 14    erodePat        :: StdGen -> [Int] -> Pat -> (Pat, StdGen)+    let test_patterns13 = [+           ( 1, ["(!!!)", "(!.)"], "")+         , ( 2, ["(!!!)", "(!.)"], "")+         , ( 3, ["!", "!"], "True")+         , ( 3, [".", "."], "True")+         , ( 3, ["*", "*"], "True")+         , ( 3, ["!", "()"], "True")+         , ( 3, ["()", "!"], "False")+         , ( 3, ["()", "(!)"], "False")+         , ( 3, ["(!)", "(!)"], "True")+         , ( 3, ["(!)", "(!!)"], "False")+         , ( 3, ["(!)", "((!))"], "True")+         , ( 3, ["(!!)", "(!.)"], "False")+         , ( 3, ["(!.)", "(!!)"], "True")+         , ( 3, ["(!!)", "(!!!)"], "False")+         , ( 3, ["()", "(!!!)"], "False")+         , ( 3, ["!", "(*!.)"], "True")+         , ( 3, [".", "(*!.)"], "True")+         , ( 3, ["*", "(*!.)"], "False")+         , ( 3, ["*", "(*)"], "False")+         , ( 3, ["*", "(**)"], "False")+         , ( 4, ["(!!!)", "(!.)"], "")+         , ( 5, ["(!!!)", "(!.)"], "")+         , ( 6, ["(!!!)", "(!.)"], "")+         -- matching against val = ([1,2,3::Int],(False,"foo"))+         -- mkPat val = "((!(!(!!)))(!(!(!(!!)))))"+         , ( 7, ["((!(!!))(!(!!)))"], "")+         , ( 7, ["((!(!(!!)))(!(!(!!))))"], "")+         , ( 7, ["((!(!(!!)))(!(!(!(!!)))))"], "")+         , ( 8, ["((!(!(!!)))(!(!(!(!!)))))"], "")+         , ( 8, ["((!(!(!!)))(!(!(!!))))"], "")+         , ( 8, ["((!(!!))(!(!!)))"], "")+         , ( 8, ["((.(!!))(.(*3!)))"], "")+         , ( 8, ["((.!)(.!))"], "")+         , ( 8, ["(!!)"], "")+         , ( 8, ["!"], "")+         , ( 9, ["(!!!)", "(!.)"], "")+         , (10, ["(!!!)", "(!.)"], "")+         , (11, ["(!!!)", "(!.)"], "")+         , (12, ["(!!!)", "(!.)"], "")+    -- 12    mkPatN          :: Int -> Pat -> Bool+    -- 13    elidePats        :: Pat -> Pat -> [Int] -> Pat+    -- 14    erodePat        :: StdGen -> [Int] -> Pat -> (Pat, StdGen)+         ]+    putStrLn "==================================================="+    putStrLn "Testing miscellaneous PatUtil functions..."+    doit13 True test_patterns13+#endif++#endif++#if ! FOCUS_TEST++#if 1+    -- Testing fusion+    putStrLn "\nTesting fusion\n-fenable-rewrite-rules -O -ddump-rules -ddump-simpl-stats -ddump-rule-firings\n"+    let exp12 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+    let get12 (_,xs,_) = (xs!!2)+    putStrLn $ show $ get12 $ ( forcep ":Bool:*" . forcep ":Int:*" ) exp12+    putStrLn $ show $ get12 $ ( forcep ":Bool:*" . forcep_ (compilePat ":Int:*") ) exp12+    putStrLn $ show $ get12 $ ( forcep_ (compilePat ":Bool:*") . forcep ":Int:*" ) exp12+    putStrLn $ show $ get12 $ ( forcep_ (compilePat ":Bool:*") . forcep_ (compilePat ":Int:*") ) exp12+#endif++#if 1+    putStrLn $ intercalate "\n"+     [ ""+     , "expN_1 = [__] :: [Int]"+     , "expN_2 = [0,1,__,3] :: [Int]"+     , "expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)"+     , "expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+     , ""+     , "getN_1 xs = show $ ()"+--   , "getN_1 xs = show $ head xs"+--   , "getN_2 xs = show $ (xs!!1)"+     , "getN_2 xs = show $ (xs!!3)"+     , "getN_3 (_,xs,_) = show $ (xs!!2)"+     ]+    doit5 1 0 1 "" >>= putStrLn+    doit6 1 0 1 "" >>= putStrLn+    doit7 1 0 1 "" >>= putStrLn+    doit8 1 0 1 "" >>= putStrLn+#if 0+    doit9 >>= putStrLn  -- XXX broken (whatever it is)+#endif+#endif++#if 1+    putStr hdline+    putStrLn "Testing generic GNFDataN (refer to Foo.hs for the defs).\n"+    putStr hline+#if 0+#if ! USE_SOP+    putStrLn $ show $ from expTE_1+    putStrLn $ show $ from $ F 23+    putStrLn $ show $ from $ Just 11  -- bad comparison: two constructors!+#endif+--  putStrLn $ show $ from $ Just (undefined::Int)+--  putStrLn $ show $ from expTE_2+--  putStrLn $ show $ from expTE_3+    putStr "\n"+    putStrLn $ ""+           ++ "expBase7 = B2 (A1 True 4) (B1 True (A2 undefined))\n"+           ++ "expBase8 = B2 (A1 undefined 4) (B1 True (A2 undefined))\n"+           ++ "expBase9 = B2 (A1 undefined 4) (B1 undefined (A2 undefined))\n"+           ++ "...\n"+           ++ "getB_1 (B2 _ (B1 b _)) = b\n"+           ++ "getB_2 (B2 (A1 _ n) _) = n\n"+#endif+    s2 <- doit2 1 0 1 ""+    putStrLn s2+#if 0+    putStrLn $ ""+           ++ "expTB_15 = (A3 (B3 False undefined 5) False)\n"+           ++ "getA (A3 _ b) = show b\n"+    s3 <- doit3 1 1 1 ""+    putStrLn s3+#endif+#endif++#if 0+    s4 <- doit4 1 0 1 ""+    putStrLn s4+#endif++#if 0+    putStrLn $ ""+           ++ "expBase1 = ([True,False],3,Just \"fox\")         :: ([Bool],Int,Maybe String)\n"+           ++ "expBase2 = ([True,False],__,Just \"fox\")        :: ([Bool],Int,Maybe String)\n"+           ++ "expBase3 = ([True,__],3,Just \"fox\")            :: ([Bool],Int,Maybe String)\n"+           ++ "expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)\n"+           ++ "expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)\n"+           ++ "expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)\n"+           ++ "get1 ((x:_),_,_) = x           -- True\n"+           ++ "get2 (_,x,_) = x               -- 3\n"+           ++ "get3 (_,_,x) = fromJust x      -- \"fox\"\n"+           ++ "get4 (_,_,Just (x:_)) = x      -- 'f'\n"+    s1 <- doit1 1 1 1 ""+    putStrLn s1+#endif++#if USE_SOP++#if 1+    -- Testing rnfpDyn -- working+    putStrLn "\nTesting SOP rnfpDyn with SYB generic stop condition.\n"+#if 1+    let exp21 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+    let get21 (_,xs,_) = (xs!!2)+    let f21_a :: [Int] -> PatNode+        f21_a _ = WI emptyPatNodeAttrs+    let f21_b :: Bool -> PatNode+        f21_b _ = WI emptyPatNodeAttrs+    let fg21 :: GenericQ PatNode+        fg21 = mkQ (WR emptyPatNodeAttrs) f21_a `extQ` f21_b+--  let fg21 = mkQ (WR emptyPatNodeAttrs) f21_a `extQ` f21_b :: forall a. Data a => a -> PatNode+--  let fg21 = mkQ (WR emptyPatNodeAttrs) f21_a `extQ` f21_b :: GenericQ PatNode+    putStrLn $ show $ get21 $ forcepDyn fg21 exp21+#else+    let exp21 = (3.4, [5,__,7], False) :: (Float, [Int], Bool)+    let get21 (_,xs,_) = (xs!!2)+#if 0+#elif 1+    let f21 :: [Int] -> PatNode+        f21 _ = WI emptyPatNodeAttrs+    let fg21 :: GenericQ PatNode+        fg21 = mkQ (WR emptyPatNodeAttrs) f21+#elif 0+    let f21 :: (Float,[Int],Bool) -> PatNode+    -- Cannot do in SYB? We can't just "stop on any 3-tuple"; we need+    -- to give the types of the components of the tuple as well?+--  let f21 :: (,,) a b c -> PatNode+--  let f21 :: (,,) * * * -> PatNode+--  let f21 :: (,,) -> PatNode+--  let f21 :: (a,b,c) -> PatNode+--  let f21 :: (Typeable a,Typeable b,Typeable c) => (a,b,c) -> PatNode+--  let f21 :: (Data a,Typeable a,Data b,Typeable b,Data c,Typeable c) => (a,b,c) -> PatNode+        f21 _ = WI emptyPatNodeAttrs+--      f21 (x,y,z) = WI emptyPatNodeAttrs+    let fg21 :: GenericQ PatNode+        fg21 = mkQ (WR emptyPatNodeAttrs) f21+#elif 0+    let f21 :: Int -> PatNode+        f21 x = WI emptyPatNodeAttrs+--      f21 x = case x of { 5 -> WR emptyPatNodeAttrs ; _ -> WI emptyPatNodeAttrs }  -- "case x" forces x!+--  let (f21::Int->PatNode) x = case x of { 5 -> WR emptyPatNodeAttrs ; _ -> WI emptyPatNodeAttrs }+    let fg21 :: GenericQ PatNode+        fg21 = mkQ (WR emptyPatNodeAttrs) f21+#endif+    putStrLn $ show $ get21 $ forcepDyn fg21 exp21+#endif+#endif++#if 1+    -- Testing rnfpDyn again -- not working...+    putStrLn "\nTesting SOP/SYB rnfpDyn again.\n"+#if 0+#elif 1+    let exp22 = [[[__]],[[__,6],[7]]] :: [[[Int]]]+-- These three should be exactly equivalent (same core produced)?+--  let get22 xs = (((xs!!1)!!1)!!0)+--  let get22 [_,[[_,n],_]] = n+    let get22 (_:((_:n:_):_):_) = n+    let f22a :: Int -> PatNode+        f22a _ = trace "Noo-A" $ WI emptyPatNodeAttrs+    let f22b :: [Int] -> PatNode+        f22b _ = trace "Noo-B" $ WI emptyPatNodeAttrs+    let f22c :: [[Int]] -> PatNode+        f22c _ = trace "Noo-C" $ WI emptyPatNodeAttrs+    let f22d :: [[[Int]]] -> PatNode  -- goes boom+        f22d _ = trace "Noo-D" $ WI emptyPatNodeAttrs+    let fg22 :: GenericQ PatNode+        fg22 = mkQ (WR emptyPatNodeAttrs) id+--                                                              -- blows+--                                                 `extQ` f22d  -- blows+                                       `extQ` f22c `extQ` f22d  -- FINE+--                         `extQ` f22b `extQ` f22c `extQ` f22d  -- FINE+--             `extQ` f22a `extQ` f22b `extQ` f22c              -- blows+--             `extQ` f22a `extQ` f22b `extQ` f22c `extQ` f22d  -- FINE+#elif 0+    let exp22 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]+    let get22 xs = (((xs!!1)!!2)!!0)+    let f22 :: Int -> PatNode        -- goes boom+--  let f22 :: [Int] -> PatNode      -- goes boom+--  let f22 :: [[Int]] -> PatNode    -- goes boom+--  let f22 :: [[[Int]]] -> PatNode  -- goes boom+        f22 _ = trace "Noo-A" $ WI emptyPatNodeAttrs+    let fg22 :: GenericQ PatNode+        fg22 = mkQ (WR emptyPatNodeAttrs) f22+#else+    let exp22 = (3.4, [[[__]],[[__,6],__,[7]]], __) :: (Float, [[[Int]]], Bool)+--  let exp22 = (3.4, [[__],[[__,6],__,[7]]], __) :: (Float, [[[Int]]], Bool)+    let get22 (_,xs,_) = (((xs!!1)!!2)!!0)+    let f22_a :: [[Int]] -> PatNode+        f22_a _ = WI emptyPatNodeAttrs+    let f22_b :: Bool -> PatNode+        f22_b _ = WI emptyPatNodeAttrs+    let fg22 :: GenericQ PatNode+        fg22 = mkQ (WR emptyPatNodeAttrs) f22_a `extQ` f22_b+--  let fg22 = mkQ (WR emptyPatNodeAttrs) f22_a `extQ` f22_b :: forall a. Data a => a -> PatNode+--  let fg22 = mkQ (WR emptyPatNodeAttrs) f22_a `extQ` f22_b :: GenericQ PatNode+#endif+    putStrLn $ show $ get22 $ forcepDyn fg22 exp22+#endif++#if 1+#if __GLASGOW_HASKELL__ >= 708+-- XXX This isn't working yet.+-- And it won't work naively either, b/c SOP is *shallow*...+-- Note:+-- *Foo> :m +Generics.SOP+-- *Foo Generics.SOP> datatypeInfo (Proxy :: Proxy [[Int]])+-- ADT "GHC.Types" "[]" (Constructor "[]" :* (Infix ":" RightAssociative 5 :* Nil))+-- So, as done in GNFDataP, we need to pattern-match in tandem on this,+-- through the *S and *P SOP recursion auxilliaries...+-- XXX I came back to this -- getting type errors, could probably+-- get rid of by adding extra functions (as per GNFDataP.hs code),+-- but remember, this is supposed to be API-user code ... if it's+-- going to be that painful to write, we have a problem...+-- (Still, can probably write friendlier wrapper functions.)+    -- Testing rnfpDyn' with SOP generic stop condition+    putStrLn "\nTesting SOP rnfpDyn' with SOP generic stop condition.\n"+#if 0+#elif 1+    putStrLn $ doit23+#elif 0+    let exp23 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]+    let get23 xs = (((xs!!1)!!2)!!0)+    let fg23 :: forall a. (Generic a, HasDatatypeInfo a) => a -> PatNode+        fg23 d | cname == "[[Int]]"  = WI emptyPatNodeAttrs+               | otherwise           = WR emptyPatNodeAttrs+          where+#if 1+           ADT mname tname (Constructor cname :* _) = dti+--         ADT mname tname (Constructor cname :* _) = dti :: DatatypeInfo (Code a)+--         (mname,tname,cname) = case dti of ...+--         ADT mname tname (Constructor cname :* (Infix ":" RightAssociative 5 :* Nil)) = dti+#endif+           dti = datatypeInfo proxy_a+           proxy_a = Proxy :: Proxy a+           xrep = from d+    putStrLn $ show $ get23 $ forcepDyn' fg23 exp23+#endif+#endif+#endif++#if 1+-- Gave up on the fully-SOP one, at least for now, b/c+-- it seems like it's hard to write (much uglier than SYB one),+-- and then writing a friendly wrapper looks tough as well.+-- But here is a 3rd alternative, hybrid SOP/Typeable which+-- is even simpler from the user perspective, only less efficient.+    putStrLn "Testing SOP rnfpDyn'' with Typeable generic stop condition\n"+    let exp24 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]+    let get24 xs = (((xs!!1)!!2)!!0)+    let fg24 :: forall a. Typeable a => a -> PatNode+        fg24 d | t == "[[[Int]]]"  = WI emptyPatNodeAttrs+               | t == "[[Int]]"    = WI emptyPatNodeAttrs+               | otherwise         = WR emptyPatNodeAttrs+         where t = show $ typeOf d+    -- This is a simple alternative to the SOP/SYB hybrid.+    -- If efficiency isn't prime concern, this would appear to be+    -- even simpler ... the above looks much more lucid to me than+    -- the usual SYB way of mkQ/extQ; here, just define one normal+    -- function, and away you go...+    putStrLn $ show $ get24 $ forcepDyn'' fg24 exp24+#endif++#endif++#endif++#if ! FOCUS_TEST++#if 1+    putStrLn "\nTesting Seqable class (tuple with list):\n"+    let test_patterns24 = [+           (1,  1, (3.4, [5, __, 7], False))                        -- okay+         , (2,  2, fP (3.4, fP (5 : fP (__ : fP (7 : []))), __))    -- okay+         , (2,  3, fP (3.4, fP (5 : fI (__ : fP (7 : []))), __))    -- okay+         , (1,  4, fI (3.4, fP (5 : fI (__ : fP (7 : []))), __))    -- XXX+         , (1,  5, fI (3.4, fI (5 : fI (__ : fP (7 : []))), __))    -- okay+         , (2,  6, fI (3.4, fI (5 : fP (__ : fP (7 : []))), __))    -- okay+         , (1,  7, fI (3.4, fP (5 : fI (__ : fP (7 : []))), True))  -- XXX+         , (1,  8, fP (3.4, fI (5 : fI (__ : fP (7 : []))), True))  -- XXX+         , (1,  9, fP (3.4, fI (5 : fI (__ : fI (7 : []))), True))  -- XXX+         ] :: [(Int,Int,(Float,[Int],Bool))]+    doit24 True test_patterns24+#endif++#if 1+    putStrLn "\nTesting Seqable class (nested tuples):\n"+    let test_patterns25 = [+           (1,  1, (3.4, (__, 7), False))       -- okay+         , (1,  2, fI (3.4 ,fI (__, 7) ,__))    -- okay+         , (2,  3, fP (3.4 ,fP (__, 7) ,__))    -- XXX+         , (2,  4, fP (3.4 ,fI (__, 7) ,__))    -- XXX+         , (2,  5, fI (3.4 ,fP (__, 7) ,__))    -- XXX+         , (1,  6, fI (3.4 ,fI (__, 7) ,True))  -- okay+         , (2,  7, fP (3.4 ,fP (__, 7) ,True))  -- XXX+         , (1,  8, fP (3.4 ,fI (__, 7) ,True))  -- okay+         , (2,  9, fI (3.4 ,fP (__, 7) ,True))  -- XXX+         ] :: [(Int,Int,(Float,(Bool,Int),Bool))]+    doit25 True test_patterns25+#endif++#if USE_SOP++#if 1+    putStrLn "\nTesting generic Seqable (tuple with list):\n"+    let test_patterns26 = [+           (1,  1, (3.4, [5, __, 7], False))                        -- okay+         , (2,  2, gP (3.4, gP (5 : gP (__ : gP (7 : []))), __))    -- okay+         , (2,  3, gP (3.4, gP (5 : gI (__ : gP (7 : []))), __))    -- okay+         , (1,  4, gI (3.4, gP (5 : gI (__ : gP (7 : []))), __))    -- XXX+         , (1,  5, gI (3.4, gI (5 : gI (__ : gP (7 : []))), __))    -- okay+         , (2,  6, gI (3.4, gI (5 : gP (__ : gP (7 : []))), __))    -- okay+         , (1,  7, gI (3.4, gP (5 : gI (__ : gP (7 : []))), True))  -- XXX+         , (1,  8, gP (3.4, gI (5 : gI (__ : gP (7 : []))), True))  -- XXX+         , (1,  9, gP (3.4, gI (5 : gI (__ : gI (7 : []))), True))  -- XXX+         ] :: [(Int,Int,(Float,[Int],Bool))]+    doit26 True test_patterns26+#endif++#if 1+    putStrLn "\nTesting generic Seqable (expTJ_*):\n"+-- expTJ_1 = J2 ( 1, J4 ( J3, K3 K2 ( J1 4.5))) False     -- for ref.+-- expTJ_2 = J2 ( 1, J4 ( J3, K3 __ ( J1 4.5))) False+-- expTJ_3 = J2 ( 1, J4 ( __, K3 K2 ( J1 4.5))) False+-- expTJ_4 = J2 ( 1, J4 ( __, K3 __ ( J1 4.5))) __        -- in use+    let test_patterns27 = [+           (1,  1, gI (J2 (gI ( 1, gI (J4 (gI ( __, gI (K3 __ ( gI (J1 4.5)))))))) __))+         , (2,  2, gP (J2 (gP ( 1, gP (J4 (gP ( __, gP (K3 __ ( gP (J1 4.5)))))))) __))+         , (1,  3, gI (J2 (gP ( 1, gP (J4 (gI ( __, gI (K3 __ ( gP (J1 4.5)))))))) __))+         , (2,  4, gP (J2 (gP ( 1, gP (J4 (gI ( __, gI (K3 __ ( gP (J1 4.5)))))))) __))+         , (2,  5, gI (J2 (gP ( 1, gP (J4 (gP ( __, gI (K3 __ ( gP (J1 4.5)))))))) __))+         , (2,  6, gI (J2 (gP ( 1, gP (J4 (gI ( __, gP (K3 __ ( gP (J1 4.5)))))))) __))+         ] :: [(Int,Int,TJ)]+    doit27 True test_patterns27+#endif++#endif++#if 1+    putStrLn "\nTesting PatNodeAttrs (pattern node attributes):\n"+    -- exp = G2 5 __ 7 :: TG+    let test_patterns28 = [+#if 1+           (4,  "^^!")   -- syntax error+         , (4,  "^=^!")  -- syntax error+         , (2,  "=*")  -- XXX broken (at least in observability sense)+         , (2,  "+*")  -- fine (but see no trace message!)+         , (2,  "^*")  -- fine (but get no exception)+#if 1+         , (1,  "+^!")+         , (2,  "+^*")+         , (2,  "+^(.!.)")+         , (3,  "^+()")+         , (3,  "^+(!!)")+         , (2,  "^+(!!!)")+         , (3,  "^+(!!!!)")+#else+-- Later: This is now working -- too well, and the first / encountered+-- puts an end to the testing!+         , (2,  "/*")  -- fine (but no indication of termination)+         , (1,  "/+^!")+         , (2,  "/+^*")+         , (2,  "/+^(.!.)")+         , (3,  "^+/()")+         , (3,  "^+/(!!)")+         , (2,  "^+/(!!!)")+         , (3,  "^+/(!!!!)")+#endif+#else+           (4,  "^^!")   -- syntax error+         , (4,  "^=^!")  -- syntax error+         , (3,  "^=()")+         , (3,  "^=(!!)")+         , (2,  "^=(!!!)")+         , (3,  "^=(!!!!)")+--       , (1,  "/=+^!")+--       , (2,  "/=+^*")       -- XXX+--       , (2,  "/=+^(.!.)")   -- XXX+         , (2,  "*")+         , (2,  "(.!.)")+         , (2,  "=*")  -- XXX broken (at least in observability sense)+         , (2,  "+*")  -- fine (but see no trace message!)+         , (2,  "^*")  -- fine (but get no exception)+--       , (2,  "/*")  -- fine (but no indication of termination)+--       , (2,  "/+^(.!.)")  -- fine+#endif+         ]+    doit28 True test_patterns28+#endif++#if 1+    putStrLn "\nTesting PatNodeAttrs (pattern node attributes):\n"+    -- exp = ([0..999999],[1000000..1999999]),[2000000..3999999])+    let test_patterns29 = [+           (1,  "+( +>ba(+*+*)=+*)")+         , (1,  "+(=+>ba(+*+*) +*)")+--       , (1,  "(>ba(+*+*)+=*)")+         ]+    doit29 True test_patterns29+#endif++#endif++    putStrLn "\n"++    return 0++-------------------------------------------------------------------------------++  hline :: String+  hline = "---------------------------------------------------\n"+  hdline :: String+  hdline = "===================================================\n"++-------------------------------------------------------------------------------++  doit1 :: Int -> Int -> Int -> String -> IO String+  doit1 i j k acc+   -- this glitch (the exception that seemingly escapes my catch)+   -- happens just for these combos (and for all j):+-- | i == 3 && k == 4  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+-- | i == 3 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+-- | i == 3 && j < 4 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+   | k == 7  = return acc+   | j == 6  = doit1 1 1 (1+k) acc+   | i == 5  = doit1 1 (1+j) k acc+   | otherwise  = do+      fexp <- catch+               -- The semantics of the !'s here are not what they were,+               -- since forcing in some places. [?] But at least the+               -- first one seems definitely still needed...+               -- LATER: The second one is also needed, finally seen!+               -- (It is needed for a version of getE _ = "getee", only.)+               -- XXX I'm just not sure whether the second ! is better+               -- to leave in or leave out...+               ( return $! get $! forcen dep exp )+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+--    doit1 (1+i) j k $! force $ acc+      doit1 (1+i) j k $! acc+--    doit1 (1+i) j k $ acc+        ++ "( get" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k of+            1 -> expBase1+            2 -> expBase2+            3 -> expBase3+            4 -> expBase4+            5 -> expBase5+            6 -> expBase6+    get = case i of+           1 -> get1+           2 -> get2+--         3 -> unsafePerformIO . get3  -- yeesh!...+--         3 -> get3+           3 -> get3 (i,j,k)+           4 -> get4+    dep = j++  -- XXX All this fuss to deal with the case that the+  -- entire argument m is undefined (or whatever is going+  -- for "undefined" at the moment...) -- but, none of+  -- the expBase[1-5] have this! ch.+  myFromJust :: Maybe a -> IO (Either () a)+  myFromJust m = do+                    putStrLn "Boo!"+                    catch+                      (myFromJust' m)+                      (\e -> do putStrLn $! show (e::BottomedOut)+                                putStrLn "HERE!"+                                return $! Left ())+  myFromJust' :: Maybe a -> IO (Either () a)+  myFromJust' Nothing = do+--                         throw BottomedOut+                           return $! Left ()+  myFromJust' (Just x) = return $! Right x+--myFromJust _ = throw BottomedOut++--------------------------------++  doit2 :: Int -> Int -> Int -> String -> IO String+  doit2 i j k acc+-- | k == 2  = {- trace (show (i,j,k)) $ -} return acc+-- | k == 7  = return acc+   | k == 27  = return acc+-- | k == 21  = return acc+-- | k == 5  = return acc+-- | j == 15  = doit2 1 0 (1+k) acc+   | j == 11  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+-- | j == 8  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+-- | j == 3  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc+-- | i == 3  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc+#else+   | i == 2  = doit2 1 (1+j) k acc+-- | i == 3  = doit2 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+--             ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit2 (1+i) j k $! acc+        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expTB_" ++ show (k'-6) ++ " )  "+--      ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expBase" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            7 -> expBase7+            8 -> expBase8+            9 -> expBase9+            10 -> expBase10+            11 -> expBase11+            12 -> expBase12+            13 -> expBase13+            14 -> expBase14+            15 -> expBase15+            16 -> expBase16+            17 -> expBase17+            18 -> expBase18+            19 -> expBase19+            20 -> expBase20+            21 -> expBase20  -- fudge it!!+            22 -> expBase22+            23 -> expBase23+            24 -> expBase24+            25 -> expBase25+            26 -> expBase26+            27 -> expBase27+            28 -> expBase28+            29 -> expBase29+            30 -> expBase30+            31 -> expBase31+            32 -> expBase32+    get = case i of+           1 -> if k' >= 27 then getB_3 else getB_1+           2 -> getB_2+    dep = j'+    j' = j+--  j' = j+11+--  k' = k+26+    k' = k+6++  doit3 :: Int -> Int -> Int -> String -> IO String+  doit3 i j k acc+   | k == 2  = return acc+   | j == 8  = {- trace (show (i,j,k)) $ -} doit3 1 1 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit3 1 (1+j) k acc+#else+   | i == 2  = doit3 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit3 (1+i) j k $! acc+        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            21 -> expBase21+    get = case i of+           1 -> getA+    dep = j'+    i' = i+    j' = j+    k' = k+20++  doit4 :: Int -> Int -> Int -> String -> IO String+  doit4 i j k acc+-- | k == 2  = return acc+   | k == 4  = return acc+   | j == 8  = {- trace (show (i,j,k)) $ -} doit4 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit4 1 (1+j) k acc+#else+   | i == 2  = doit4 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit4 (1+i) j k $! acc+        ++ "( getE $ forcen " ++ show dep ++ " expTE_" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            1 -> expTE_1+            2 -> expTE_2+            3 -> expTE_3+    get = case i of+           1 -> getE+    dep = j'+    i' = i+    j' = j+    k' = k++-------------------------------------------------------------------------------++  doit5 :: Int -> Int -> Int -> String -> IO String+  doit5 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit5 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit5 1 (1+j) k acc+#else+   | i == 2  = doit5 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit5 (1+i) j k $! acc+        ++ "forcen " ++ show dep ++ " expN_" ++ show k' ++ " `seq` ()  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            1 -> expN_1+    get = case i of+           1 -> getN_1+    dep = j'+    i' = i+    j' = j+    k' = k++-------------------------------------------------------------------------------++  doit6 :: Int -> Int -> Int -> String -> IO String+  doit6 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit6 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit6 1 (1+j) k acc+#else+   | i == 2  = doit6 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit6 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_2+    get = case i of+           _ -> getN_2+    dep = j'+    i' = i+1+    j' = j+    k' = k+1++-------------------------------------------------------------------------------++  doit7 :: Int -> Int -> Int -> String -> IO String+  doit7 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit7 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit7 1 (1+j) k acc+#else+   | i == 2  = doit7 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit7 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_3+    get = case i of+           _ -> getN_3+    dep = j'+    i' = i+2+    j' = j+    k' = k+2++-------------------------------------------------------------------------------++  doit8 :: Int -> Int -> Int -> String -> IO String+  doit8 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit8 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit8 1 (1+j) k acc+#else+   | i == 2  = doit8 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit8 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_4+    get = case i of+           _ -> getN_3+    dep = j'+    i' = i+2+    j' = j+    k' = k+3++-------------------------------------------------------------------------------++#if 0++#if 0+  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+  patP_1 = Node (TR [typeOf ((__,__,__)::(Float, [Int], Bool))])+             [ Node (TR [typeOf (__::Bool)]) []+--           [ Node (TR [typeOf (__::Float)]) []+--           [ Node (NTR [typeOf (__::Bool)]) []+--           [ Node (NTR [typeOf (__::Float)]) []+--           , Node WS []+             , Node (TW [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) [ Node WS [], Node WS [] ]  -- why not?+             , Node WW []+--           , Node I []+             ]+  getP_1 (_,xs,_) = show $ (xs!!2)+#endif++  doit9 :: IO String+  doit9 = do+#if 0+    putStrLn $ intercalate "\n"+     [ ""+     , "expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+     , "patP_1 = Node (T [typeOf ((__,__,__)::(Float, [Int], Bool))])"+     , "           [ Node W []"+     , "           , Node (T [typeOf ([__]::[Int])]) []"+     , "           , Node I []"+     , "           ]"+     , "getP_1 (_,xs,_) = show $ (xs!!2)"+     ]+    putStrLn "getP_1 $ forcep patP_1 expP_1"+#endif+    s <- catch+             ( return $! getP_1 $! forcep patP_1 expP_1 )+--           ( return $! getP_2 $! forcep patP_2 expP_2 )+--           ( return $! getP_3 $! forcep patP_3 expP_3 )+             -- ErrorCall if use __ = undefined+             -- BottomedOut if use __ = throw BottomedOut+             (\e -> do let err = show (e :: ErrorCall)+--           (\e -> do let err = show (e :: BottomedOut)+                       return err)+    return s++#endif++-------------------------------------------------------------------------------++  doit10 :: Bool -> [(Int,String)] -> IO ()+  doit10 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit10 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit10: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit10 False t++-------------------------------------------------------------------------------++  doit11 :: Bool -> [(Int,String,String)] -> IO ()+  doit11 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit11 b ((code,patstr1,patstr2):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit11: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let patstrU = showPat $ unionPats [compilePat patstr1, compilePat patstr2]+                let pat1 = compilePat patstr1+                let pat2 = compilePat patstr2+                let patU = unionPats [pat1,pat2]+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ ( forcep patstr2 . forcep patstr1 ) exp"+--                putStrLn "? = get $ ( forcep ( unionPatsStr [ patstr1, patstr2 ] ) ) exp"+                  putStrLn "? = get $! ( forcep_ ( unionPats [ pat1, pat2 ] ) ) exp"+                  putStrLn "(Results were more interesting with a previous semantics...)."+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr1                     = " ++ patstr1+                putStrLn $ "patstr2                     = " ++ patstr2+                putStrLn $ "patstrU                     = " ++ patstrU+                if code > 4+                then putStrLn $  "expected value              = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat patstr1  = " ++ showPat pat1+                putStrLn $ "showPat.compilePat patstr2  = " ++ showPat pat2+                putStrLn $ "showPat.compilePat patstrU  = " ++ showPat patU+                if code <= 4+                then putStrLn $  "expected value              = " ++ expect+                else return ()+                putStr "actual value                = "+                let s1 = get $! ( forcep patstr2 . forcep patstr1 ) exp+                putStrLn s1+                putStr "actual value                = "+                let s2 = get $! forcep patstrU exp+#if 1+                let s3 = s2+#else+                putStrLn s2+                let s3 = get $! forcep_ ( unionPats [ pat1, pat2 ] ) exp+#endif+                return $! s3+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit11 False t++-------------------------------------------------------------------------------++  doit12 :: Bool -> [(Int,String,[Int],[(Int,String)])] -> IO ()+--doit12 :: Bool -> [(Int,String,String,[(Int,String)])] -> IO ()+  doit12 _ [] = do+                   return ()+  doit12 b ((code,patstr1,path,isibs'):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit12: unexpected code " ++ show code+    s <- catch+           ( do+                let target = compilePat patstr1+--              let path = compilePat patstr2+                let isibs = map (\ (x,y) -> (x,compilePat y)) isibs'+                if b+                then do+                  putStr hdline+                  putStrLn "Testing splicePats."+                  putStr hline+                else return ()+                putStrLn $ "target       " ++ patstr1+                putStrLn $ "path         " ++ show path+--              putStrLn $ "path         " ++ patstr2+                putStrLn $ "isibs        " ++ show isibs'+                let s1 = force $ showPat $ splicePats target path isibs+--              let s1 = showPat $! splicePats target path isibs+--              let s1 = showPat $ splicePats target path isibs+                putStr "result       "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    if null t then return () else putStr hline+    doit12 False t++-------------------------------------------------------------------------------++  doit12b :: Bool -> [(Int,String,[Int],[Int])] -> IO ()+  doit12b _ [] = do+                   return ()+  doit12b b ((code,patstr1,path,isibs'):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit12b: unexpected code " ++ show code+    s <- catch+           ( do+                let target = compilePat patstr1+                let isibs = isibs'+                if b+                then do+                  putStr hdline+                  putStrLn "Testing elidePats."+                  putStr hline+                else return ()+                putStrLn $ "target       " ++ patstr1+                putStrLn $ "path         " ++ show path+                putStrLn $ "isibs        " ++ show isibs'+                let s1 = force $ showPat $ elidePats target path isibs+                putStr "result       "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    if null t then return () else putStr hline+    doit12b False t++-------------------------------------------------------------------------------++  -- This is the first recursive test [much later than "12" would suggest].+  doit12c :: Bool -> [(Int,String,[Int])] -> StdGen -> Int -> IO StdGen+--doit12c :: Bool -> [(Int,String,[Int],Int)] -> StdGen -> IO StdGen+--doit12c :: Bool -> [(Int,String,StdGen,[Int],Int)] -> IO StdGen+--doit12c :: Bool -> [(Int,String,StdGen,[Int],Int)] -> IO ()+  doit12c _ [] g _ = do+                   return g+--                 return ()+  doit12c b lst@((code,patstr1,path):t) g 0 = return g+  doit12c b lst@((code,patstr1,path):t) g nreps = do  -- but singleton expected?+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit12c: unexpected code " ++ show code+    (s, g') <- catch+--  s <- catch+           ( do+                let target = compilePat patstr1+                if b+                then do+                  putStr hdline+                  putStrLn "Testing erodePat."+                  putStr hline+                else return ()+                putStrLn $ "target       " ++ patstr1+                putStrLn $ "stdgen       " ++ show g+                putStrLn $ "path         " ++ show path+                let (rslt, g') = erodePat g path target+                let s1 = force $ showPat $ rslt+--              let s1 = force $ showPat $ erodePat g path target+                putStr "result       "+                return $! (s1, g')+--              return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return (err, g))+--                   return err)+    putStrLn s+    putStr hline+    doit12c False lst g' (-1+nreps)+--  doit12c False t g' (-1+nreps)++-------------------------------------------------------------------------------++  doit13 :: Bool -> [(Int,[String],String)] -> IO ()+  doit13 _ [] = do+                   putStr hline+                   return ()+  doit13 b ((code,patstrlst,expectstr):t) = do+    s <- catch+           ( do+                s1 <- case code of+-- Where were they done already?+-- Oh, in doit11 and doit12 above...+                       1 -> error $ hline ++ "unionPats test already done test13-1!"+--                     4 -> error $ hline ++ "unionPatsStr test already done test13-4!"+                       10 -> error $ hline ++ "splicePats test already done test13-10!"+                       11 -> error $ hline ++ "isPath test already done test13-11!"+    --  1    unionPats       :: [ Pat ] -> Pat+    --  2  * intersectPats   :: [ Pat ] -> Pat+    --  3  * subPat          :: Pat -> Pat -> Bool+--  --  4    unionPatsStr    :: [ String ] -> String+    --  5  * emptyPat        :: Pat+    --  6  * mkPat           :: forall d. Data d => d -> Pat+    --  7  * growPat         :: forall d. Data d => Pat -> d -> Pat+    --  8  * shrinkPat       :: Pat -> Pat+    --  9  * liftPats        :: [ Pat ] -> Pat+    -- 10    splicePats      :: Pat -> Pat -> [(Int, Pat)] -> Pat+    -- 11    isPath          :: Pat -> Bool+                       2 -> do+                               let patA = patstrlst!!0+                               let patB = patstrlst!!1+                               putStr hline+                               putStrLn "Testing      intersectPats [patA, patB]"+                               putStrLn $ "patA         " ++ patA+                               putStrLn $ "patB         " ++ patB+                               putStr $ "result       "+                               let s1 = force $ showPat $ intersectPats [compilePat patA, compilePat patB]+                               return s1+                       3 -> do+                               let patA = patstrlst!!0+                               let patB = patstrlst!!1+                               putStr hline+                               putStrLn "Testing      subPat patA patB"+                               putStrLn $ "patA         " ++ patA+                               putStrLn $ "patB         " ++ patB+                               let s1 = force $ show $ subPat (compilePat patA) (compilePat patB)+                               if s1 /= expectstr+                               then do putStrLn $ "expect       " ++ expectstr+                                       putStr $ "result       "+                               else putStr $ "as expected  "+                               return s1+                       5 -> do+                               putStr hline+                               putStrLn "Testing      emptyPat"+                               putStr $ "result       "+                               let s1 = force $ showPat $ emptyPat+                               return s1+                       6 -> do+                               putStr hline+                               putStrLn "Testing      mkPat ([1,2,3],(False,\"foo\"))"+                               putStr $ "result       "+                               let s1 = force $ showPat $ mkPat ([1,2,3::Int],(False,"foo"))+                               return s1+                       7 -> do+                               let patA = patstrlst!!0+                               putStr hline+                               putStrLn "Testing      growPat patA ([1,2,3],(False,\"foo\"))"+                               putStrLn $ "patA         " ++ patA+                               putStr $ "result       "+                               let s1 = force $ showPat $ growPat (compilePat patA) ([1,2,3::Int],(False,"foo"))+                               return s1+                       8 -> do+                               let patA = patstrlst!!0+                               putStr hline+                               putStrLn "Testing      shrinkPat patA"+                               putStrLn $ "patA         " ++ patA+                               putStr $ "result       "+                               let s1 = force $ showPat $ shrinkPat (compilePat patA)+                               return s1+                       9 -> do+                               putStr hline+                               putStrLn "Testing      liftPats patstrlst"+                               putStrLn $ "patstrs      " ++ show patstrlst+                               putStr $ "result       "+                               let s1 = force $ showPat $ liftPats $ map compilePat patstrlst+                               return s1+    -- 12    mkPatN          :: Int -> Pat -> Bool+    -- 13    elidePats        :: Pat -> Pat -> [Int] -> Pat+    -- 14    erodePat        :: StdGen -> [Int] -> Pat -> (Pat, StdGen)+                       12 -> do+                               putStr hline+                               putStrLn "Testing      mkPatN 2 ([1,2,3],(False,\"foo\"))"+                               putStr $ "result       "+                               let s1 = force $ showPat $ mkPatN 2 ([1,2,3::Int],(False,"foo"))+                               return s1+                       _ -> error $ "doit13: unexpected code " ++ show code+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit13 False t++-------------------------------------------------------------------------------++  doit14 :: Bool -> [(Int,String)] -> IO ()+  doit14 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit14 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit14: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit14 False t++-------------------------------------------------------------------------------++#if USE_SOP++  -- This is an adaptation of doit10 to user-defined datatypes,+  -- for testing GNFDataP, which is finally within reach thanks+  -- to SOP!+  doit15 :: Bool -> [(Int,String)] -> IO ()+  doit15 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit15 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit15: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTG_5  -- ( G1, G2 5 __ 7, __ )+--              let exp = expTG_4  -- ( G1, G2 5 6 7, __ )+--              let exp = expTG_3  -- ( G1, G2 __ __ 7, __ )+--              let exp = expTG_2  -- ( __, G2 __ __ 7, __ )+--              let exp = expTG_1  -- ( G1, G2 5 6 7, True )+--              let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get = getG+--              let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (G1, G2 5 __ 7, __) :: (TG, TG, Bool)"+                  putStrLn "get (_,(G2 _ _ n),_) = n"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit15 False t++-------------------------------------------------------------------------------++  doit16 :: Bool -> [(Int,String)] -> IO ()+  doit16 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit16 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit16: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTG_6  -- G2 5 __ 7+                let pat = compilePat patstr+                let get = getG'+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = G2 5 __ 7 :: TG"+                  putStrLn "get (G2 _ _ n) = n"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit16 False t++-------------------------------------------------------------------------------++  doit17 :: Bool -> [(Int,String)] -> IO ()+  doit17 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit17 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "4.5"+                  2 -> "Prelude.undefined"+                  3 -> "4.5 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "4.5 (but \"# with subpattern\" warning)"+                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit17: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTH_1  -- H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False+--              let exp = expTH_2  -- H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] False+--              let exp = expTH_3  -- H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] __+                let exp = expTH_4  -- H2 1 [H1 2.3, H3, H4 (__, I3 __ (H1 4.5))] __+                let pat = compilePat patstr+                let get = getH+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] __ :: TH"+--                putStrLn "exp = H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False :: TH"+                  putStrLn "get = (H2 _ [_, _, H4 (_, I3 _ (H1 f))] _) = show f"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit17 False t++-------------------------------------------------------------------------------++  doit18 :: Bool -> [(Int,String)] -> IO ()+  doit18 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "4.5"+                  2 -> "Prelude.undefined"+                  3 -> "4.5 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "4.5 (but \"# with subpattern\" warning)"+                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit18: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTJ_1  -- J2 (1, J4 (J3, K3 K2 (J1 4.5))) False+--              let exp = expTJ_2  -- J2 (1, J4 (J3, K3 __ (J1 4.5))) False+                let exp = expTJ_3  -- J2 (1, J4 (__, K3 K2 (J1 4.5))) False+--              let exp = expTJ_4  -- J2 (1, J4 (__, K3 __ (J1 4.5))) __+                let pat = compilePat patstr+                let get = getJ+                if b+                then do+                  putStrLn "==================================================="+--                putStrLn "exp = J2 (1, J4 (J3, K3 K2 (J1 4.5))) False"+                  putStrLn "exp = J2 (1, J4 (J3, K3 __ (J1 4.5))) False"+--                putStrLn "exp = J2 (1, J4 (__, K3 K2 (J1 4.5))) False"+--                putStrLn "exp = J2 (1, J4 (__, K3 __ (J1 4.5))) __"+                  putStrLn "get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18 False t++-------------------------------------------------------------------------------++  doit18b :: Bool -> [(Int,String)] -> IO ()+  doit18b _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18b b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "1"+                  2 -> "Prelude.undefined"+                  3 -> "1 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "1 (but \"# with subpattern\" warning)"+                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit18b: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTJ_5  -- J2 (1, J4 (__, K2)) False+                let pat = compilePat patstr+                let get = getJ'+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = J2 (1, J4 (__, K2)) False"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+--                putStrLn "get (J2 (n, J4 (_, K2)) False) = show n"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18b False t++-------------------------------------------------------------------------------++  doit18c :: Bool -> [(Int,String)] -> IO ()+  doit18c _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18c b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "1"+                  2 -> "Prelude.undefined"+                  3 -> "1 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "1 (but \"# with subpattern\" warning)"+                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit18c: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTJ_6  -- J4 (__, K2)+                let pat = compilePat patstr+                let get = getJ6+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = J4 (__, K2)"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+--                putStrLn "get (J4 (_, K2)) = show n"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18c False t++-------------------------------------------------------------------------------++  doit18d :: Bool -> [(Int,String)] -> IO ()+  doit18d _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18d b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "1"+                  2 -> "Prelude.undefined"+                  3 -> "1 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "1 (but \"# with subpattern\" warning)"+                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit18d: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTJ_7  -- (__, K2)+                let pat = compilePat patstr+                let get = getJ7+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (__, K2)"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18d False t++-------------------------------------------------------------------------------++  doit18e :: Bool -> [(Int,String)] -> IO ()+  doit18e _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18e b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "1"+                  2 -> "Prelude.undefined"+                  3 -> "1 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "1 (but \"# with subpattern\" warning)"+                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit18e: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTJ_8  -- __ :: TJ+                let pat = compilePat patstr+                let get = getJ8+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = __ :: TJ"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18e False t++-------------------------------------------------------------------------------++  doit18f :: Bool -> [(Int,String)] -> IO ()+  doit18f _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18f b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "okay"+                  2 -> "Prelude.undefined"+                  3 -> "okay (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "okay (but \"# with subpattern\" warning)"+                  6 -> "okay (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit18f: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (K5 (__::TJ))+                let pat = compilePat patstr+                let get _ = "okay"+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (K5 (__::TJ))"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18f False t+++-------------------------------------------------------------------------------++  doit18g :: Bool -> [(Int,String)] -> IO ()+  doit18g _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18g b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "okay"+                  2 -> "Prelude.undefined"+                  3 -> "okay (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "okay (but \"# with subpattern\" warning)"+                  6 -> "okay (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit18g: unexpected code " ++ show code+    s <- catch+           ( do+#if TRY_THIS+                let exp = K3 (__::TK) J3+#else+                let exp = K3 K2 (__::TJ)+#endif+                let pat = compilePat patstr+                let get _ = "okay"+                if b+                then do+                  putStrLn "==================================================="+#if TRY_THIS+                  putStrLn "exp = K3 (__::TK) J3"+#else+                  putStrLn "exp = K3 K2 (__::TJ)"+#endif+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18g False t++-------------------------------------------------------------------------------++  doit19 :: Bool -> [(Int,String)] -> IO ()+  doit19 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit19 b ((code,patstr):t) = do+--  let expstr = "True"+    let expstr = "5.6"+    let expect = case code of+                  1 -> expstr+                  2 -> "Prelude.undefined"+                  3 -> expstr ++ " (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> expstr ++ " (but \"# with subpattern\" warning)"+                  6 -> expstr ++ " (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit19: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTL_1  -- L1 5.6 (M1 True)+                let exp = expTL_2  -- L1 5.6 (M1 __)+--              let exp = expTL_3  -- L1 5.6 __+--              let exp = expTL_4  -- L1 __ (M1 True)+                let pat = compilePat patstr+                let get = getL+--              let get = getL'+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = L1 5.6 (M1 __)"+--                putStrLn "exp = L1 5.6 __"+--                putStrLn "exp = L1 __ (M1 True)"+                  putStrLn "get (L1 f (M1 _)) = show f"+--                putStrLn "get (L1 f _) = show f"+--                putStrLn "get (L1 _ (M1 b)) = show b"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit19 False t++-------------------------------------------------------------------------------++  doit20 :: Bool -> [(Int,String)] -> IO ()+  doit20 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit20 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "4.5"+                  2 -> "Prelude.undefined"+                  3 -> "4.5 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "4.5 (but \"# with subpattern\" warning)"+                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit20: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTK_1  -- K3 K2 (J1 4.5)+                let exp = expTK_2  -- K3 __ (J1 4.5)+                let pat = compilePat patstr+                let get = getK+                if b+                then do+                  putStrLn "==================================================="+--                putStrLn "exp = K3 K2 (J1 4.5)"+                  putStrLn "exp = K3 __ (J1 4.5)"+                  putStrLn "get = (K3 _ (J1 f)) = show f"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit20 False t++-------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 708+  doit23 :: String+  doit23 = show $ fg23 exp23+--doit23 = show $ get23 $ forcepDyn' fg23 exp23+   where+    exp23 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]+    get23 xs = (((xs!!1)!!2)!!0)+#if 0+    fg23 :: forall a. (Generic a, HasDatatypeInfo a) => a -> DatatypeInfo (Code a)+    fg23 d = dti+#else+    fg23 :: forall a. (Generic a, HasDatatypeInfo a, All2 Show (Code a), Typeable a) => a -> PatNode+#if 1+    fg23 d = doit23' dti proxy_a d (from d)+#else+    fg23 d | cname == "[[Int]]"  = WI emptyPatNodeAttrs+           | otherwise           = WR emptyPatNodeAttrs+#endif+#endif+     where+--    ADT mname tname (Constructor cname :* _) = dti+--    ADT mname tname (Constructor cname :* _) = dti :: DatatypeInfo (Code a)+--    (mname,tname,cname) = case dti of ...+--    ADT mname tname (Constructor cname :* (Infix ":" RightAssociative 5 :* Nil)) = dti+      dti = datatypeInfo proxy_a+      proxy_a = Proxy :: Proxy a+      xrep = from d++  doit23' :: forall a.+             (+               Generic a+             , HasDatatypeInfo a+--           , All2 NFDataP (Code a)+             , All2 Show (Code a)+             , Typeable a+--           , NFDataN a+--           , NFDataP a+             ) =>+                     DatatypeInfo (Code a)+                  -> Proxy a+                  -> a+                  -> Rep a+                  -> PatNode+  doit23' (ADT     _ _ cs) proxy_a x xrep+   = doit23'' cs         proxy_a x xrep+  doit23' (Newtype _ _ c ) proxy_a x xrep+   = doit23'' (c :* Nil) proxy_a x xrep++  doit23'' :: forall a xss.+            (+              Generic a+            , HasDatatypeInfo a+            , All2 Show xss+            ) =>+                    NP ConstructorInfo xss+                 -> Proxy a+                 -> a+                 -> SOP I xss+                 -> PatNode+  doit23'' (m :* _) proxy_a x (SOP (Z xs))+   | tx == "[[Int]]"  = WI emptyPatNodeAttrs+   | otherwise        = WR emptyPatNodeAttrs+   where+    !_ = trace ("*** "++tx) $ ()+    tx | (Constructor n) <- m  = n+       | (Infix n _ _) <- m    = n+       | (Record n _) <- m     = n+  doit23'' (m :* ms) proxy_a x (SOP (S xss))+   = doit23'' ms proxy_a x (SOP xss)+  doit23'' _ _ _ _ = error "doit23'': unexpected case!!"+#endif++-------------------------------------------------------------------------------++#endif++  doit24 :: Bool -> [(Int,Int,(Float,[Int],Bool))] -> IO ()+  doit24 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit24 b ((code,ident,exp):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "7 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit24: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = force_ Propagate (force_ Propagate 3.4, force_ Propagate (force_ Propagate 5 : (force_ Propagate __ : (force_ Propagate 7 : force_ Propagate []))), force_ Propagate __) :: (Float, [Int], Bool)+--              let seq_exp = mkSeqableHarness exp+--              let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = <refer to test code>"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $! exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+--              putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+--              putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr $ show ident ++ " actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit24 False t++-------------------------------------------------------------------------------++  doit25 :: Bool -> [(Int,Int,(Float,(Bool,Int),Bool))] -> IO ()+  doit25 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit25 b ((code,ident,exp):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "7 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit25: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = force_ Propagate (force_ Propagate 3.4, force_ Propagate (force_ Propagate 5 : (force_ Propagate __ : (force_ Propagate 7 : force_ Propagate []))), force_ Propagate __) :: (Float, [Int], Bool)+--              let seq_exp = mkSeqableHarness exp+--              let pat = compilePat patstr+                let get (_,(_,x),_) = show x+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = <refer to test code>"+                  putStrLn "get (_,(_,x),_) = show x"+                  putStrLn "? = get $! exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+--              putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+--              putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr $ show ident ++ " actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit25 False t++-------------------------------------------------------------------------------++#if USE_SOP++  doit26 :: Bool -> [(Int,Int,(Float,[Int],Bool))] -> IO ()+  doit26 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit26 b ((code,ident,exp):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "7 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit26: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = force_ Propagate (force_ Propagate 3.4, force_ Propagate (force_ Propagate 5 : (force_ Propagate __ : (force_ Propagate 7 : force_ Propagate []))), force_ Propagate __) :: (Float, [Int], Bool)+--              let seq_exp = mkSeqableHarness exp+--              let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = <refer to test code>"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $! exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+--              putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+--              putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr $ show ident ++ " actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit26 False t++-------------------------------------------------------------------------------++  doit27 :: Bool -> [(Int,Int,TJ)] -> IO ()+  doit27 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit27 b ((code,ident,exp):t) = do+    let expect = case code of+                  1 -> "4.5"+                  2 -> "Prelude.undefined"+                  3 -> "4.5 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "4.5 (but \"# with subpattern\" warning)"+                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit27: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTJ_1  -- J2 (1, J4 (J3, K3 K2 (J1 4.5))) False+--              let exp = expTJ_2  -- J2 (1, J4 (J3, K3 __ (J1 4.5))) False+--              let exp = expTJ_3  -- J2 (1, J4 (__, K3 K2 (J1 4.5))) False+--              let exp = expTJ_4  -- J2 (1, J4 (__, K3 __ (J1 4.5))) __+--              let pat = compilePat patstr+                let get = getJ+                if b+                then do+                  putStrLn "==================================================="+--                putStrLn "exp = J2 (1, J4 (J3, K3 K2 (J1 4.5))) False"+--                putStrLn "exp = J2 (1, J4 (J3, K3 __ (J1 4.5))) False"+--                putStrLn "exp = J2 (1, J4 (__, K3 K2 (J1 4.5))) False"+                  putStrLn "exp = J2 (1, J4 (__, K3 __ (J1 4.5))) __"+                  putStrLn "get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f"+                  putStrLn "? = get exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+--              putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+--              putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr $ show ident ++ " actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit27 False t++-------------------------------------------------------------------------------++  doit28 :: Bool -> [(Int,String)] -> IO ()+  doit28 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit28 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "7 (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "7 (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit28: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTG_6  -- G2 5 __ 7+                let pat = compilePat patstr+                let get = getG'+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = G2 5 __ 7 :: TG"+                  putStrLn "get (G2 _ _ n) = n"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit28 False t++-------------------------------------------------------------------------------++  doit29 :: Bool -> [(Int,String)] -> IO ()+  doit29 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit29 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "((999999,1999999),3999999)"+                  2 -> "Prelude.undefined"+                  3 -> "((999999,1999999),3999999) (due to pattern-match failure)"+                  4 -> "syntax error"+                  5 -> "((999999,1999999),3999999) (but \"# with subpattern\" warning)"+                  6 -> "((999999,1999999),3999999) (but \"constraint/subpattern arity mismatch\" warning)"+#if WARN_PATTERN_MATCH_FAILURE+                  13 -> "((999999,1999999),3999999) (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+#else+                  13 -> "((999999,1999999),3999999) (with silent pattern-match failure)"+                  23 -> "Prelude.undefined (with silent pattern-match failure)"+#endif+                  _ -> error $ "doit29: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (([0..999999::Int],[1000000..1999999::Int]),[2000000..3999999::Int])+                let pat = compilePat patstr+                let get ((xs,ys),zs) = show ((last xs,last ys),last zs)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (([0..999999],[1000000..1999999]),[2000000..3999999])"+                  putStrLn "get ((xs,ys),zs) = show ((last xs,last ys),last zs)"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit29 False t++-------------------------------------------------------------------------------++#endif+
+ tests/Blah_old_grammar.hs view
@@ -0,0 +1,3000 @@++-------------------------------------------------------------------------------++-- Disclaimer: I've not used HUnit yet. I'm using it only+-- as a "hook" so can compile/test in less clock time...+-- (I forget the details of how why.)+--+-- Obviously, this should use proper HUnit eventually.+-- And QuickCheck and SmallCheck, DEFINITELY!!!...+-- This is a great case for those; and shape-syb no less.+--+-- This file could be cleaned up a lot, but that's+-- not quite a priority at the moment...+--+-- The reason I shied away from making it real HUnit tests+-- is probably related to the fancy exception throwing/catching+-- and catching of all exceptions (including error), etc.+-- Which was aggravated by the nature of this project and+-- of its tests, which hit bottom as a matter of course...+--+-- Yeah; and looking at examples of QuickCheck and SmallCheck,+-- it's still not clear to me how to work bottoming-out+-- into my tests.+--   I guess I could catch the bottoms in my code, and return+-- some reserved value to indicate that it occurred?...++-------------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------++#define FOCUS_TEST 0+#define USE_TRACE 0++-------------------------------------------------------------------------------++-- Later: This may work with some versions of GHC, but I'm quite+-- sure I've seen it not work with some recent version...+-- Unfortunately, this doesn't work -- all pragmas are processed,+-- regardless of CPP (so CPP must run after).+-- The fact the CPP itself can be set via a pragma complicates this.+-- It could be made an exception, and the LANGUAGE CPP pragma could+-- be parsed regardless of CPP context (as all pragmas currently are).+-- As it is, we need separate source modules, and to switch at+-- import statements (and in the .cabal file).+-- THIS IS A BUG.+-- So anyhow, this is only here as a reminder:+---  #if ! HASKELL98_FRAGMENT+---  {-# LANGUAGE ... #-}+---  #endif+  {-# LANGUAGE DeriveGeneric #-}+  {-# LANGUAGE DeriveDataTypeable #-}  -- to make BottomedOut+  {-# LANGUAGE BangPatterns #-}++  {-# LANGUAGE Rank2Types #-}  -- for SYB (testing rnfpDyn and friends)++-------------------------------------------------------------------------------++  -- SOP pragmas:++  -- Not necessarily needed to work with SOP, but I think it'll+  -- be helpful here [?] ...+  {-# LANGUAGE ScopedTypeVariables #-}+  {-  LANGUAGE AllowAmbiguousTypes #-}++-- Actually, CPP doesn't work with Haskell (GHC) pragmas last I checked...+#if USE_SOP+  {-# LANGUAGE DataKinds #-}+  {-# LANGUAGE TypeFamilies #-}+  {-# LANGUAGE ConstraintKinds #-}+#if __GLASGOW_HASKELL__ < 708+  {-# LANGUAGE GADTs #-}+#endif+  {-# LANGUAGE TemplateHaskell #-}+#endif++-------------------------------------------------------------------------------++  module Blah_old_grammar ( run_tests ) where++-------------------------------------------------------------------------------++  import Bottom+  import Foo+  import FooG++--import Control.DeepSeq.Generics+  import Control.DeepSeq.Bounded+--import Control.DeepSeq.Bounded hiding ( F )+  import Control.DeepSeq.Bounded.Generic++#if 0+  import GHC.Generics+--import GHC.Generics ( Generic )+#endif++  import Data.Maybe++  import Control.Exception+--import Control.Monad ( guard )+  import Control.Monad ( replicateM )+  import Control.Monad ( when )+  import Data.Typeable ( Typeable )+  import Data.Typeable ( typeOf )++  import Data.Data ( Data )++  import Data.Generics.Aliases ( mkQ, extQ, GenericQ )++--import Util ( spoor )+  import Debug.Trace ( trace )+  import Control.DeepSeq++#if __GLASGOW_HASKELL__ >= 708+  import Data.Typeable ( Proxy(..) )+#endif++#if USE_SOP+  import Generics.SOP hiding ( Shape )+#endif++  import System.Random++  import Data.List ( intercalate )++  import System.IO.Unsafe ( unsafePerformIO )++-------------------------------------------------------------------------------++  -- For convenience in GHCi interactive sessions:+  cp = compilePat+  ip = intersectPats+  isp = subPat++  -- For more compact test expressions:+-- XXX Refer to Seqable.hs for comments about JUST_ALIAS_GSEQABLE.+#if 1+#if JUST_ALIAS_GSEQABLE+  fI :: forall a. Generic a => a -> a+  fI = force_ Insulate+  fP :: forall a. Generic a => a -> a+  fP = force_ Propagate+#else+  fI :: forall a. NFDataN a => a -> a+  fI = force_ Insulate+  fP :: forall a. NFDataN a => a -> a+  fP = force_ Propagate+#endif+#else+  fI = force_ Insulate+  fP = force_ Propagate+#endif++  gI :: forall a. Generic a => a -> a+  gI = gforce_ Insulate+  gP :: forall a. Generic a => a -> a+  gP = gforce_ Propagate++-------------------------------------------------------------------------------++  run_tests :: IO Int+  run_tests = do++    putStr "\n"+    -- So can notice the start when scrollback, esp. in ghci reload/reruns.+--  replicateM 50 $ putStrLn "################################################################################"+    putStrLn "\nTesting.\n"++#if ! FOCUS_TEST++#if 1+--  let shp s = s ++ replicate (30 - length s) ' ' ++ show (compilePat s)+    let shp s = +         unsafePerformIO $ +         catch+          ( return $! force $ s ++ replicate (30 - length s) ' ' ++ show (compilePat s) )+          ( \e -> do let err = show (e :: ErrorCall)+                     return err )++    putStrLn "Pattern                       Compiles to"+--  putStrLn $ shp ""  -- empty pattern syntax error+    putStrLn $ shp "*"  -- Node WW []+--  putStrLn $ shp "@"  -- Node WS []  -- obsoleted (use "." w/o children)+    putStrLn $ shp "#"  -- Node I []  -- no parent to absorb (should be error)+    putStrLn $ shp "."  -- Node WS []+--  putStrLn $ shp "**"  -- Node WS []  -- "disconnected pattern (not rooted)"+--  putStrLn $ shp ".*"  -- Node WS []  -- "disconnected pattern (not rooted)"+--  putStrLn $ shp "*."  -- Node WS []  -- "disconnected pattern (not rooted)"+    putStrLn $ shp ".{}"  -- Node WR []+    putStrLn $ shp ".{*}"  -- Node WR [Node WW []]+    putStrLn $ shp ".{**}"  -- Node WR [Node WW [],Node WW []]+    putStrLn $ shp ".{.*}"  -- Node WR [Node WS [],Node WW []]+    putStrLn $ shp ".{#.}"  -- Node WR [Node I [],Node WS []]+    putStrLn $ shp ".{#{#}}"  -- Node WR [Node I []] with warning+    putStrLn $ shp ".{.{#}}"  -- Node WR [Node WR [Node I []]]+    putStrLn $ shp ".{*#*#*#**#*#*}"  -- looks fine+    putStrLn $ shp ".{*#.{*#.{*#}*}*{#*}#*}"  -- warning about *{...}+    putStrLn $ shp ".{*#.{*#.{*#}*}*#*}"+--  putStrLn $ shp ".{*#.{*#.{*#}*}{*}{#*}#*}"  -- }{ syntax error+-- [old comment for that last:] NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil,NodeM WR [NodeM WW [],Nil],NodeM WW [],NodeM WW [],Nil,NodeM WW []],Nil,NodeM WW []] -- was wrong but is fixed I think+    putStrLn $ shp ".{.*.{*23*}}"+#if PARALLELISM_EXPERIMENT+    putStrLn $ shp ".{.=*.{=*23*}}"+#endif+#endif++#endif++#if ! FOCUS_TEST++#if 1+    let test_patterns10 = [+           (4,  "")  -- syntax error+         , (4,  ".##")  -- syntax error (disconnected pattern)+         , (1,  ".{.##}")  -- fail+         , (5,  ".{.{}#{}#{}}")+         , (2,  "*")+         , (2,  ".{***}")+         , (1,  ".{###}")+         , (1,  ".{*##}")+         , (2,  ".{**#}")+         , (2,  ".{##*}")++           -- Remember, [a] is a recursive binary ctor app!...+           -- The next four tests give instance errors for [a], but if+           -- testing expTG_* (GNFDataP/grnfp) then it's no longer a list...+         , (13, ".{..{*#*}#}")+         , (13, ".{..{*###}#}")+         , (13, ".{..{*####}#}")+         , (23, ".{..{*####}.}")++         , (2,  ".{..{*#}*}")+         , (1,  ".{..{*#}#}")+         , (1,  ".{..{*.{#*}}#}")+         , (2,  ".{..{*.{*#}}#}")+         , (13, ".{..{.{..{#*}}}#}")  -- See above comment about [a] instance+         , (2,  ".{#.{..{..{#*}}}#}")++           -- (See Book, p.84.)+         , (1,  ".{..{..{#.{..}}}#}")+         , (1,  ".{..{..{#*}}#}")+         , (1,  ".{*.{*.{#*}}#}")+         , (2,  ".{##*}")+         , (2,  ".{*#*}")+         , (1,  ".:Tuple3{*.{*.{#*}}#}")  -- oops...+         , (1,  ".:(,,){*.{*.{#*}}#}")+         , (2,  ".:(,,){*.{*.{.*}}#}")+         , (1,  ".:Bool{***}")  -- XXX makes no sense (but works) -- oh well;+                                  -- this is an important point to note in+                                  -- docs/blog also...+         , (1,  "*:Bool")+         , (2,  "*:(,,)")+         , (2,  ".{*#.}")+         , (2,  ".{*#.:Bool}")  -- XXX this gives parse error on 2nd .+         , (2,  ".{*#.:Bool{}}")  -- XXX this gives no parse error; if it does what+                                  -- it says, it will only match a childless Bool node+         , (1,  ".{*#.:Int{}}")  -- still need to implement # when not in type+         , (1,  ".{*#.:(,){}}")  -- still need to implement # when not in type+         , (1,  ".{*#.:Int }")  -- still need to implement # when not in type+         , (1,  ".{*#.:Int'}")  -- still need to implement # when not in type+         , (1,  ".{*##:Bool}")+         , (2,  ".{*##:Int}")+         , (2,  ".{*##:(,)}")+         , (1,  ".{*##:Bool{}}")+         , (2,  ".{*##:Int{}}")+         , (2,  ".{*##:(,){}}")+         , (1,  ".{**2#}")+         , (2,  ".{**3#}")+         , (1,  ".{*#:G2{}#}")+         , (1,  ".{*#:Int{}#}")+         ]+    doit14 True test_patterns10+--  doit10 True test_patterns10+#endif++#if USE_SOP++-- Seems fine; it's not a good test as the # in the middle+-- only forces one ctor when type doesn't match, and need+-- to force one more level to hit an undefined.+#if 1+    let test_patterns11 = [+           (4,  "")  -- syntax error+#if 0+         , (4,  ".##")  -- syntax error (disconnected pattern)+         , (1,  ".{.##}")  -- fail+         , (5,  ".{.{}#{}#{}}")+         , (2,  "*")+         , (2,  ".{***}")+         , (1,  ".{###}")+         , (1,  ".{*##}")+         , (2,  ".{**#}")+         , (2,  ".{##*}")++           -- Remember, [a] is a recursive binary ctor app!...+           -- The next four tests give instance errors for [a], but if+           -- testing expTG_* (GNFDataP/grnfp) then it's no longer a list...+         , (13, ".{..{*#}#}")+         , (13, ".{..{*###}#}")+         , (13, ".{..{*####}#}")+         , (23, ".{..{*####}.}")++         , (2,  ".{..{*##}*}")+         , (1,  ".{..{*##}#}")+         , (1,  ".{..{*#*}#}")+         , (2,  ".{..{**#}#}")++           -- (See Book, p.84.)+         , (1,  ".{..{.#.}#}")+         , (1,  ".{..{.#*}#}")+         , (1,  ".{*.{*#*}#}")+         , (2,  ".{##*}")+         , (2,  ".{*#*}")+         , (1,  ".:Tuple3{*.{*#*}#}")  -- oops...+         , (1,  ".:(,,){*.{*#*}#}")+         , (2,  ".:(,,){*.{*.*}#}")+         , (1,  ".:Bool{***}")  -- XXX makes no sense (but works) -- oh well;+                                -- this is an important point to note in+                                -- docs/blog also...+         , (1,  "*:Bool")+         , (2,  "*:(,,)")+         , (2,  ".{*#.}")+         , (2,  ".{*#.:Bool}")  -- XXX this gives parse error on 2nd .+         , (2,  ".{*#.:Bool{}}")  -- XXX this gives no parse error; if it does what+                                  -- it says, it will only match a childless Bool node+         , (1,  ".{*#.:Int{}}")  -- still need to implement # when not in type+         , (1,  ".{*#.:(,){}}")  -- still need to implement # when not in type+         , (1,  ".{*#.:Int }")  -- still need to implement # when not in type+         , (1,  ".{*#.:Int'}")  -- still need to implement # when not in type+         , (1,  ".{*##:Bool}")+         , (2,  ".{*##:Int}")+         , (2,  ".{*##:(,)}")+         , (1,  ".{*##:Bool{}}")+         , (2,  ".{*##:Int{}}")+         , (2,  ".{*##:(,){}}")+         , (1,  ".{**0#}")+         , (1,  ".{**1#}")+         , (2,  ".{**2#}")+         , (2,  ".{**3#}")+#endif+         , (1,  ".{*#:G2{}#}")+         , (1,  ".{*#:Int{}#}")+         ]+    doit15 True test_patterns11+#endif++#endif++#if USE_SOP++-- All fine last checked.+#if 1+    let test_patterns12 = [+#if 0+           (1, ".{.##}")+#else+#if 1+           (4, "..")++         , (2, "*")+         , (1, "*0")+         , (1, "*1")+         , (2, "*2")+         , (2, "*3")++#if 1++         , (1, ".{.#.}")+         , (2, ".{...}")++         , (1, "*:TG")  -- (misuse; TG is a type name, not the name of a ctor)+         , (1, "*:G1")+         , (2, "*:G2")+         , (1, "*:G1{..}")+         , (1, "*:G1{...}")+         , (2, "*:G2{..}")+         , (2, "*:G2{...}")++         -- the getter used makes the rest uninteresting (none touch bottom)+         , (1, "#:G1")+         , (1, "#:G2")+         , (1, "#:G1{..}")+         , (1, "#:G1{...}")+--       , (6, "#:G1{...}")+         , (1, "#:G2{..}")+         , (1, "#:G2{...}")++         , (1, ".:G1{..}")+         , (1, ".:G1{...}")+         , (1, ".:G2{..}")+         , (2, ".:G2{...}")+#endif+#else+           (2, "#:G1{}")+         , (1, "#:G2{}")+         , (2, "#:Int{}")+         , (1, "*:G1")+         , (2, "*:G2")+         , (1, "*:G1{}")+         , (2, "*:G2{}")+         , (1, "*:Int{}")+         , (2, "*:G2{..}")+         , (2, "*:G2{...}")+         , (2, "*{..}")+         , (2, "*{....}")+         , (1, ".{..}")+         , (2, ".{...}")+         , (1, ".{....}")+#endif+#endif+         ]+    doit16 True test_patterns12+#endif++#endif++#if USE_SOP++-- This should work, once the patterns are right for lists,+-- but until I get non-list generic tests working I'm not+-- going to struggle with this.+#if 0+    let test_patterns13 = [+-- expTH_1 = H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False    (for ref.)+-- expTH_4 = H2 1 [H1 2.3, H3, H4 (__, I3 __ (H1 4.5))] __       (in use)+           (4,  "")  -- syntax error+         , (1,  ".{..{..{..{.{#.{#.}}.}}}#}")+         , (2,  ".{..{..{..{.{..{#.}}.}}}#}")+         , (2,  ".{..{..{..{.{#.{..}}.}}}#}")+         , (2,  ".{..{..{..{.{#.{#.}}.}}}.}")+         , (1,  ".{..{.{.}.{..{.{#.{#.{.}}}.}}}#}")+         , (2,  ".{..{.{.}.{..{.{..{#.{.}}}.}}}#}")+         , (2,  ".{..{.{.}.{..{.{#.{..{.}}}.}}}#}")+         , (2,  ".{..{.{.}.{..{.{#.{#.{.}}}.}}}.}")+         , (2,  ".{..{.{.}.{..{.{#.{#..{.}}}.}}}.}")+         ]+    doit17 True test_patterns13+#endif++#if 1+    let test_patterns14 = [+-- expTJ_1 = J2 ( 1, J4 ( J3, K3 K2 ( J1 4.5))) False     -- for ref.+-- expTJ_2 = J2 ( 1, J4 ( J3, K3 __ ( J1 4.5))) False+-- expTJ_3 = J2 ( 1, J4 ( __, K3 K2 ( J1 4.5))) False+-- expTJ_4 = J2 ( 1, J4 ( __, K3 __ ( J1 4.5))) __        -- in use+--           {  { {} {  { {}  {  {} { {  {} }}}}}}}+-- XXX The tuples are ctors, I forgot...+           (4 ,  "")  -- syntax error+#if 0+         , (1 ,  ".")+         , (13,  ".{}")+         , (13,  ".{.}")+         , (2 ,  ".{..}")+         , (13,  ".{...}")+         , (13,  ".{....}")+         , (13,  ".{.....}")+#endif+-- expTJ_1 = J2 ( 1, J4 ( J3, K3 K2 ( J1 4.5))) False     -- for ref.+--                J2 { (,) { I J4 { (,) { J3 K3 { K2 { J1 { 4.5 } } } } } } False }+--                .  {  .  { .  . {  .  { .  .  {  . { .  { .   } } } } } } . }+           -- this pattern also double-checked on paper+         , (2 ,  ".{.{..{.{..{..{.}}}}}.}")+--       , (1 ,  ".{.{..{.{..{#.{.}}}}}#}")  -- blows (in partic. expTJ_2)+         , (1 ,  ".{.{..{.{#.{..{.}}}}}#}")  -- blows (in partic. expTJ_3)+--       , (1 ,  ".{.{..{.{#.{#.{.}}}}}#}")  -- blows (in partic. expTJ_4)+#if 0+         , (1 ,  ".{.{..{#{##{##{#}}}}}#}")  -- = ".{.{..{#}}#}" (no blow)+         , (1 ,  ".{.{..{#{#.{#.{.}}}}}#}")  -- = ".{.{..{#}}#}" (no blow)+         , (1 ,  ".{.{..{#{..{#.{.}}}}}#}")  -- = ".{.{..{#}}#}" (no blow)+         , (1 ,  ".{.{..{.{..{#.{.}}}}}#}")  -- blows+         , (1 ,  ".{.{..{.{##{##{#}}}}}#}")  -- blows+         , (1 ,  ".{.{..{#}}#}")             -- confirming (no blow)+#endif+#if 0+         , (2 ,  ".{.{..{.{..{.{.{.}}}}}}.}")+         , (1 ,  ".{.{..{.{#.{#{.{.}}}}}}#}")+         , (1 ,  "#{#{##{#{##{#{#{#}}}}}}#}")+         , (1 ,  ".{#{##{#{##{#{#{#}}}}}}#}")+         , (1 ,  ".{.{##{#{##{#{#{#}}}}}}#}")+         , (1 ,  ".{.{..{#{##{#{#{#}}}}}}#}")+#endif+#if 0+         , (1,  ".{..{#.{#.{.}}}#}")+         , (2,  ".{..{..{..{.}}}.}")+         , (2,  "*")+         , (2,  ".{.*.}")+         , (2,  ".{***}")+#endif+         ]+    doit18 True test_patterns14+#endif++#if 1+    let test_patterns14b = [+-- expTJ_5 = J2 ( 1, J4 ( __, K2 )) False+           (4 ,  "")  -- syntax error+         , (2 ,  ".{.{..{.{..}}}.}")+         , (1 ,  ".{.{..{.{#.}}}.}")+         , (1 ,  ".{.{..{#{..}}}.}")+         , (1 ,  ".{.{.#{.{..}}}.}")+         ]+    doit18b True test_patterns14b+#endif++#if 1+    let test_patterns14c = [+-- expTJ_6 = J4 ( __, K2 ) False+           (4 ,  "")  -- syntax error+         , (2 ,  ".{.{..}}")+         , (1 ,  ".{.{#.}}")+         , (1 ,  ".{#{..}}")+         , (1 ,  "#{.{..}}")+         ]+    doit18c True test_patterns14c+#endif++#if 1+    let test_patterns14d = [+-- expTJ_7 = ( __, K2 )+           (4 ,  "")  -- syntax error+         , (2 ,  ".{..}")+         , (1 ,  ".{#.}")+         , (1 ,  "#{..}")+         ]+    doit18d True test_patterns14d+#endif++#if 1+    let test_patterns14e = [+-- expTJ_8 = __ :: TJ+           (4 ,  "")  -- syntax error+         , (2 ,  ".")+         , (1 ,  "#")+         ]+    doit18e True test_patterns14e+#endif++#if 1+    let test_patterns14f = [+-- expTJ_8 = (K5 (__::TJ))+           (4 ,  "")  -- syntax error+         , (1 ,  ".")+         , (1 ,  ".{#}")+         , (2 ,  ".{.}")+         , (1 ,  "#")+         ]+    doit18f True test_patterns14f+#endif++-- These work!+#define TRY_THIS 1+#if 1+    let test_patterns14g = [+#if TRY_THIS+-- exp = K3 (__::TK) J3+#else+-- exp = K3 K2 (__::TJ)+#endif+           (4 ,  "")  -- syntax error+         , (1 ,  ".")+#if TRY_THIS+         , (1 ,  ".{#.}")+         , (2 ,  ".{.#}")+#else+         , (2 ,  ".{#.}")+         , (1 ,  ".{.#}")+#endif+         , (2 ,  ".{..}")+         , (1 ,  "#")+         ]+    doit18g True test_patterns14g+#endif++-- Okay last I checked.+#if 1+    let test_patterns15 = [+-- expTL_1 = L1 5.6 (M1 True)+-- expTL_2 = L1 5.6 (M1 __)+-- expTL_3 = L1 5.6 __+-- expTL_4 = L1 __ (M1 True)+           (4 ,  "")  -- syntax error+#if 0+#elif 1+         , (1 ,  "#")+         , (5 ,  "#{..}")+         , (1 ,  ".{..}")+         , (2 ,  ".{.{.}.}")+         , (1 ,  ".{.{#}.}")+#elif 0+         , (1 ,  "#")+         , (5 ,  "#{..}")+         , (2 ,  ".{..}")+         , (1 ,  ".{#.{.}}")+#elif 0+         , (1 ,  "#")+         , (5 ,  "#{..}")+         , (2 ,  ".{..}")+         , (2 ,  ".{..{.}}")+         , (2 ,  ".{..{#}}")+#elif 0+         , (1 ,  "#")+         , (5 ,  "#{..}")+         , (1 ,  ".{..}")+         , (2 ,  ".{..{.}}")+         , (1 ,  ".{..{#}}")+#endif+         ]+    doit19 True test_patterns15+#endif++-- Good test case for the problem. No tuples; every step is generic.+#if 1+    let test_patterns16 = [+-- expTK_1 = K3 K2 ( J1 4.5)     -- for ref.+-- expTK_2 = K3 __ ( J1 4.5)+--           {  {} { {  {} }}}+-- XXX Don't forget tuples are ctors...+           (4 ,  "")  -- syntax error+#if 0+         , (2 ,  ".{..}")+         , (1 ,  ".{#.}")+         , (2 ,  ".{.#}")+         , (1 ,  ".{##}")+#else+         , (2 ,  ".{..{.}}")  -- ok+         , (1 ,  ".{##}")     -- X+         , (1 ,  ".{#.}")     -- X+         , (1 ,  ".{#.{#}}")  -- X+         , (1 ,  ".{#.{.}}")  -- X+         , (2 ,  ".{.#{.}}")  -- X  & this does give the # with subpat. warning.+         , (2 ,  ".{.#{#}}")  -- X  & why no warning about # with subpattern?+         , (1 ,  ".{##{#}}")  -- X  & why no warning about # with subpattern?+         , (1 ,  "#{##{#}}")  -- ok & why no warning about # with subpattern?+#endif+         ]+    doit20 True test_patterns16+#endif++#endif++---------------------------------------------++#endif++-- Later: Oh! Don't be silly -- it's all compile-time, and the+-- size or shape of the list is irrelevant -- which rules+-- will fire depends on THIS FILE'S SOURCE CODE (not it's+-- data, including static values)!+-- XXX Even with empty list, the same rule firings occur!...+-- If comment out this block however, the rules do not fire!+#if 1+    -- Testing composition and union:+    let test_patterns11 = [+           (1, ".", ".")+         , (2, ".", "*")+         , (2, "*", ".")+         , (2, "*", "*")+         , (2, ".{...}", ".{*..}")+         , (2, ".{*..}", ".{..*}")+         , (2, ".{.*#}", ".{.#.}")+         ]+    doit11 True test_patterns11+#endif++#if ! FOCUS_TEST++#if 1+    -- Testing splicePats+    let test_patterns12 = [+           (1, ".", [], [(0,"*")])+         , (1, ".{}", [], [(0,"*")])+         , (1, ".", [0], [(0,"*")])+         , (1, ".{..}", [], [(0,"*")])+         , (1, ".{..}", [0], [(0,"*")])+         , (1, ".{..}", [2], [(0,"*")])+         , (1, ".{..}", [], [(0,"*"),(0,"#")])+         , (1, ".{..}", [], [(0,"*"),(1,"#")])+         , (1, ".{..}", [], [(1,"#"),(0,"*")])+         , (1, ".{..}", [], [(0,"*"),(2,"#")])+         , (1, ".{..}", [], [(2,"*"),(2,"#"),(2,"#")])+         , (1, ".{..}", [], [(-1,"*")])+         , (1, ".{..}", [], [(0,"*")])+         , (1, ".{..}", [], [(1,"*")])+         , (1, ".{..}", [], [(2,"*")])+         , (1, ".{..}", [], [(3,"*")])+         , (1, ".{..{..}.}", [1], [(0,"*")])+         , (1, ".{..{..}.}", [1], [(0,"*3"),(1,"#"),(2,"*")])+         , (1, ".{..{..}.}", [1,0], [(0,"*"),(0,"#")])+         , (1, ".{.{...}.{.{}.}.}", [1], [(0,"*"),(0,"#")])+         , (1, ".{.{...}.{.{}.}.}", [1,0], [(0,"*"),(0,"#")])+         , (1, ".{.{###}.{.{}#}#}", [1,0], [(0,"*"),(0,"#")])+         , (1, ".{.:(,,){###}.{.{}#}#}", [1,0], [(0,"*"),(0,"#")])+         ]+    doit12 True test_patterns12+#endif++#if 1+    -- Testing elidePats+    -- XXX There's a nice way to do this, by rewriting each test+    -- automatically (or via manual regex substitutions) so that+    -- the target is the result of the corresponding splicePats test.+    -- Unfortunately, the expected results are not encoded for+    -- the splicePats test, so oh well, for now at least, just+    -- build some fresh tests!+    let test_patterns12b = [+           (1, ".{.{..}..{.}}", [], [0])+         , (1, ".{.{..}..{.}}", [0], [0])+         , (1, ".{.{..}..{.}}", [1], [0])+         , (1, ".{.{..}..{.}}", [1], [1])+         ]+    doit12b True test_patterns12b+#endif++#endif++#if ! FOCUS_TEST++#if 1+    -- Testing erodePat+    -- XXX Note we toss the stdgen when done here...+    stdgen12c <- newStdGen+--  let stdgen12c = mkStdGen seed+    let test_patterns12c = [+           (1, ".{.{..}..{.}}", [])  -- recursive test...+         ]+--  stdgen12c <- doit12c True test_patterns12c+#if 0+    stdgen12c' <- doit12c True test_patterns12c stdgen12c+    stdgen12c'' <- doit12c True test_patterns12c stdgen12c'+    stdgen12c''' <- doit12c True test_patterns12c stdgen12c''+    return ()+#else+#if 1+    stdgen12c' <- doit12c True test_patterns12c stdgen12c 5+    return ()+#else+    doit12c True test_patterns12c stdgen12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+      >>= doit12c True test_patterns12c+#endif+#endif+#endif++#endif++#if 1+    -- Testing anything else we can with a single function!+    -- (Getting sick of this cloning.)+    -- Functions are listed in (current) export order.+    -- Things still needing testing are >'d.+    -- Things tested but failing some tests have a *.+    -- +    -- XXX Wow does this ever look cleaner with "Pat" instead of "Pattern"!...+    -- Fortunately splicePats is already tested separately; the rest+    -- we need to test deal only in Pat args (or list of same), so+    -- we can pass a couple [Pat] to test13 along with an Int code+    -- to control delegation.+    --  1    unionPats       :: [ Pat ] -> Pat+    --  2    intersectPats   :: [ Pat ] -> Pat+    --  3    subPat          :: Pat -> Pat -> Bool+--  --  4    unionPatssStr   :: [ String ] -> String+    --  5    emptyPat        :: Pat+    --  6    mkPat           :: forall d. Data d => d -> Pat+    --  7    growPat         :: forall d. Data d => Pat -> d -> Pat+    --  8    shrinkPat       :: Pat -> Pat+    --  9    liftPats        :: [ Pat ] -> Pat+    -- 10    splicePats      :: Pat -> [Int] -> [(Int, Pat)] -> Pat+    -- 11    isPath          :: Pat -> Bool+    -- 12    mkPatN          :: Int -> Pat -> Bool+    -- 13    elidePats       :: Pat -> Pat -> [Int] -> Pat+    -- 14    erodePat        :: StdGen -> [Int] -> Pat -> (Pat, StdGen)+    let test_patterns13 = [+           ( 1, [".{...}", ".{.#}"], "")+         , ( 2, [".{...}", ".{.#}"], "")+         , ( 3, [".", "."], "True")+         , ( 3, ["#", "#"], "True")+         , ( 3, ["*", "*"], "True")+         , ( 3, [".", ".{}"], "True")+         , ( 3, [".{}", "."], "False")+         , ( 3, [".{}", ".{.}"], "False")+         , ( 3, [".{.}", ".{.}"], "True")+         , ( 3, [".{.}", ".{..}"], "False")+         , ( 3, [".{.}", ".{.{.}}"], "True")+         , ( 3, [".{..}", ".{.#}"], "False")+         , ( 3, [".{.#}", ".{..}"], "True")+         , ( 3, [".{..}", ".{...}"], "False")+         , ( 3, [".{}", ".{...}"], "False")+         , ( 3, [".", ".{*.#}"], "True")+         , ( 3, ["#", ".{*.#}"], "True")+         , ( 3, ["*", ".{*.#}"], "False")+         , ( 3, ["*", ".{*}"], "False")+         , ( 3, ["*", ".{**}"], "False")+         , ( 4, [".{...}", ".{.#}"], "")+         , ( 5, [".{...}", ".{.#}"], "")+         , ( 6, [".{...}", ".{.#}"], "")+         -- matching against val = ([1,2,3::Int],(False,"foo"))+         -- mkPat val = ".{.{..{..{..}}}.{..{..{..{..}}}}}"+         , ( 7, [".{.{..{..}}.{..{..}}}"], "")+         , ( 7, [".{.{..{..{..}}}.{..{..{..}}}}"], "")+         , ( 7, [".{.{..{..{..}}}.{..{..{..{..}}}}}"], "")+         , ( 8, [".{.{..{..{..}}}.{..{..{..{..}}}}}"], "")+         , ( 8, [".{.{..{..{..}}}.{..{..{..}}}}"], "")+         , ( 8, [".{.{..{..}}.{..{..}}}"], "")+         , ( 8, [".{.{#.{..}}.{#.{*3.}}}"], "")+         , ( 8, [".{.{#.}.{#.}}"], "")+         , ( 8, [".{..}"], "")+         , ( 8, ["."], "")+         , ( 9, [".{...}", ".{.#}"], "")+         , (10, [".{...}", ".{.#}"], "")+         , (11, [".{...}", ".{.#}"], "")+         , (12, [".{...}", ".{.#}"], "")+    -- 12    mkPatN          :: Int -> Pat -> Bool+    -- 13    elidePats        :: Pat -> Pat -> [Int] -> Pat+    -- 14    erodePat        :: StdGen -> [Int] -> Pat -> (Pat, StdGen)+         ]+    putStrLn "==================================================="+    putStrLn "Testing miscellaneous PatUtil functions..."+    doit13 True test_patterns13+#endif++#if ! FOCUS_TEST++#if 1+    -- Testing fusion+    putStrLn "\nTesting fusion\n-fenable-rewrite-rules -O -ddump-rules -ddump-simpl-stats -ddump-rule-firings\n"+    let exp12 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+    let get12 (_,xs,_) = (xs!!2)+    putStrLn $ show $ get12 $ ( forcep ".:Bool{}" . forcep ".:Int{}" ) exp12+    putStrLn $ show $ get12 $ ( forcep ".:Bool{}" . forcep_ (compilePat ".:Int{}") ) exp12+    putStrLn $ show $ get12 $ ( forcep_ (compilePat ".:Bool{}") . forcep ".:Int{}" ) exp12+    putStrLn $ show $ get12 $ ( forcep_ (compilePat ".:Bool{}") . forcep_ (compilePat ".:Int{}") ) exp12+#endif++#if 1+    putStrLn $ intercalate "\n"+     [ ""+     , "expN_1 = [__] :: [Int]"+     , "expN_2 = [0,1,__,3] :: [Int]"+     , "expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)"+     , "expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+     , ""+     , "getN_1 xs = show $ ()"+--   , "getN_1 xs = show $ head xs"+--   , "getN_2 xs = show $ (xs!!1)"+     , "getN_2 xs = show $ (xs!!3)"+     , "getN_3 (_,xs,_) = show $ (xs!!2)"+     ]+    doit5 1 0 1 "" >>= putStrLn+    doit6 1 0 1 "" >>= putStrLn+    doit7 1 0 1 "" >>= putStrLn+    doit8 1 0 1 "" >>= putStrLn+#if 0+    doit9 >>= putStrLn  -- XXX broken (whatever it is)+#endif+#endif++#if 1+    putStr hdline+    putStrLn "Testing generic GNFDataN (refer to Foo.hs for the defs).\n"+    putStr hline+#if 0+#if ! USE_SOP+    putStrLn $ show $ from expTE_1+    putStrLn $ show $ from $ F 23+    putStrLn $ show $ from $ Just 11  -- bad comparison: two constructors!+#endif+--  putStrLn $ show $ from $ Just (undefined::Int)+--  putStrLn $ show $ from expTE_2+--  putStrLn $ show $ from expTE_3+    putStr "\n"+    putStrLn $ ""+           ++ "expBase7 = B2 (A1 True 4) (B1 True (A2 undefined))\n"+           ++ "expBase8 = B2 (A1 undefined 4) (B1 True (A2 undefined))\n"+           ++ "expBase9 = B2 (A1 undefined 4) (B1 undefined (A2 undefined))\n"+           ++ "...\n"+           ++ "getB_1 (B2 _ (B1 b _)) = b\n"+           ++ "getB_2 (B2 (A1 _ n) _) = n\n"+#endif+    s2 <- doit2 1 0 1 ""+    putStrLn s2+#if 0+    putStrLn $ ""+           ++ "expTB_15 = (A3 (B3 False undefined 5) False)\n"+           ++ "getA (A3 _ b) = show b\n"+    s3 <- doit3 1 1 1 ""+    putStrLn s3+#endif+#endif++#if 0+    s4 <- doit4 1 0 1 ""+    putStrLn s4+#endif++#if 0+    putStrLn $ ""+           ++ "expBase1 = ([True,False],3,Just \"fox\")         :: ([Bool],Int,Maybe String)\n"+           ++ "expBase2 = ([True,False],__,Just \"fox\")        :: ([Bool],Int,Maybe String)\n"+           ++ "expBase3 = ([True,__],3,Just \"fox\")            :: ([Bool],Int,Maybe String)\n"+           ++ "expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)\n"+           ++ "expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)\n"+           ++ "expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)\n"+           ++ "get1 ((x:_),_,_) = x           -- True\n"+           ++ "get2 (_,x,_) = x               -- 3\n"+           ++ "get3 (_,_,x) = fromJust x      -- \"fox\"\n"+           ++ "get4 (_,_,Just (x:_)) = x      -- 'f'\n"+    s1 <- doit1 1 1 1 ""+    putStrLn s1+#endif++#if USE_SOP++#if 1+    -- Testing rnfpDyn -- working+    putStrLn "\nTesting SOP rnfpDyn with SYB generic stop condition.\n"+#if 1+    let exp21 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+    let get21 (_,xs,_) = (xs!!2)+    let f21_a :: [Int] -> PatNode+        f21_a _ = WI+    let f21_b :: Bool -> PatNode+        f21_b _ = WI+    let fg21 :: GenericQ PatNode+        fg21 = mkQ WR f21_a `extQ` f21_b+--  let fg21 = mkQ WR f21_a `extQ` f21_b :: forall a. Data a => a -> PatNode+--  let fg21 = mkQ WR f21_a `extQ` f21_b :: GenericQ PatNode+    putStrLn $ show $ get21 $ forcepDyn fg21 exp21+#else+    let exp21 = (3.4, [5,__,7], False) :: (Float, [Int], Bool)+    let get21 (_,xs,_) = (xs!!2)+#if 0+#elif 1+    let f21 :: [Int] -> PatNode+        f21 _ = WI+    let fg21 :: GenericQ PatNode+        fg21 = mkQ WR f21+#elif 0+    let f21 :: (Float,[Int],Bool) -> PatNode+    -- Cannot do in SYB? We can't just "stop on any 3-tuple"; we need+    -- to give the types of the components of the tuple as well?+--  let f21 :: (,,) a b c -> PatNode+--  let f21 :: (,,) * * * -> PatNode+--  let f21 :: (,,) -> PatNode+--  let f21 :: (a,b,c) -> PatNode+--  let f21 :: (Typeable a,Typeable b,Typeable c) => (a,b,c) -> PatNode+--  let f21 :: (Data a,Typeable a,Data b,Typeable b,Data c,Typeable c) => (a,b,c) -> PatNode+        f21 _ = WI+--      f21 (x,y,z) = WI+    let fg21 :: GenericQ PatNode+        fg21 = mkQ WR f21+#elif 0+    let f21 :: Int -> PatNode+        f21 x = WI+--      f21 x = case x of { 5 -> WR ; _ -> WI }  -- "case x" forces x!+--  let (f21::Int->PatNode) x = case x of { 5 -> WR ; _ -> WI }+    let fg21 :: GenericQ PatNode+        fg21 = mkQ WR f21+#endif+    putStrLn $ show $ get21 $ forcepDyn fg21 exp21+#endif+#endif++#if 1+    -- Testing rnfpDyn again -- not working...+    putStrLn "\nTesting SOP/SYB rnfpDyn again.\n"+#if 0+#elif 1+    let exp22 = [[[__]],[[__,6],[7]]] :: [[[Int]]]+-- These three should be exactly equivalent (same core produced)?+--  let get22 xs = (((xs!!1)!!1)!!0)+--  let get22 [_,[[_,n],_]] = n+    let get22 (_:((_:n:_):_):_) = n+    let f22a :: Int -> PatNode+        f22a _ = trace "Noo-A" $ WI+    let f22b :: [Int] -> PatNode+        f22b _ = trace "Noo-B" $ WI+    let f22c :: [[Int]] -> PatNode+        f22c _ = trace "Noo-C" $ WI+    let f22d :: [[[Int]]] -> PatNode  -- goes boom+        f22d _ = trace "Noo-D" $ WI+    let fg22 :: GenericQ PatNode+        fg22 = mkQ WR id+--                                                              -- blows+--                                                 `extQ` f22d  -- blows+                                       `extQ` f22c `extQ` f22d  -- FINE+--                         `extQ` f22b `extQ` f22c `extQ` f22d  -- FINE+--             `extQ` f22a `extQ` f22b `extQ` f22c              -- blows+--             `extQ` f22a `extQ` f22b `extQ` f22c `extQ` f22d  -- FINE+#elif 0+    let exp22 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]+    let get22 xs = (((xs!!1)!!2)!!0)+    let f22 :: Int -> PatNode        -- goes boom+--  let f22 :: [Int] -> PatNode      -- goes boom+--  let f22 :: [[Int]] -> PatNode    -- goes boom+--  let f22 :: [[[Int]]] -> PatNode  -- goes boom+        f22 _ = trace "Noo-A" $ WI+    let fg22 :: GenericQ PatNode+        fg22 = mkQ WR f22+#else+    let exp22 = (3.4, [[[__]],[[__,6],__,[7]]], __) :: (Float, [[[Int]]], Bool)+--  let exp22 = (3.4, [[__],[[__,6],__,[7]]], __) :: (Float, [[[Int]]], Bool)+    let get22 (_,xs,_) = (((xs!!1)!!2)!!0)+    let f22_a :: [[Int]] -> PatNode+        f22_a _ = WI+    let f22_b :: Bool -> PatNode+        f22_b _ = WI+    let fg22 :: GenericQ PatNode+        fg22 = mkQ WR f22_a `extQ` f22_b+--  let fg22 = mkQ WR f22_a `extQ` f22_b :: forall a. Data a => a -> PatNode+--  let fg22 = mkQ WR f22_a `extQ` f22_b :: GenericQ PatNode+#endif+    putStrLn $ show $ get22 $ forcepDyn fg22 exp22+#endif++#if 1+#if __GLASGOW_HASKELL__ >= 708+-- XXX This isn't working yet.+-- And it won't work naively either, b/c SOP is *shallow*...+-- Note:+-- *Foo> :m +Generics.SOP+-- *Foo Generics.SOP> datatypeInfo (Proxy :: Proxy [[Int]])+-- ADT "GHC.Types" "[]" (Constructor "[]" :* (Infix ":" RightAssociative 5 :* Nil))+-- So, as done in GNFDataP, we need to pattern-match in tandem on this,+-- through the *S and *P SOP recursion auxilliaries...+-- XXX I came back to this -- getting type errors, could probably+-- get rid of by adding extra functions (as per GNFDataP.hs code),+-- but remember, this is supposed to be API-user code ... if it's+-- going to be that painful to write, we have a problem...+-- (Still, can probably write friendlier wrapper functions.)+    -- Testing rnfpDyn' with SOP generic stop condition+    putStrLn "\nTesting SOP rnfpDyn' with SOP generic stop condition.\n"+#if 0+#elif 1+    putStrLn $ doit23+#elif 0+    let exp23 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]+    let get23 xs = (((xs!!1)!!2)!!0)+    let fg23 :: forall a. (Generic a, HasDatatypeInfo a) => a -> PatNode+        fg23 d | cname == "[[Int]]"  = WI+               | otherwise           = WR+          where+#if 1+           ADT mname tname (Constructor cname :* _) = dti+--         ADT mname tname (Constructor cname :* _) = dti :: DatatypeInfo (Code a)+--         (mname,tname,cname) = case dti of ...+--         ADT mname tname (Constructor cname :* (Infix ":" RightAssociative 5 :* Nil)) = dti+#endif+           dti = datatypeInfo proxy_a+           proxy_a = Proxy :: Proxy a+           xrep = from d+    putStrLn $ show $ get23 $ forcepDyn' fg23 exp23+#endif+#endif+#endif++#if 1+-- Gave up on the fully-SOP one, at least for now, b/c+-- it seems like it's hard to write (much uglier than SYB one),+-- and then writing a friendly wrapper looks tough as well.+-- But here is a 3rd alternative, hybrid SOP/Typeable which+-- is even simpler from the user perspective, only less efficient.+    putStrLn "Testing SOP rnfpDyn'' with Typeable generic stop condition\n"+    let exp24 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]+    let get24 xs = (((xs!!1)!!2)!!0)+    let fg24 :: forall a. Typeable a => a -> PatNode+        fg24 d | t == "[[[Int]]]"  = WI+               | t == "[[Int]]"    = WI+               | otherwise         = WR+         where t = show $ typeOf d+    -- This is a simple alternative to the SOP/SYB hybrid.+    -- If efficiency isn't prime concern, this would appear to be+    -- even simpler ... the above looks much more lucid to me than+    -- the usual SYB way of mkQ/extQ; here, just define one normal+    -- function, and away you go...+    putStrLn $ show $ get24 $ forcepDyn'' fg24 exp24+#endif++#endif++#endif++#if ! FOCUS_TEST++#if 1+    putStrLn "\nTesting Seqable class (tuple with list):\n"+    let test_patterns24 = [+           (1,  1, (3.4, [5, __, 7], False))                        -- okay+         , (2,  2, fP (3.4, fP (5 : fP (__ : fP (7 : []))), __))    -- okay+         , (2,  3, fP (3.4, fP (5 : fI (__ : fP (7 : []))), __))    -- okay+         , (1,  4, fI (3.4, fP (5 : fI (__ : fP (7 : []))), __))    -- XXX+         , (1,  5, fI (3.4, fI (5 : fI (__ : fP (7 : []))), __))    -- okay+         , (2,  6, fI (3.4, fI (5 : fP (__ : fP (7 : []))), __))    -- okay+         , (1,  7, fI (3.4, fP (5 : fI (__ : fP (7 : []))), True))  -- XXX+         , (1,  8, fP (3.4, fI (5 : fI (__ : fP (7 : []))), True))  -- XXX+         , (1,  9, fP (3.4, fI (5 : fI (__ : fI (7 : []))), True))  -- XXX+         ] :: [(Int,Int,(Float,[Int],Bool))]+    doit24 True test_patterns24+#endif++#if 1+    putStrLn "\nTesting Seqable class (nested tuples):\n"+    let test_patterns25 = [+           (1,  1, (3.4, (__, 7), False))       -- okay+         , (1,  2, fI (3.4 ,fI (__, 7) ,__))    -- okay+         , (2,  3, fP (3.4 ,fP (__, 7) ,__))    -- XXX+         , (2,  4, fP (3.4 ,fI (__, 7) ,__))    -- XXX+         , (2,  5, fI (3.4 ,fP (__, 7) ,__))    -- XXX+         , (1,  6, fI (3.4 ,fI (__, 7) ,True))  -- okay+         , (2,  7, fP (3.4 ,fP (__, 7) ,True))  -- XXX+         , (1,  8, fP (3.4 ,fI (__, 7) ,True))  -- okay+         , (2,  9, fI (3.4 ,fP (__, 7) ,True))  -- XXX+         ] :: [(Int,Int,(Float,(Bool,Int),Bool))]+    doit25 True test_patterns25+#endif++#if USE_SOP++#if 1+    putStrLn "\nTesting generic Seqable (tuple with list):\n"+    let test_patterns26 = [+           (1,  1, (3.4, [5, __, 7], False))                        -- okay+         , (2,  2, gP (3.4, gP (5 : gP (__ : gP (7 : []))), __))    -- okay+         , (2,  3, gP (3.4, gP (5 : gI (__ : gP (7 : []))), __))    -- okay+         , (1,  4, gI (3.4, gP (5 : gI (__ : gP (7 : []))), __))    -- XXX+         , (1,  5, gI (3.4, gI (5 : gI (__ : gP (7 : []))), __))    -- okay+         , (2,  6, gI (3.4, gI (5 : gP (__ : gP (7 : []))), __))    -- okay+         , (1,  7, gI (3.4, gP (5 : gI (__ : gP (7 : []))), True))  -- XXX+         , (1,  8, gP (3.4, gI (5 : gI (__ : gP (7 : []))), True))  -- XXX+         , (1,  9, gP (3.4, gI (5 : gI (__ : gI (7 : []))), True))  -- XXX+         ] :: [(Int,Int,(Float,[Int],Bool))]+    doit26 True test_patterns26+#endif++#if 1+    putStrLn "\nTesting generic Seqable (expTJ_*):\n"+-- expTJ_1 = J2 ( 1, J4 ( J3, K3 K2 ( J1 4.5))) False     -- for ref.+-- expTJ_2 = J2 ( 1, J4 ( J3, K3 __ ( J1 4.5))) False+-- expTJ_3 = J2 ( 1, J4 ( __, K3 K2 ( J1 4.5))) False+-- expTJ_4 = J2 ( 1, J4 ( __, K3 __ ( J1 4.5))) __        -- in use+    let test_patterns27 = [+           (1,  1, gI (J2 (gI ( 1, gI (J4 (gI ( __, gI (K3 __ ( gI (J1 4.5)))))))) __))+         , (2,  2, gP (J2 (gP ( 1, gP (J4 (gP ( __, gP (K3 __ ( gP (J1 4.5)))))))) __))+         , (1,  3, gI (J2 (gP ( 1, gP (J4 (gI ( __, gI (K3 __ ( gP (J1 4.5)))))))) __))+         , (2,  4, gP (J2 (gP ( 1, gP (J4 (gI ( __, gI (K3 __ ( gP (J1 4.5)))))))) __))+         , (2,  5, gI (J2 (gP ( 1, gP (J4 (gP ( __, gI (K3 __ ( gP (J1 4.5)))))))) __))+         , (2,  6, gI (J2 (gP ( 1, gP (J4 (gI ( __, gP (K3 __ ( gP (J1 4.5)))))))) __))+         ] :: [(Int,Int,TJ)]+    doit27 True test_patterns27+    putStrLn "\n"+#endif++#endif++#endif++    return 0++-------------------------------------------------------------------------------++  hline :: String+  hline = "---------------------------------------------------\n"+  hdline :: String+  hdline = "===================================================\n"++-------------------------------------------------------------------------------++  doit1 :: Int -> Int -> Int -> String -> IO String+  doit1 i j k acc+   -- this glitch (the exception that seemingly escapes my catch)+   -- happens just for these combos (and for all j):+-- | i == 3 && k == 4  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+-- | i == 3 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+-- | i == 3 && j < 4 && k == 5  = doit1 (1+i) j k acc  -- trying to avoid a glitch...+   | k == 7  = return acc+   | j == 6  = doit1 1 1 (1+k) acc+   | i == 5  = doit1 1 (1+j) k acc+   | otherwise  = do+      fexp <- catch+               -- The semantics of the !'s here are not what they were,+               -- since forcing in some places. [?] But at least the+               -- first one seems definitely still needed...+               -- LATER: The second one is also needed, finally seen!+               -- (It is needed for a version of getE _ = "getee", only.)+               -- XXX I'm just not sure whether the second ! is better+               -- to leave in or leave out...+               ( return $! get $! forcen dep exp )+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+--    doit1 (1+i) j k $! force $ acc+      doit1 (1+i) j k $! acc+--    doit1 (1+i) j k $ acc+        ++ "( get" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k of+            1 -> expBase1+            2 -> expBase2+            3 -> expBase3+            4 -> expBase4+            5 -> expBase5+            6 -> expBase6+    get = case i of+           1 -> get1+           2 -> get2+--         3 -> unsafePerformIO . get3  -- yeesh!...+--         3 -> get3+           3 -> get3 (i,j,k)+           4 -> get4+    dep = j++  -- XXX All this fuss to deal with the case that the+  -- entire argument m is undefined (or whatever is going+  -- for "undefined" at the moment...) -- but, none of+  -- the expBase[1-5] have this! ch.+  myFromJust :: Maybe a -> IO (Either () a)+  myFromJust m = do+                    putStrLn "Boo!"+                    catch+                      (myFromJust' m)+                      (\e -> do putStrLn $! show (e::BottomedOut)+                                putStrLn "HERE!"+                                return $! Left ())+  myFromJust' :: Maybe a -> IO (Either () a)+  myFromJust' Nothing = do+--                         throw BottomedOut+                           return $! Left ()+  myFromJust' (Just x) = return $! Right x+--myFromJust _ = throw BottomedOut++--------------------------------++  doit2 :: Int -> Int -> Int -> String -> IO String+  doit2 i j k acc+-- | k == 2  = {- trace (show (i,j,k)) $ -} return acc+-- | k == 7  = return acc+   | k == 27  = return acc+-- | k == 21  = return acc+-- | k == 5  = return acc+-- | j == 15  = doit2 1 0 (1+k) acc+   | j == 11  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+-- | j == 8  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+-- | j == 3  = {- trace (show (i,j,k)) $ -} doit2 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc+-- | i == 3  = trace ("End of " ++ show (i,j',k')) $ doit2 1 (1+j) k acc+#else+   | i == 2  = doit2 1 (1+j) k acc+-- | i == 3  = doit2 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+--             ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit2 (1+i) j k $! acc+        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expTB_" ++ show (k'-6) ++ " )  "+--      ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ (if dep < 10 then " " else "") ++ " expBase" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            7 -> expBase7+            8 -> expBase8+            9 -> expBase9+            10 -> expBase10+            11 -> expBase11+            12 -> expBase12+            13 -> expBase13+            14 -> expBase14+            15 -> expBase15+            16 -> expBase16+            17 -> expBase17+            18 -> expBase18+            19 -> expBase19+            20 -> expBase20+            21 -> expBase20  -- fudge it!!+            22 -> expBase22+            23 -> expBase23+            24 -> expBase24+            25 -> expBase25+            26 -> expBase26+            27 -> expBase27+            28 -> expBase28+            29 -> expBase29+            30 -> expBase30+            31 -> expBase31+            32 -> expBase32+    get = case i of+           1 -> if k' >= 27 then getB_3 else getB_1+           2 -> getB_2+    dep = j'+    j' = j+--  j' = j+11+--  k' = k+26+    k' = k+6++  doit3 :: Int -> Int -> Int -> String -> IO String+  doit3 i j k acc+   | k == 2  = return acc+   | j == 8  = {- trace (show (i,j,k)) $ -} doit3 1 1 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit3 1 (1+j) k acc+#else+   | i == 2  = doit3 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit3 (1+i) j k $! acc+        ++ "( getB_" ++ show i ++ " $ forcen " ++ show dep ++ " expBase" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            21 -> expBase21+    get = case i of+           1 -> getA+    dep = j'+    i' = i+    j' = j+    k' = k+20++  doit4 :: Int -> Int -> Int -> String -> IO String+  doit4 i j k acc+-- | k == 2  = return acc+   | k == 4  = return acc+   | j == 8  = {- trace (show (i,j,k)) $ -} doit4 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit4 1 (1+j) k acc+#else+   | i == 2  = doit4 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit4 (1+i) j k $! acc+        ++ "( getE $ forcen " ++ show dep ++ " expTE_" ++ show k' ++ " )  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            1 -> expTE_1+            2 -> expTE_2+            3 -> expTE_3+    get = case i of+           1 -> getE+    dep = j'+    i' = i+    j' = j+    k' = k++-------------------------------------------------------------------------------++  doit5 :: Int -> Int -> Int -> String -> IO String+  doit5 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit5 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i,j',k')) $ doit5 1 (1+j) k acc+#else+   | i == 2  = doit5 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit5 (1+i) j k $! acc+        ++ "forcen " ++ show dep ++ " expN_" ++ show k' ++ " `seq` ()  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            1 -> expN_1+    get = case i of+           1 -> getN_1+    dep = j'+    i' = i+    j' = j+    k' = k++-------------------------------------------------------------------------------++  doit6 :: Int -> Int -> Int -> String -> IO String+  doit6 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit6 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit6 1 (1+j) k acc+#else+   | i == 2  = doit6 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit6 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_2+    get = case i of+           _ -> getN_2+    dep = j'+    i' = i+1+    j' = j+    k' = k+1++-------------------------------------------------------------------------------++  doit7 :: Int -> Int -> Int -> String -> IO String+  doit7 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit7 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit7 1 (1+j) k acc+#else+   | i == 2  = doit7 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit7 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_3+    get = case i of+           _ -> getN_3+    dep = j'+    i' = i+2+    j' = j+    k' = k+2++-------------------------------------------------------------------------------++  doit8 :: Int -> Int -> Int -> String -> IO String+  doit8 i j k acc+   | k == 2  = return acc+   | j == 5  = {- trace (show (i,j,k)) $ -} doit8 1 0 (1+k) acc+#if USE_TRACE+   | i == 2  = trace ("End of " ++ show (i',j',k')) $ doit8 1 (1+j) k acc+#else+   | i == 2  = doit8 1 (1+j) k acc+#endif+   | otherwise  = do+      fexp <- catch+               ( return $! get $! forcen dep exp )+               -- ErrorCall if use __ = undefined+               -- BottomedOut if use __ = throw BottomedOut+               (\e -> do let err = show (e :: ErrorCall)+--             (\e -> do let err = show (e :: BottomedOut)+                         return err)+      doit8 (1+i) j k $! acc+        ++ "getN_" ++ show i' ++" $ forcen " ++ show dep ++ " expN_" ++ show k' ++ "  =  "+        ++ fexp ++ "\n"+   where+    exp = case k' of+            _ -> expN_4+    get = case i of+           _ -> getN_3+    dep = j'+    i' = i+2+    j' = j+    k' = k+3++-------------------------------------------------------------------------------++#if 0++#if 0+  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+  patP_1 = Node (TR [typeOf ((__,__,__)::(Float, [Int], Bool))])+             [ Node (TR [typeOf (__::Bool)]) []+--           [ Node (TR [typeOf (__::Float)]) []+--           [ Node (NTR [typeOf (__::Bool)]) []+--           [ Node (NTR [typeOf (__::Float)]) []+--           , Node WS []+             , Node (TW [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) [ Node WS [], Node WS [] ]  -- why not?+             , Node WW []+--           , Node I []+             ]+  getP_1 (_,xs,_) = show $ (xs!!2)+#endif++  doit9 :: IO String+  doit9 = do+#if 0+    putStrLn $ intercalate "\n"+     [ ""+     , "expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+     , "patP_1 = Node (T [typeOf ((__,__,__)::(Float, [Int], Bool))])"+     , "           [ Node W []"+     , "           , Node (T [typeOf ([__]::[Int])]) []"+     , "           , Node I []"+     , "           ]"+     , "getP_1 (_,xs,_) = show $ (xs!!2)"+     ]+    putStrLn "getP_1 $ forcep patP_1 expP_1"+#endif+    s <- catch+             ( return $! getP_1 $! forcep patP_1 expP_1 )+--           ( return $! getP_2 $! forcep patP_2 expP_2 )+--           ( return $! getP_3 $! forcep patP_3 expP_3 )+             -- ErrorCall if use __ = undefined+             -- BottomedOut if use __ = throw BottomedOut+             (\e -> do let err = show (e :: ErrorCall)+--           (\e -> do let err = show (e :: BottomedOut)+                       return err)+    return s++#endif++-------------------------------------------------------------------------------++  doit10 :: Bool -> [(Int,String)] -> IO ()+  doit10 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit10 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit10: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit10 False t++-------------------------------------------------------------------------------++  doit11 :: Bool -> [(Int,String,String)] -> IO ()+  doit11 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit11 b ((code,patstr1,patstr2):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit11: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let patstrU = showPat $ unionPats [compilePat patstr1, compilePat patstr2]+                let pat1 = compilePat patstr1+                let pat2 = compilePat patstr2+                let patU = unionPats [pat1,pat2]+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ ( forcep patstr2 . forcep patstr1 ) exp"+--                putStrLn "? = get $ ( forcep ( unionPatsStr [ patstr1, patstr2 ] ) ) exp"+                  putStrLn "? = get $! ( forcep_ ( unionPats [ pat1, pat2 ] ) ) exp"+                  putStrLn "(Results were more interesting with a previous semantics...)."+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr1                     = " ++ patstr1+                putStrLn $ "patstr2                     = " ++ patstr2+                putStrLn $ "patstrU                     = " ++ patstrU+                if code > 4+                then putStrLn $  "expected value              = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat patstr1  = " ++ showPat pat1+                putStrLn $ "showPat.compilePat patstr2  = " ++ showPat pat2+                putStrLn $ "showPat.compilePat patstrU  = " ++ showPat patU+                if code <= 4+                then putStrLn $  "expected value              = " ++ expect+                else return ()+                putStr "actual value                = "+                let s1 = get $! ( forcep patstr2 . forcep patstr1 ) exp+                putStrLn s1+                putStr "actual value                = "+                let s2 = get $! forcep patstrU exp+#if 1+                let s3 = s2+#else+                putStrLn s2+                let s3 = get $! forcep_ ( unionPats [ pat1, pat2 ] ) exp+#endif+                return $! s3+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit11 False t++-------------------------------------------------------------------------------++  doit12 :: Bool -> [(Int,String,[Int],[(Int,String)])] -> IO ()+--doit12 :: Bool -> [(Int,String,String,[(Int,String)])] -> IO ()+  doit12 _ [] = do+                   return ()+  doit12 b ((code,patstr1,path,isibs'):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit12: unexpected code " ++ show code+    s <- catch+           ( do+                let target = compilePat patstr1+--              let path = compilePat patstr2+                let isibs = map (\ (x,y) -> (x,compilePat y)) isibs'+                if b+                then do+                  putStr hdline+                  putStrLn "Testing splicePats."+                  putStr hline+                else return ()+                putStrLn $ "target       " ++ patstr1+                putStrLn $ "path         " ++ show path+--              putStrLn $ "path         " ++ patstr2+                putStrLn $ "isibs        " ++ show isibs'+                let s1 = force $ showPat $ splicePats target path isibs+--              let s1 = showPat $! splicePats target path isibs+--              let s1 = showPat $ splicePats target path isibs+                putStr "result       "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    if null t then return () else putStr hline+    doit12 False t++-------------------------------------------------------------------------------++  doit12b :: Bool -> [(Int,String,[Int],[Int])] -> IO ()+  doit12b _ [] = do+                   return ()+  doit12b b ((code,patstr1,path,isibs'):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit12b: unexpected code " ++ show code+    s <- catch+           ( do+                let target = compilePat patstr1+                let isibs = isibs'+                if b+                then do+                  putStr hdline+                  putStrLn "Testing elidePats."+                  putStr hline+                else return ()+                putStrLn $ "target       " ++ patstr1+                putStrLn $ "path         " ++ show path+                putStrLn $ "isibs        " ++ show isibs'+                let s1 = force $ showPat $ elidePats target path isibs+                putStr "result       "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    if null t then return () else putStr hline+    doit12b False t++-------------------------------------------------------------------------------++  -- This is the first recursive test [much later than "12" would suggest].+  doit12c :: Bool -> [(Int,String,[Int])] -> StdGen -> Int -> IO StdGen+--doit12c :: Bool -> [(Int,String,[Int],Int)] -> StdGen -> IO StdGen+--doit12c :: Bool -> [(Int,String,StdGen,[Int],Int)] -> IO StdGen+--doit12c :: Bool -> [(Int,String,StdGen,[Int],Int)] -> IO ()+  doit12c _ [] g _ = do+                   return g+--                 return ()+  doit12c b lst@((code,patstr1,path):t) g 0 = return g+  doit12c b lst@((code,patstr1,path):t) g nreps = do  -- but singleton expected?+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  _ -> error $ "doit12c: unexpected code " ++ show code+    (s, g') <- catch+--  s <- catch+           ( do+                let target = compilePat patstr1+                if b+                then do+                  putStr hdline+                  putStrLn "Testing erodePat."+                  putStr hline+                else return ()+                putStrLn $ "target       " ++ patstr1+                putStrLn $ "stdgen       " ++ show g+                putStrLn $ "path         " ++ show path+                let (rslt, g') = erodePat g path target+                let s1 = force $ showPat $ rslt+--              let s1 = force $ showPat $ erodePat g path target+                putStr "result       "+                return $! (s1, g')+--              return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return (err, g))+--                   return err)+    putStrLn s+    putStr hline+    doit12c False lst g' (-1+nreps)+--  doit12c False t g' (-1+nreps)++-------------------------------------------------------------------------------++  doit13 :: Bool -> [(Int,[String],String)] -> IO ()+  doit13 _ [] = do+                   putStr hline+                   return ()+  doit13 b ((code,patstrlst,expectstr):t) = do+    s <- catch+           ( do+                s1 <- case code of+-- Where were they done already?+-- Oh, in doit11 and doit12 above...+                       1 -> error $ hline ++ "unionPats test already done test13-1!"+--                     4 -> error $ hline ++ "unionPatsStr test already done test13-4!"+                       10 -> error $ hline ++ "splicePats test already done test13-10!"+                       11 -> error $ hline ++ "isPath test already done test13-11!"+    --  1    unionPats       :: [ Pat ] -> Pat+    --  2  * intersectPats   :: [ Pat ] -> Pat+    --  3  * subPat          :: Pat -> Pat -> Bool+--  --  4    unionPatsStr    :: [ String ] -> String+    --  5  * emptyPat        :: Pat+    --  6  * mkPat           :: forall d. Data d => d -> Pat+    --  7  * growPat         :: forall d. Data d => Pat -> d -> Pat+    --  8  * shrinkPat       :: Pat -> Pat+    --  9  * liftPats        :: [ Pat ] -> Pat+    -- 10    splicePats      :: Pat -> Pat -> [(Int, Pat)] -> Pat+    -- 11    isPath          :: Pat -> Bool+                       2 -> do+                               let patA = patstrlst!!0+                               let patB = patstrlst!!1+                               putStr hline+                               putStrLn "Testing      intersectPats [patA, patB]"+                               putStrLn $ "patA         " ++ patA+                               putStrLn $ "patB         " ++ patB+                               putStr $ "result       "+                               let s1 = force $ showPat $ intersectPats [compilePat patA, compilePat patB]+                               return s1+                       3 -> do+                               let patA = patstrlst!!0+                               let patB = patstrlst!!1+                               putStr hline+                               putStrLn "Testing      subPat patA patB"+                               putStrLn $ "patA         " ++ patA+                               putStrLn $ "patB         " ++ patB+                               let s1 = force $ show $ subPat (compilePat patA) (compilePat patB)+                               if s1 /= expectstr+                               then do putStrLn $ "expect       " ++ expectstr+                                       putStr $ "result       "+                               else putStr $ "as expected  "+                               return s1+                       5 -> do+                               putStr hline+                               putStrLn "Testing      emptyPat"+                               putStr $ "result       "+                               let s1 = force $ showPat $ emptyPat+                               return s1+                       6 -> do+                               putStr hline+                               putStrLn "Testing      mkPat ([1,2,3],(False,\"foo\"))"+                               putStr $ "result       "+                               let s1 = force $ showPat $ mkPat ([1,2,3::Int],(False,"foo"))+                               return s1+                       7 -> do+                               let patA = patstrlst!!0+                               putStr hline+                               putStrLn "Testing      growPat patA ([1,2,3],(False,\"foo\"))"+                               putStrLn $ "patA         " ++ patA+                               putStr $ "result       "+                               let s1 = force $ showPat $ growPat (compilePat patA) ([1,2,3::Int],(False,"foo"))+                               return s1+                       8 -> do+                               let patA = patstrlst!!0+                               putStr hline+                               putStrLn "Testing      shrinkPat patA"+                               putStrLn $ "patA         " ++ patA+                               putStr $ "result       "+                               let s1 = force $ showPat $ shrinkPat (compilePat patA)+                               return s1+                       9 -> do+                               putStr hline+                               putStrLn "Testing      liftPats patstrlst"+                               putStrLn $ "patstrs      " ++ show patstrlst+                               putStr $ "result       "+                               let s1 = force $ showPat $ liftPats $ map compilePat patstrlst+                               return s1+    -- 12    mkPatN          :: Int -> Pat -> Bool+    -- 13    elidePats        :: Pat -> Pat -> [Int] -> Pat+    -- 14    erodePat        :: StdGen -> [Int] -> Pat -> (Pat, StdGen)+                       12 -> do+                               putStr hline+                               putStrLn "Testing      mkPatN 2 ([1,2,3],(False,\"foo\"))"+                               putStr $ "result       "+                               let s1 = force $ showPat $ mkPatN 2 ([1,2,3::Int],(False,"foo"))+                               return s1+                       _ -> error $ "doit13: unexpected code " ++ show code+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit13 False t++-------------------------------------------------------------------------------++  doit14 :: Bool -> [(Int,String)] -> IO ()+  doit14 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit14 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit14: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit14 False t++-------------------------------------------------------------------------------++#if USE_SOP++  -- This is an adaptation of doit10 to user-defined datatypes,+  -- for testing GNFDataP, which is finally within reach thanks+  -- to SOP!+  doit15 :: Bool -> [(Int,String)] -> IO ()+  doit15 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit15 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit15: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTG_5  -- ( G1, G2 5 __ 7, __ )+--              let exp = expTG_4  -- ( G1, G2 5 6 7, __ )+--              let exp = expTG_3  -- ( G1, G2 __ __ 7, __ )+--              let exp = expTG_2  -- ( __, G2 __ __ 7, __ )+--              let exp = expTG_1  -- ( G1, G2 5 6 7, True )+--              let exp = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+                let pat = compilePat patstr+                let get = getG+--              let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (G1, G2 5 __ 7, __) :: (TG, TG, Bool)"+                  putStrLn "get (_,(G2 _ _ n),_) = n"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit15 False t++-------------------------------------------------------------------------------++  doit16 :: Bool -> [(Int,String)] -> IO ()+  doit16 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit16 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit16: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTG_6  -- G2 5 __ 7+                let pat = compilePat patstr+                let get = getG'+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = G2 5 __ 7 :: TG"+                  putStrLn "get (G2 _ _ n) = n"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit16 False t++-------------------------------------------------------------------------------++  doit17 :: Bool -> [(Int,String)] -> IO ()+  doit17 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit17 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "4.5"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "4.5 (but \"# with subpattern\" warning)"+                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "4.5 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit17: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTH_1  -- H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False+--              let exp = expTH_2  -- H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] False+--              let exp = expTH_3  -- H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] __+                let exp = expTH_4  -- H2 1 [H1 2.3, H3, H4 (__, I3 __ (H1 4.5))] __+                let pat = compilePat patstr+                let get = getH+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] __ :: TH"+--                putStrLn "exp = H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False :: TH"+                  putStrLn "get = (H2 _ [_, _, H4 (_, I3 _ (H1 f))] _) = show f"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit17 False t++-------------------------------------------------------------------------------++  doit18 :: Bool -> [(Int,String)] -> IO ()+  doit18 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "4.5"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "4.5 (but \"# with subpattern\" warning)"+                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "4.5 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit18: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTJ_1  -- J2 (1, J4 (J3, K3 K2 (J1 4.5))) False+--              let exp = expTJ_2  -- J2 (1, J4 (J3, K3 __ (J1 4.5))) False+                let exp = expTJ_3  -- J2 (1, J4 (__, K3 K2 (J1 4.5))) False+--              let exp = expTJ_4  -- J2 (1, J4 (__, K3 __ (J1 4.5))) __+                let pat = compilePat patstr+                let get = getJ+                if b+                then do+                  putStrLn "==================================================="+--                putStrLn "exp = J2 (1, J4 (J3, K3 K2 (J1 4.5))) False"+                  putStrLn "exp = J2 (1, J4 (J3, K3 __ (J1 4.5))) False"+--                putStrLn "exp = J2 (1, J4 (__, K3 K2 (J1 4.5))) False"+--                putStrLn "exp = J2 (1, J4 (__, K3 __ (J1 4.5))) __"+                  putStrLn "get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18 False t++-------------------------------------------------------------------------------++  doit18b :: Bool -> [(Int,String)] -> IO ()+  doit18b _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18b b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "1"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "1 (but \"# with subpattern\" warning)"+                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "1 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit18b: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTJ_5  -- J2 (1, J4 (__, K2)) False+                let pat = compilePat patstr+                let get = getJ'+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = J2 (1, J4 (__, K2)) False"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+--                putStrLn "get (J2 (n, J4 (_, K2)) False) = show n"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18b False t++-------------------------------------------------------------------------------++  doit18c :: Bool -> [(Int,String)] -> IO ()+  doit18c _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18c b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "1"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "1 (but \"# with subpattern\" warning)"+                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "1 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit18c: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTJ_6  -- J4 (__, K2)+                let pat = compilePat patstr+                let get = getJ6+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = J4 (__, K2)"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+--                putStrLn "get (J4 (_, K2)) = show n"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18c False t++-------------------------------------------------------------------------------++  doit18d :: Bool -> [(Int,String)] -> IO ()+  doit18d _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18d b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "1"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "1 (but \"# with subpattern\" warning)"+                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "1 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit18d: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTJ_7  -- (__, K2)+                let pat = compilePat patstr+                let get = getJ7+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (__, K2)"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18d False t++-------------------------------------------------------------------------------++  doit18e :: Bool -> [(Int,String)] -> IO ()+  doit18e _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18e b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "1"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "1 (but \"# with subpattern\" warning)"+                  6 -> "1 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "1 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit18e: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = expTJ_8  -- __ :: TJ+                let pat = compilePat patstr+                let get = getJ8+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = __ :: TJ"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18e False t++-------------------------------------------------------------------------------++  doit18f :: Bool -> [(Int,String)] -> IO ()+  doit18f _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18f b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "okay"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "okay (but \"# with subpattern\" warning)"+                  6 -> "okay (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "okay (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit18f: unexpected code " ++ show code+    s <- catch+           ( do+                let exp = (K5 (__::TJ))+                let pat = compilePat patstr+                let get _ = "okay"+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = (K5 (__::TJ))"+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18f False t+++-------------------------------------------------------------------------------++  doit18g :: Bool -> [(Int,String)] -> IO ()+  doit18g _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit18g b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "okay"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "okay (but \"# with subpattern\" warning)"+                  6 -> "okay (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "okay (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit18g: unexpected code " ++ show code+    s <- catch+           ( do+#if TRY_THIS+                let exp = K3 (__::TK) J3+#else+                let exp = K3 K2 (__::TJ)+#endif+                let pat = compilePat patstr+                let get _ = "okay"+                if b+                then do+                  putStrLn "==================================================="+#if TRY_THIS+                  putStrLn "exp = K3 (__::TK) J3"+#else+                  putStrLn "exp = K3 K2 (__::TJ)"+#endif+                  putStrLn "get ~_ = show 1  -- seems to suffice?!?..."+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit18g False t++-------------------------------------------------------------------------------++  doit19 :: Bool -> [(Int,String)] -> IO ()+  doit19 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit19 b ((code,patstr):t) = do+--  let expstr = "True"+    let expstr = "5.6"+    let expect = case code of+                  1 -> expstr+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> expstr ++ " (but \"# with subpattern\" warning)"+                  6 -> expstr ++ " (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> expstr ++ " (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit19: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTL_1  -- L1 5.6 (M1 True)+                let exp = expTL_2  -- L1 5.6 (M1 __)+--              let exp = expTL_3  -- L1 5.6 __+--              let exp = expTL_4  -- L1 __ (M1 True)+                let pat = compilePat patstr+                let get = getL+--              let get = getL'+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = L1 5.6 (M1 __)"+--                putStrLn "exp = L1 5.6 __"+--                putStrLn "exp = L1 __ (M1 True)"+                  putStrLn "get (L1 f (M1 _)) = show f"+--                putStrLn "get (L1 f _) = show f"+--                putStrLn "get (L1 _ (M1 b)) = show b"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit19 False t++-------------------------------------------------------------------------------++  doit20 :: Bool -> [(Int,String)] -> IO ()+  doit20 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit20 b ((code,patstr):t) = do+    let expect = case code of+                  1 -> "4.5"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "4.5 (but \"# with subpattern\" warning)"+                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "4.5 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit20: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTK_1  -- K3 K2 (J1 4.5)+                let exp = expTK_2  -- K3 __ (J1 4.5)+                let pat = compilePat patstr+                let get = getK+                if b+                then do+                  putStrLn "==================================================="+--                putStrLn "exp = K3 K2 (J1 4.5)"+                  putStrLn "exp = K3 __ (J1 4.5)"+                  putStrLn "get = (K3 _ (J1 f)) = show f"+                  putStrLn "? = get $ forcep patstr exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+                putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+                putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  "expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! forcep patstr exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr "actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit20 False t++-------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 708+  doit23 :: String+  doit23 = show $ fg23 exp23+--doit23 = show $ get23 $ forcepDyn' fg23 exp23+   where+    exp23 = [[[__]],[[__,6],__,[7]]] :: [[[Int]]]+    get23 xs = (((xs!!1)!!2)!!0)+#if 0+    fg23 :: forall a. (Generic a, HasDatatypeInfo a) => a -> DatatypeInfo (Code a)+    fg23 d = dti+#else+    fg23 :: forall a. (Generic a, HasDatatypeInfo a, All2 Show (Code a), Typeable a) => a -> PatNode+#if 1+    fg23 d = doit23' dti proxy_a d (from d)+#else+    fg23 d | cname == "[[Int]]"  = WI+           | otherwise           = WR+#endif+#endif+     where+--    ADT mname tname (Constructor cname :* _) = dti+--    ADT mname tname (Constructor cname :* _) = dti :: DatatypeInfo (Code a)+--    (mname,tname,cname) = case dti of ...+--    ADT mname tname (Constructor cname :* (Infix ":" RightAssociative 5 :* Nil)) = dti+      dti = datatypeInfo proxy_a+      proxy_a = Proxy :: Proxy a+      xrep = from d++  doit23' :: forall a.+             (+               Generic a+             , HasDatatypeInfo a+--           , All2 NFDataP (Code a)+             , All2 Show (Code a)+             , Typeable a+--           , NFDataN a+--           , NFDataP a+             ) =>+                     DatatypeInfo (Code a)+                  -> Proxy a+                  -> a+                  -> Rep a+                  -> PatNode+  doit23' (ADT     _ _ cs) proxy_a x xrep+   = doit23'' cs         proxy_a x xrep+  doit23' (Newtype _ _ c ) proxy_a x xrep+   = doit23'' (c :* Nil) proxy_a x xrep++  doit23'' :: forall a xss.+            (+              Generic a+            , HasDatatypeInfo a+            , All2 Show xss+            ) =>+                    NP ConstructorInfo xss+                 -> Proxy a+                 -> a+                 -> SOP I xss+                 -> PatNode+  doit23'' (m :* _) proxy_a x (SOP (Z xs))+   | tx == "[[Int]]"  = WI+   | otherwise        = WR+   where+    !_ = trace ("*** "++tx) $ ()+    tx | (Constructor n) <- m  = n+       | (Infix n _ _) <- m    = n+       | (Record n _) <- m     = n+  doit23'' (m :* ms) proxy_a x (SOP (S xss))+   = doit23'' ms proxy_a x (SOP xss)+  doit23'' _ _ _ _ = error "doit23'': unexpected case!!"+#endif++-------------------------------------------------------------------------------++#endif++  doit24 :: Bool -> [(Int,Int,(Float,[Int],Bool))] -> IO ()+  doit24 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit24 b ((code,ident,exp):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit24: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = force_ Propagate (force_ Propagate 3.4, force_ Propagate (force_ Propagate 5 : (force_ Propagate __ : (force_ Propagate 7 : force_ Propagate []))), force_ Propagate __) :: (Float, [Int], Bool)+--              let seq_exp = mkSeqableHarness exp+--              let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = <refer to test code>"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $! exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+--              putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+--              putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr $ show ident ++ " actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit24 False t++-------------------------------------------------------------------------------++  doit25 :: Bool -> [(Int,Int,(Float,(Bool,Int),Bool))] -> IO ()+  doit25 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit25 b ((code,ident,exp):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit25: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = force_ Propagate (force_ Propagate 3.4, force_ Propagate (force_ Propagate 5 : (force_ Propagate __ : (force_ Propagate 7 : force_ Propagate []))), force_ Propagate __) :: (Float, [Int], Bool)+--              let seq_exp = mkSeqableHarness exp+--              let pat = compilePat patstr+                let get (_,(_,x),_) = show x+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = <refer to test code>"+                  putStrLn "get (_,(_,x),_) = show x"+                  putStrLn "? = get $! exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+--              putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+--              putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr $ show ident ++ " actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit25 False t++-------------------------------------------------------------------------------++#if USE_SOP++  doit26 :: Bool -> [(Int,Int,(Float,[Int],Bool))] -> IO ()+  doit26 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit26 b ((code,ident,exp):t) = do+    let expect = case code of+                  1 -> "7"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "7 (but \"# with subpattern\" warning)"+                  6 -> "7 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "7 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit26: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = force_ Propagate (force_ Propagate 3.4, force_ Propagate (force_ Propagate 5 : (force_ Propagate __ : (force_ Propagate 7 : force_ Propagate []))), force_ Propagate __) :: (Float, [Int], Bool)+--              let seq_exp = mkSeqableHarness exp+--              let pat = compilePat patstr+                let get (_,xs,_) = show $ (xs!!2)+                if b+                then do+                  putStrLn "==================================================="+                  putStrLn "exp = <refer to test code>"+                  putStrLn "get (_,xs,_) = show $ (xs!!2)"+                  putStrLn "? = get $! exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+--              putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+--              putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr $ show ident ++ " actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit26 False t++-------------------------------------------------------------------------------++  doit27 :: Bool -> [(Int,Int,TJ)] -> IO ()+  doit27 _ [] = do+                   putStrLn "--------------------------------------------------"+                   return ()+  doit27 b ((code,ident,exp):t) = do+    let expect = case code of+                  1 -> "4.5"+                  2 -> "Prelude.undefined"+                  3 -> "pattern-match failure"+                  4 -> "syntax error"+                  5 -> "4.5 (but \"# with subpattern\" warning)"+                  6 -> "4.5 (but \"constraint/subpattern arity mismatch\" warning)"+                  13 -> "4.5 (but with pattern-match failure warning)"+                  23 -> "Prelude.undefined (but with pattern-match failure warning)"+                  _ -> error $ "doit27: unexpected code " ++ show code+    s <- catch+           ( do+--              let exp = expTJ_1  -- J2 (1, J4 (J3, K3 K2 (J1 4.5))) False+--              let exp = expTJ_2  -- J2 (1, J4 (J3, K3 __ (J1 4.5))) False+--              let exp = expTJ_3  -- J2 (1, J4 (__, K3 K2 (J1 4.5))) False+--              let exp = expTJ_4  -- J2 (1, J4 (__, K3 __ (J1 4.5))) __+--              let pat = compilePat patstr+                let get = getJ+                if b+                then do+                  putStrLn "==================================================="+--                putStrLn "exp = J2 (1, J4 (J3, K3 K2 (J1 4.5))) False"+--                putStrLn "exp = J2 (1, J4 (J3, K3 __ (J1 4.5))) False"+--                putStrLn "exp = J2 (1, J4 (__, K3 K2 (J1 4.5))) False"+                  putStrLn "exp = J2 (1, J4 (__, K3 __ (J1 4.5))) __"+                  putStrLn "get = (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f"+                  putStrLn "? = get exp"+                  putStrLn "==================================================="+                else do+                  putStrLn "---------------------------------------------------"+--              putStrLn $ "patstr                   = " ++ patstr+                if code > 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+--              putStrLn $ "pat = " ++ show pat+--              putStrLn $ "showPat.compilePat       = " ++ showPat pat+                if code <= 4+                then putStrLn $  show ident ++ " expected value           = " ++ expect+                else return ()+                s1 <- catch+                        ( return $! force $! get $! exp )+                        (\e -> do let err = show (e :: ErrorCall)+--                      (\e -> do let err = show (e :: BottomedOut)+                                  return err)+                putStr $ show ident ++ " actual value             = "+                return $! s1+           )+           -- ErrorCall if use __ = undefined+           -- BottomedOut if use __ = throw BottomedOut+           (\e -> do let err = show (e :: ErrorCall)+--         (\e -> do let err = show (e :: BottomedOut)+                     return err)+    putStrLn s+    doit27 False t++-------------------------------------------------------------------------------++#endif+
+ tests/Bottom.hs view
@@ -0,0 +1,41 @@++  {-# LANGUAGE CPP #-}+  {-# LANGUAGE DeriveDataTypeable #-}++-------------------------------------------------------------------------------++  module Bottom where++-------------------------------------------------------------------------------++  import Util++  import Data.Maybe++  import Control.Exception+--import Control.Monad ( guard )+  import Data.Typeable ( Typeable )+  import Data.Typeable ( typeOf )++  import Debug.Trace ( trace )+  import Control.DeepSeq++  import System.IO.Unsafe ( unsafePerformIO )++-------------------------------------------------------------------------------++  __ :: a+--bt'm = undefined+  __ = undefined+--__ = throw BottomedOut++-------------------------------------------------------------------------------++  data BottomedOut = BottomedOut+--data BottomedOut = ThisException | ThatException+    deriving (Show, Typeable)++  instance Exception BottomedOut++-------------------------------------------------------------------------------+
+ tests/Foo.hs view
@@ -0,0 +1,265 @@++-- XXX This file could be cleaned up a lot, but that's+-- not quite a priority at this moment...++  {-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------++#define USE_TRACE 1+-- This so can get an honest comparison for the user-defined datatypes;+-- if this is 0, the NFDataN instances will be derived via GHC.Generics.+-- (The NFData instances are derived in any case.)+#define USE_MANUAL_INSTANCES 0++-------------------------------------------------------------------------------++  module Foo where++-------------------------------------------------------------------------------++-- TABLE OF EXPECTED AND ACTUAL RESULTS+-- (Only recording "BOT" or "ok".)+--+-- The expressions and getters are effectively:+--+-- expBase1 = ([True,False],3,Just "fox")         :: ([Bool],Int,Maybe String)+-- expBase2 = ([True,False],__,Just "fox")        :: ([Bool],Int,Maybe String)+-- expBase3 = ([True,__],3,Just "fox")            :: ([Bool],Int,Maybe String)+-- expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)+-- expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)+-- expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)+-- get1 ((x:_),_,_) = x           -- True+-- get2 (_,x,_) = x               -- 3+-- get3 (_,_,x) = fromJust x      -- "fox"+-- get4 (_,_,Just (x:_)) = x      -- 'f'+--+-- These match like Haskell pattern-matching -- the higher will+-- be matched first; the lower will pick up what trickles through.+--+--  (i,j,k)         Expected           Actual+--   * * 1            ok                 ok+--   2 1 2            BOT                BOT+--   * 1 2            ok                 ok+--   * * 2            BOT                BOT+--   * 4 3            BOT                BOT+--   * 5 3            BOT                BOT+--   * * 3            ok                 ok+--   1 1 4            ok                 ok+--   1 2 4            ok                 ok+--   * * 4            BOT                BOT+--   3 * 5            BOT                BOT+--   * 5 5            BOT                BOT+--   * * 5            ok                 ok++-- AND, SOLVED -- by forcing that show!+-- Great! And it's the USE_EXCEPTION branch too, which I prefer+-- in principle.  Now to consider the output...++-- It seems that this difference decides whether escapee exception+-- happens of (3,1,4) or (3,1,5):+--     doit (1+i) j k $! acc+--  -- doit (1+i) j k $ acc+-- What I don't understand is why "show" which is part of get3+-- doesn't force it where the handler can catch it...++-- What a confusion!+-- So, if you also insert some tracing, you can see all (i,j,k)+-- indices traced, yet the exception still occurs.+-- I suppose this is because the acc string isn't forced+-- until later, and meanwhile the trace lines are free to+-- be printed. (This is the explanation for sure.)+--   But just forcing acc is not the same thing?...+-- If force acc, you see nothing at all printed except the+-- trace lines. All of [ABC](3,1,5) are printed, and then+-- the escapee exception rises.++-- And anyhow, now it passes 4 but not 5, and I don't even know+-- how/why? I'm not using overridden fromJust anymore...+-- (i=3 k=5 exception still escapes in any case!)++-- By overriding fromJust I was able to get past expBase4,+-- but i=3 k=5 exception still escapes!...++-- STILL not getting it -- I can run the gamut, just using+-- putStrLn (as we're in IO anyhow since started fussing+-- with exception catching).  And it says we bottom out+-- a few times, with proper interleaving -- but these are+-- only when /get/ requests a __ value; it doesn't seem+-- to do anything when forcen supposedly forces it.+--   And yet, when run with USE_EXCEPTION, we do see these+-- extra bottom-outs -- unfortunately, the "exceptional+-- exception" occurs and the darned thing doesn't run to+-- completion.++-- Having some problems.+-- Same results if use ErrorCall or use custom BottomedOut,+-- namely, get as far as:+--   ( get3 $ forcen 1 expBase4 )+--   t: BottomedOut+-- The "t: " is significant, since normally when hit+-- the "potholes" my exception handler prints only "BottomedOut".+-- And this also terminates the testing.+-- So clearly, my (own, custom, even -- good to know) exception+-- is escaping the handler.  How can this be?  Esp. as it seems+-- nothing much changes from one test to another.+-- The only thing that comes to mind is, we don't catch ASYNCHRONOUS+-- exceptions this way? Why should an asynch. exception be raised+-- in this case. Trying one more thing: define __ to be trace+-- and just trace the fact it was evaluated...++-- XXX Regarding the use of undefined, I think this is not+-- working well for catching all exceptions? Would we have+-- better luck throwing a custom exception type? How do you+-- do that? "throw BottomedOut" in the component of the tuple?...++  import Data.Maybe++  import Control.Exception+--import Control.Monad ( guard )+  import Data.Typeable ( Typeable )+  import Data.Typeable ( typeOf )++--import Util+  import Debug.Trace ( trace )+  import Control.DeepSeq++#if ! HASKELL98_FRAGMENT+  -- Custom exception requires -XDerivingDataTypeable it seems. [?]+  import Bottom+#endif++  import System.IO.Unsafe ( unsafePerformIO )++-------------------------------------------------------------------------------++#if HASKELL98_FRAGMENT+  __ = undefined+#else+-- imported from Bottom (sorry)+#endif++-------------------------------------------------------------------------------++  expN_1 = [__] :: [Int]+  expN_2 = [0,1,__,3] :: [Int]+  expN_3 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)+  expN_4 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)++  getN_1 xs = show $ ()+--getN_1 xs = show $ head xs+--getN_2 xs = show $ (xs!!1)+  getN_2 xs = show $ (xs!!3)+  getN_3 (_,xs,_) = show $ (xs!!2)++-------------------------------------------------------------------------------++#if 0++  -- Should be able to dodge the third component with a pattern.+--expP_1 = (3.4, [5,__,7], True) :: (Float, [Int], Bool)+  expP_1 = (3.4, [5,__,7], __) :: (Float, [Int], Bool)+  patP_1 = Node (TR [typeOf ((__,__,__)::(Float, [Int], Bool))])+             [ Node (TR [typeOf (__::Bool)]) []+--           [ Node (TR [typeOf (__::Float)]) []+--           [ Node (NTR [typeOf (__::Bool)]) []+--           [ Node (NTR [typeOf (__::Float)]) []+--           , Node WS []+             , Node (TW [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) []+--           , Node (TR [typeOf ([__]::[Int])]) [ Node WS [], Node WS [] ]  -- why not?+             , Node WW []+--           , Node I []+             ]+  getP_1 (_,xs,_) = show $ (xs!!2)++  expP_2 = 23 :: Int+--expP_2 = [1,__,3] :: [Int]+  patP_2 = Node WW []+--patP_2 = Node (TR [typeOf ([__]::[Int])]) []+  getP_2 x = show x++#if 1+-- Fuck, this works too... (the only one of all of 'em, except bare 23)+-- See NFDataP.hs for expansion of PatNode constructors...+-- (It's hardly going to be that useful if you have to specify+-- one constructor per node in whole data structure, rather than+-- just match the top bit you want as one expects with patterns.)+-- So I'm basically committed to this expansion...+  expP_3 = (3.4, (5,__), __) :: (Float, (Int,Int), Bool)+  patP_3 = Node (TR [typeOf ((__,__,__)::(Float, (Int,Int), Bool))])+#if 0+             [ Node W []+             , Node I [ Node W [], Node W [] ]  -- works+--           , Node I []                        -- doesn't work+             , Node W []+             ]+#else+             [ Node WR []+             , Node WR [ Node WR [], Node WR [] ]  -- works+--           , Node WR []                        -- doesn't work+             , Node WR []+             ]+#endif+  getP_3 (_,(_,x),_) = show x+#else+  expP_3 = (3.4, (5,__), __) :: (Float, (Int,Int), Bool)+  patP_3 = Node (T [typeOf ((__,__,__)::(Float, (Int,Int), Bool))])+             [ Node (T [typeOf (__::Float)]) []+--           [ Node W []+             , Node (T [typeOf ((__,__)::(Int,Int))]) []+             , Node I []+             ]+  getP_3 (_,(_,x),_) = show x+#endif++#endif++-------------------------------------------------------------------------------++  expBase1 = ([True,False],3,Just "fox")         :: ([Bool],Int,Maybe String)+  expBase2 = ([True,False],__,Just "fox")        :: ([Bool],Int,Maybe String)+  expBase3 = ([True,__],3,Just "fox")            :: ([Bool],Int,Maybe String)+  expBase4 = ([True,__],3,Just __)               :: ([Bool],Int,Maybe String)+  expBase5 = ([True,False],3,Just ['f',__,'x'])  :: ([Bool],Int,Maybe String)+  expBase6 = ([True,False],3,Just __)            :: ([Bool],Int,Maybe String)++#if 1+  get1 ((x:_),_,_) = show x         -- True+  get2 (_,x,_) = show x             -- 3+#if 0+#if 0+  get3 (_,_,x) = do+                    es <- myFromJust x  -- "fox"+                    case es of+                     Left () -> return ""+                     Right s -> return $! show s+--get3 (_,_,x) = show $! myFromJust x  -- "fox"+#else+  get3 (_,_,x) = return $! show $! fromJust x  -- "fox"+--get3 (_,_,x) = return $ show $ fromJust x  -- "fox"+#endif+#else+  get3 ijk (_,_,x) = force $ show $ fromJust x  -- "fox"+--get3 ijk (_,_,x) = trace ("A"++show ijk) ( force $ show $! trace ("B"++show ijk) $ fromJust $! trace ("C"++show ijk) $ x )  -- "fox"+--get3 (_,_,x) = show $! fromJust x  -- "fox"+--get3 (_,_,x) = show $ fromJust x  -- "fox"+#endif+  get4 (_,_,Just (x:_)) = show x    -- 'f'+#else+  get1 ((x:_),_,_) = x       -- True+  get2 (_,x,_) = x           -- 3+  get3 (_,_,x) = fromJust x  -- "fox"+  get4 (_,_,Just (x:_)) = x  -- 'f'+#endif++#if 0+  -- oops, these are just what you DON'T want!+  get1 (_,x,_) = x  -- 3+  get2 (_:x:_) = x  -- False+  get3 (_,_,x) = fromJust x  -- "fox"+  get4 (_,_,(_:x:_)) = x  -- 'o'+#endif++-------------------------------------------------------------------------------+
+ tests/FooG.hs view
@@ -0,0 +1,617 @@++-- XXX This file could be cleaned up a lot, but that's+-- not quite a priority at this moment...++  {-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------++#define USE_TRACE 1+-- This so can get an honest comparison for the user-defined datatypes;+-- if this is 0, the NFDataN instances will be derived via GHC.Generics.+-- (The NFData instances are derived in any case.)+#define USE_MANUAL_INSTANCES 0++-------------------------------------------------------------------------------++#if USE_SOP+  {-# LANGUAGE DataKinds #-}+  {-# LANGUAGE TypeFamilies #-}+  -- XXX This wasn't here, when came to make the edit to add the CPP below it!+  {-# LANGUAGE ConstraintKinds #-}+#if __GLASGOW_HASKELL__ < 708+  {-# LANGUAGE GADTs #-}+#endif+  {-# LANGUAGE TemplateHaskell #-}+#else+  {-# LANGUAGE DeriveGeneric #-}+#endif++  {-# LANGUAGE DeriveGeneric #-}  -- still needed to derive NFData...++  {-# LANGUAGE DeriveDataTypeable #-}  -- to make BottomedOut++-------------------------------------------------------------------------------++  module FooG where++-------------------------------------------------------------------------------++--import Control.DeepSeq.Generics+  import Control.DeepSeq.Bounded hiding ( F )+  import Control.DeepSeq.Bounded.Generic++#if USE_SOP+  import Generics.SOP.TH+#else+  import GHC.Generics+--import GHC.Generics ( Generic )+#endif++  import GHC.Generics ( Generic ) -- still needed to derive NFData...+  import Control.DeepSeq.Generics++  import Data.Maybe++  import Control.Exception+--import Control.Monad ( guard )+  import Data.Typeable ( Typeable )+  import Data.Typeable ( typeOf )++--import Util+  import Debug.Trace ( trace )+  import Control.DeepSeq++  import Bottom++  import System.IO.Unsafe ( unsafePerformIO )++-------------------------------------------------------------------------------++  data TA = A1 Bool Int+          | A4 (Float,TB,Int)  -- (testing reordering!)+          | A2 Int+          | A3 TB Bool+          | A5 (Int,Float)+#if USE_SOP+    deriving (Show)+#else+    deriving (Show,Generic)+#endif+--instance NFData TA where rnf = genericRnf+#if USE_MANUAL_INSTANCES+  instance NFDataN TA where+    rnfn n (A1 x y)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y+    rnfn n (A2 x)+     | n <= 0     = ()+     | otherwise  = rnfn (-1+n) x+    rnfn n (A3 x y)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y+    rnfn n (A4 x)+     | n <= 0     = ()+     | otherwise  = rnfn (-1+n) x+#else+#if USE_SOP+  instance NFDataN TA where rnfn = grnfn+#else+  instance NFDataN TA where rnfn = genericRnfn+#endif+#endif+  expTA = A1 __ 3++  data TB = B1 Bool TA+          | B2 TA TB+          | B3 Bool TA Int+          | B4 Bool Int TA+          | B5 Bool Int Float+          | B6 TA+          | B7 TB+          | B8 (Int,Float)+          | B9 Bool (Int,Float) Int+          | B10 (Int,Int,(Int,Int,Int,Int),Int)+          | B11 Bool (Int,Int,(Int,Int,Int,Int),Int)+#if USE_SOP+    deriving (Show)+#else+    deriving (Show,Generic)+#endif+--instance NFData TB where rnf = genericRnf+#if USE_MANUAL_INSTANCES+  instance NFDataN TB where+    rnfn n (B1 x y)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y+    rnfn n (B2 x y)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y+    rnfn n (B3 x y z)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y `seq` rnfn n' z+    rnfn n (B4 x y z)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y `seq` rnfn n' z+    rnfn n (B5 x y z)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y `seq` rnfn n' z+    rnfn n (B6 x)+     | n <= 0     = ()+     | otherwise  = rnfn (-1+n) x+#else+#if USE_SOP+  instance NFDataN TB where rnfn = grnfn+#else+  instance NFDataN TB where rnfn = genericRnfn+#endif+#endif++#if USE_SOP+  deriveGeneric ''TA+  deriveGeneric ''TB+#endif++  expTB_1 = B2 (A1 True 4) (B1 True (A2 23))+--expTB_1 = B2 (A1 True 4) (B1 True (A2 __))+  expTB_2 = B2 (A1 __   4) (B1 True (A2 __))+  expTB_3 = B2 (A1 __   4) (B1 __   (A2 __))+--expTB_4 = B2 (A1 True 4) (B1 True (A2 __))+--expTB_4 = B2 (A1 True 4) (B1 __   (A2 __))+  expTB_4 = B2 (A1 True 4) (B1 __   (A2 23))+  expTB_5+   = B2+        (A3 (B1 False (A2 __)) True)+        (B1 True (A1 False 4))+  expTB_6+   = B2+        (A3 (B1 __ (A2 3)) True)+        (B1 True (A1 False 4))+  expTB_7+   = B2+        (A3 (B1 False (A2 3)) True)+        (B1 __ (A1 False 4))+  expTB_8+   = B2+        (A3 (B1 False (A2 3)) True)+        (B1 True (A1 __ 4))+  expTB_9+   = B2+        (A3 (B3 False __ 5) True)+        (B1 True (A1 False 4))+  expTB_10                                                -- 5  .+   = B2+        (A3 (B3 False (A2 3) 5) True)+        (B1 True (A4 (2.3, B1 False (A1 True 4), __)))+  expTB_11+   = B2+        (A3 (B3 False (A2 3) 5) True)+        (B1 True (A4 (__, B1 False (A1 True 4), 6)))+  expTB_12+   = B2+        (A3 (B3 False (A2 3) 5) True)+        (B1 True (A4 (2.3, B1 False (A1 __ 4), 6)))+  expTB_13+   = B2+        (A3 (B3 False (A2 3) __) True)+        (B1 True (A1 False 4))+  expTB_14+   = B2+        (A3 (B3 False (A2 __) 5) True)+        (B1 True (A1 False 4))+  expTB_15 = A3 (B3 False __ 5) False  -- not expTB actually+                             -- For the non-combinator SOP recursion version:+  expTB_16 = B3 False (A2 __) 5   -- E/A =  3  .   B3 Bool TA Int+--expTB_16 = B7 (B3 False __ 5)   -- E/A =  3  .   B3 Bool TA Int+--expTB_16 = B3 False __ 5        -- E/A =  2  .   B3 Bool TA Int+  expTB_17 = B4 False 5 __        -- E/A =  2  .   B4 Bool Int TA+  expTB_18 = B5 False 5 __        -- E/A =  2  .   B5 Bool Int Float+  expTB_19 = B1 False __          -- E/A =  2  .   B1 Bool TA+  expTB_20 = B6 __                -- E/A =  2  .   B6 TA++--data TA = A1 Bool Int+--        | A4 (Float,TB,Int)+--        | A2 Int+--        | A3 TB Bool+--        | A5 (Int,Float)+--data TB = B1 Bool TA+--        | B2 TA TB+--        | B3 Bool TA Int+--        | B4 Bool Int TA+--        | B5 Bool Int Float+--        | B6 TA+--        | B7 TB+--        | B8 (Int,Float)+--        | B9 Bool (Int,Float) Int+  expTB_21 = B7 (B7 (B5 __ 5 2.3))    -- E/A =  4  .+  expTB_22 = B7 (B7 (B5 True 5 __))   -- E/A =  4  .+  expTB_23 = B1+                True+                (A4+                    ( 2.3+                    , B2+                         -- forcen 4 takes you to here (unwrapping B2).+                                                     -- Bottoms-out at n=?+                                                     -- (X Y) = SOP recurs.+                                                     -- E(xpect) A(ctual)+                                                     -- E  A (. if A=E)+--                       (A3 (B6 (A2 __)) False)     -- 8  .+                         (A3 (B6 (A2 7)) False)      -- never+                         (B3 True (A2 5) __)         -- 6  8  ( 6  . )+--                       (B9 True (2,__) 6)          -- 7  .  ( 7  . )+--                       (B9 True (__,3.4) 6)        -- 7  .  ( 7  . )+--                       (B9 True __ 6)              -- 6  7  ( 6  . )+--                       (B3 True __ 6)              -- 6  7  ( 6  . )+--                       (B3 True (A2 __) 6)         -- 7  .  ( 7  . )+--                       (B3 __ (A2 5) 6)            -- 6  .  ( 6  . )+--                       (B3 True (A2 5) 6)          -- never+                    , 7))+                                                           -- E  A+--expTB_24 = B10 (1,2,(3,__,5,6),7)                        -- 4  .+  expTB_24 = B11 False (1,2,(3,__,5,6),7)                  -- 4  .+  expTB_25 = B9 True __ 6                                  -- 2  .+--expTB_25 = B9 __ (1,2.3) 6                               -- 2  .+--expTB_26 = B7 (B9 True __ 6)                             -- 3  .+--expTB_26 = B7 (B7 (B7 (B7 (B9 True __ 6))))              -- 6  .+  expTB_26 = B2 (A2 8) (B7 (B7 (B7 (B7 (B9 True __ 6)))))  -- 7  .++  getA (A3 _ b) = show b++  expBase7 = expTB_1+  expBase8 = expTB_2+  expBase9 = expTB_3+  expBase10 = expTB_4+  expBase11 = expTB_5+  expBase12 = expTB_6+  expBase13 = expTB_7+  expBase14 = expTB_8+  expBase15 = expTB_9+  expBase16 = expTB_10+  expBase17 = expTB_11+  expBase18 = expTB_12+  expBase19 = expTB_13+  expBase20 = expTB_14+  expBase21 = expTB_15+  expBase22 = expTB_16+  expBase23 = expTB_17+  expBase24 = expTB_18+  expBase25 = expTB_19+  expBase26 = expTB_20++  expBase27 = expTB_21+  expBase28 = expTB_22+  expBase29 = expTB_23+  expBase30 = expTB_24+  expBase31 = expTB_25+  expBase32 = expTB_26++-------------------------------------------------------------------------------++#if 1+  getB_1 :: TB -> String+  getB_1 (B1 b _) = show b+  getB_1 (B2 _ (B1 b _)) = show b+  getB_1 (B3 _ _ n) = show n+  getB_1 (B4 _ n _) = show n+  getB_1 (B5 _ n _) = show n+  getB_1 (B6 _) = "beesix"+--getB_1 (B7 x) = getB_1 x+  getB_1 _ = error "!"+  getB_2 :: TB -> String+  getB_2 (B1 b _) = show b+  getB_2 (B2 (A1 _ n) _) = show n+  getB_2 (B2 (A3 _ b) _) = show b+  getB_2 (B3 _ _ n) = show n+  getB_2 (B4 _ n _) = show n+  getB_2 (B5 _ n _) = show n+  getB_2 (B6 _) = "beesix"+  getB_2 _ = error "!"+  getB_3 _ = "<bah>"+#else+  getB_1 :: TB -> Bool+  getB_1 (B2 _ (B1 b _)) = b+  getB_1 _ = error "!"+  getB_2 :: TB -> Int+  getB_2 (B2 (A1 _ n) _) = n+  getB_2 _ = error "!"+#endif++-------------------------------------------------------------------------------++  data TC = C Int Bool+#if USE_SOP+    deriving (Show)+#else+    deriving (Show,Generic)+#endif+--instance NFData TC where rnf = genericRnf+#if USE_MANUAL_INSTANCES+  instance NFDataN TC where+    rnfn n (C x y)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y+#else+#if USE_SOP+  deriveGeneric ''TC+  instance NFDataN TC where rnfn = grnfn+#else+  instance NFDataN TC where rnfn = genericRnfn+#endif+#endif+  expTC = C __ True+  getC (C _ x) = x++  data TD = D1 Int Bool+          | D2 Int Bool+#if USE_SOP+    deriving (Show)+#else+    deriving (Show,Generic)+#endif+--instance NFData TD where rnf = genericRnf+#if USE_MANUAL_INSTANCES+  instance NFDataN TD where+    rnfn n (D1 x y)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y+    rnfn n (D2 x y)+     | n <= 0     = ()+     | otherwise  = let n' = -1+n in rnfn n' x `seq` rnfn n' y+#else+#if USE_SOP+  deriveGeneric ''TD+  instance NFDataN TD where rnfn = grnfn+#else+  instance NFDataN TD where rnfn = genericRnfn+#endif+#endif+  expTD_1 = D1 __ True+  expTD_2 = D2 __ True+  getD (D1 _ x) = x+  getD (D2 _ x) = x++-------------------------------------------------------------------------------++  data TE = E TF+#if USE_SOP+    deriving (Show)+#else+    deriving (Show,Generic)+#endif+--instance NFData TE where rnf = genericRnf+#if USE_MANUAL_INSTANCES+  instance NFDataN TE where+    rnfn n (E x)+     | n <= 0     = ()+     | otherwise  = rnfn (-1+n) x+#else+#if USE_SOP+  instance NFDataN TE where rnfn = grnfn+#else+  instance NFDataN TE where rnfn = genericRnfn+#endif+#endif++  data TF = F Int+#if USE_SOP+    deriving (Show)+#else+    deriving (Show,Generic)+#endif+--instance NFData TF where rnf = genericRnf+#if USE_MANUAL_INSTANCES+  instance NFDataN TF where+    rnfn n (F x)+     | n <= 0     = ()+     | otherwise  = rnfn (-1+n) x+#else+#if USE_SOP+  instance NFDataN TF where rnfn = grnfn+#else+  instance NFDataN TF where rnfn = genericRnfn+#endif+#endif++#if USE_SOP+  deriveGeneric ''TE+  deriveGeneric ''TF+#endif++  expTE_1 = E (F 23)+  expTE_2 = E (F __)+  expTE_3 = E __++#if 1+  -- These all produce the same, unexpected result; so maybe the+  -- pattern-matching isn't implicated?...+  getE (E _) = "getee"+--getE (E ~_) = "getee"+--getE (E ~x) = "getee"+#else+  -- In order for this not to just print "getee" every time,+  -- you need to make "get $ " to "get $! " everywhere it+  -- occurs in Main.hs.+  getE _ = "getee"  -- making sure the (E _) isn't triggering...+#endif++-------------------------------------------------------------------------------++#if USE_SOP++  -- Following the shape of the base-typed test expression+  -- used in Blah.doit10:  (_, [_,_,_], _) :: (Float, [Int], Bool)++  data TG = G1 | G2 Int Int Int+    deriving (Show,Generic,Typeable)+--  deriving (Show,Generic)+--  deriving (Show)+--instance NFData TG where rnf = genericRnf+  instance NFDataP TG where rnfp = grnfp+  instance NFDataN TG where rnfn = grnfn+  instance NFData TG where rnf = genericRnf++  deriveGeneric ''TG++  expTG_1 = ( G1, G2 5 6 7, True )+  expTG_2 = ( __, G2 __ __ 7, __ )+  expTG_3 = ( G1, G2 __ __ 7, __ )+  expTG_4 = ( G1, G2 5 6 7, __ )+  expTG_5 = ( G1, G2 5 __ 7, __ )   -- this is the analogue of doit10 exp++  getG :: (TG,TG,Bool) -> String+  getG (_,(G2 _ _ n),_) = show n+--getG (_,(G2 _ _ _),_) = "getG-G2"+  getG _ = "getG-!"++  expTG_6 = G2 5 __ 7+  getG' :: TG -> String+  getG' (G2 _ _ n) = show n++#endif++-------------------------------------------------------------------------------++#if USE_SOP++  -- A more elaborate shape for more thorough testing!++  data TH = H1 Float | H2 Int [TH] Bool | H3 | H4 (TH,TI)+    deriving (Show,Generic,Typeable)+  instance NFDataP TH where rnfp = grnfp+  instance NFDataN TH where rnfn = grnfn+  instance NFData  TH where rnf  = genericRnf++  data TI = I1 (Bool,TH) | I2 | I3 TI TH+    deriving (Show,Generic,Typeable)+  instance NFDataP TI where rnfp = grnfp+  instance NFDataN TI where rnfn = grnfn+  instance NFData  TI where rnf  = genericRnf++  deriveGeneric ''TH+  deriveGeneric ''TI++  expTH_1 = H2 1 [H1 2.3, H3, H4 (H3, I3 I2 (H1 4.5))] False+  expTH_2 = H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] False+  expTH_3 = H2 1 [H1 2.3, H3, H4 (__, I3 I2 (H1 4.5))] __+  expTH_4 = H2 1 [H1 2.3, H3, H4 (__, I3 __ (H1 4.5))] __++  getH :: TH -> String+  getH (H2 _ [_, _, H4 (_, I3 _ (H1 f))] _) = show f+  getH _ = "getH-!"++#endif++-------------------------------------------------------------------------------++#if USE_SOP++  -- A more elaborate shape for more thorough testing!++  data TJ = J1 Float | J2 (Int,TJ) Bool | J3 | J4 (TJ,TK) | J5 Int | J6 TK+    deriving (Show,Generic,Typeable)+  instance NFDataP TJ where rnfp = grnfp+  instance NFDataN TJ where rnfn = grnfn+  instance NFData  TJ where rnf  = genericRnf++  data TK = K1 (Bool,TJ) | K2 | K3 TK TJ | K4 Int Bool | K5 TJ | K6 Float Int Bool | K7 TJ TJ+    deriving (Show,Generic,Typeable)+  instance NFDataP TK where rnfp = grnfp+  instance NFDataN TK where rnfn = grnfn+  instance NFData  TK where rnf  = genericRnf++  deriveGeneric ''TJ+  deriveGeneric ''TK++  expTJ_1 = J2 (1, J4 (J3, K3 K2 (J1 4.5))) False+  expTJ_2 = J2 (1, J4 (J3, K3 __ (J1 4.5))) False+  expTJ_3 = J2 (1, J4 (__, K3 K2 (J1 4.5))) False+  expTJ_4 = J2 (1, J4 (__, K3 __ (J1 4.5))) __++  getJ :: TJ -> String+  getJ (J2 (_, J4 (_, K3 _ (J1 f))) _) = show f+  getJ _ = "getJ-!"+  getJ' :: TJ -> String++  expTJ_5 = J2 (1, J4 (__, K2)) False++  getJ' ~_ = show 1+--getJ' _ = show 1+--getJ' (J2 ~(n, ~_) _) = show n+--getJ' (J2 (n, _) _) = show n+--getJ' (J2 (n, J4 (_, K2)) _) = show n+--getJ' (J2 (n, J4 (_, K2)) False) = show n  -- most explicit+  getJ' _ = "getJ'-!"++  expTJ_6 = J4 (__, K2)+  getJ6 ~_ = show 1++  expTJ_7 = (__, K2) :: (TJ, TK)+  getJ7 ~_ = show 1++  expTJ_8 = __ :: TJ+  getJ8 ~_ = show 1++  expTK_1 = K3 K2 (J1 4.5)+  expTK_2 = K3 __ (J1 4.5)++  getK :: TK -> String+  getK (K3 _ (J1 f)) = show f+  getK _ = "getK-!"++#endif++-------------------------------------------------------------------------------++#if USE_SOP++  -- Trying to find a minimal failing case now...++#if 1+  data TL = L1 TM Float+#else+  data TL = L1 Float TM+#endif+    deriving (Show,Generic,Typeable)+  instance NFDataP TL where rnfp = grnfp+  instance NFDataN TL where rnfn = grnfn+  instance NFData  TL where rnf  = genericRnf++  data TM = M1 Bool+    deriving (Show,Generic,Typeable)+  instance NFDataP TM where rnfp = grnfp+  instance NFDataN TM where rnfn = grnfn+  instance NFData  TM where rnf  = genericRnf++  deriveGeneric ''TL+  deriveGeneric ''TM++#if 1+  expTL_1 = L1 (M1 True) 5.6+  expTL_2 = L1 (M1 __) 5.6+  expTL_3 = L1 __ 5.6+  expTL_4 = L1 (M1 True) __++  getL :: TL -> String+  getL (L1 (M1 _) f) = show f+  getL _ = "getL-!"+  getL' :: TL -> String+  getL' (L1 (M1 b) _) = show b+  getL' _ = "getL'-!"+#else+  expTL_1 = L1 5.6 (M1 True)+  expTL_2 = L1 5.6 (M1 __)+  expTL_3 = L1 5.6 __+  expTL_4 = L1 __ (M1 True)++  getL :: TL -> String+  getL (L1 f (M1 _)) = show f+  getL _ = "getL-!"+  getL' :: TL -> String+  getL' (L1 _ (M1 b)) = show b+  getL' _ = "getL'-!"+#endif++#endif++-------------------------------------------------------------------------------+
+ tests/Suite.hs view
@@ -0,0 +1,35 @@++{-# LANGUAGE CPP #-}+{-  DeriveDataTypeable, DeriveGeneric #-}+--- {-  LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric #-}++  module Main (main) where++#if 0+-- IUT+  import Control.DeepSeq.Bounded+#if ! HASKELL98_FRAGMENT+  import Control.DeepSeq.Bounded.Generic+#endif+#endif++  import Test.HUnit+  import System.Exit+  import System.IO ( stdout )+  import Debug.Trace ( trace )++  import qualified Tests++--------------------------------------------++  tests =+    "All" ~: [ Tests.tests+             ]++  main = do+            putStrLn "Running tests for deepseq-bounded..."+            counts <- runTestTT tests+            if failures counts > 0+              then exitFailure+              else exitSuccess+
+ tests/Tests.hs view
@@ -0,0 +1,49 @@++-- Refer to /work/Projects/MiniProjects/SybShape/tests for+-- more code in first HUnit example (which itself is still+-- just fudging it)!++{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------++  module Tests ( tests ) where++-------------------------------------------------------------------------------++  import Test.HUnit++  import System.IO.Unsafe ( unsafePerformIO )++#if NEW_IMPROVED_PATTERN_GRAMMAR+#if HASKELL98_FRAGMENT+  import qualified Blah98 as Blah+#else+  import qualified Blah   as Blah  -- better parallel with below+--import qualified Blah+#endif+#else+#if HASKELL98_FRAGMENT+  import qualified Blah98_old_grammar as Blah+#else+  import qualified Blah_old_grammar   as Blah+#endif+#endif++-------------------------------------------------------------------------------++-- XXX A better way to "fail on purpose" is to have the test+-- return ExitFailure, no?...+--tests = (unsafePerformIO main_tests == output) ~? "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!"  -- yeah but it wasn't printed+  tests = unsafePerformIO+            ( do+                 n <- Blah.run_tests+                 putStrLn "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!\n"+                 return n )+            ~=? output+  output = 1::Int  -- force test to fail! (so we see the output!)+--output = 0::Int+--output = ()++-------------------------------------------------------------------------------+
+ tests/Util.hs view
@@ -0,0 +1,112 @@++-------------------------------------------------------------------------------++{-  OPTIONS_GHC -O0 #-}  -- if want quick recompln.+{-  OPTIONS_GHC -package ghc #-}  -- (done via command-line/cabal)+{-# LANGUAGE CPP #-}++#define USE_ANSI_COLOUR_TERMINAL 0++-------------------------------------------------------------------------------++  module Util (++    show_list ,+    trace ,+    trace_ ,+    trace' ,+    myTrace ,+    myTrace' ,+    spoor ,+    spoor' ,+    spoorf ,+#if 0+    spoorNF ,+#endif+    trayceIO ,++  ) where++-------------------------------------------------------------------------------++  import System.IO++  import Data.List ( intersperse )++#if 0+  import Control.DeepSeq.Generics ( genericRnf )+  import Control.DeepSeq.Generics ( force )+  import Control.DeepSeq.Generics ( NFData(..) )+#endif++  import System.IO.Unsafe ( unsafePerformIO )  -- XXX for tracing only++-------------------------------------------------------------------------------++  show_list lst = concat $ intersperse "\n" $ map show lst++-------------------------------------------------------------------------------++  {-# NOINLINE trace #-}+  trace :: String -> a -> a+  trace s a = x `seq` a+   where x = unsafePerformIO $ do hPutStr stdout (s++"\n") ; hFlush stdout++  {-# NOINLINE trace_ #-}+  trace_ :: String -> a -> a+  trace_ s a = a++  {-# NOINLINE trace' #-}+  trace' :: String -> a -> a+  trace' s a = x `seq` a+   where x = unsafePerformIO $ do hPutStr stdout s ; hFlush stdout++  {-# NOINLINE myTrace #-}+  myTrace :: String -> a -> a+  myTrace s a = x `seq` a+   where x = unsafePerformIO $ do hPutStr stderr (s++"\n") ; hFlush stderr++  {-# NOINLINE myTrace' #-}+  myTrace' :: String -> a -> a+  myTrace' s a = x `seq` a+   where x = unsafePerformIO $ do hPutStr stderr s ; hFlush stderr++  -- These work reasonably well, but sometimes string's+  -- pile up, and then show expr's follow.  spoorNF is+  -- provided for these cases...++  {-# NOINLINE spoor #-}+  spoor :: Show a => String -> a -> a+  spoor string expr = unsafePerformIO $ do+    trayceIO $ string ++ show expr ++ "\n"+    return expr++  {-# NOINLINE spoor' #-}+  spoor' :: Show a => String -> a -> a+  spoor' string expr = unsafePerformIO $ do+    trayceIO $ string ++ show expr+    return expr++  {-# NOINLINE spoorf #-}+  spoorf :: Show b => String -> (a -> b) -> a -> a+  spoorf string f expr = unsafePerformIO $ do+    trayceIO $ string ++ show (f expr) ++ "\n"+    return expr++#if 0+  {-# NOINLINE spoorNF #-}+  spoorNF :: (Show b, NFData b) => String -> (a -> b) -> a -> a+  spoorNF string f expr = unsafePerformIO $ do+    let ss = string ++ show (f expr)+    trayceIO $ force ss+    return expr+#endif++  -- (There is no NOINLINE on this in Common.Trace.  And the+  -- code was templated from the Debug.Trace library.)+  trayceIO :: String -> IO ()+  trayceIO msg = do+    hPutStr stderr msg++-------------------------------------------------------------------------------+