------------------------------------------------------------------------------- {- 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 -- Prefer to hand-write the NFData instance, so that can -- use it with HASKELL98_FRAGMENT. #if 0 #if NFDATA_INSTANCE_PATTERN -- For testing only (controlling trace interleaving): {-# LANGUAGE DeriveGeneric #-} #endif #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 -- {--} -- (Restore comment from Pattern.hs when shed old grammar support.) ------------------------------------------------------------------------------- module Control.DeepSeq.Bounded.Pattern_new_grammar -- (Restore exports & comments from Pattern.hs when shed old grammar support.) 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 ) #endif -- (Hand write this NFData instance for greater portability.) #if NFDATA_INSTANCE_PATTERN -- for helping trace debugging #if 1 import Control.DeepSeq #else 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 ] -- (Hand write this NFData instance for greater portability.) #if 0 && 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 NFData a => NFData (Rose a) where rnf (Node x chs) = rnf x `seq` rnf chs instance Functor Rose where fmap f (Node x chs) = Node (f x) (map (fmap f) chs) -- (Hand write this NFData instance for greater portability.) #if 0 #if NFDATA_INSTANCE_PATTERN instance NFData a => NFData (Rose a) where rnf = DSG.genericRnf #endif #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/)   Depth of forcing for 'WN' and 'TN' nodes (/n/ is decimal integer depth). , doConstrainType :: !Bool -- ^ (__:__)   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 -- ^ (__@__)   Delay (current thread) for 'delayus' microseconds. /__XXX__ Still buggy?/ , delayus :: !Int -- ^ Microseconds of delay (when 'doDelay' is 'True'). #if USE_PAR_PATNODE , doSpark :: !Bool -- ^ (__=__)   Spark matching for parallel evaluation. #endif #if USE_PSEQ_PATNODE , doPseq :: !Bool -- ^ (__>__/perm/)   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 -- ^ (__+__)   Output a traceline to stderr. #endif #if USE_PING_PATNODE , doPing :: !Bool -- ^ (__^__)   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 -- ^ (__/__)   Kill (just this) thread. #endif #if USE_TIMING_PATNODE , doTiming :: !Bool -- ^ (__%__)   Note time passed since pattern-matched parent node. /__XXX__ Work in progress./ , timestamp :: !Int -- XXX for now , parent_timestamp :: !Int , delta_timestamp :: !Int #endif } -- (Hand write this NFData instance for greater portability.) #if 0 && 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 = () -- (Hand write this NFData instance for greater portability.) --instance NFData PatNodeAttrs where rnf = DSG.genericRnf instance NFData PatNodeAttrs where rnf (PatNodeAttrs uniqueID depth doConstrainType typeConstraints doDelay delayus #if USE_PAR_PATNODE doSpark #endif #if USE_PSEQ_PATNODE doPseq pseqPerm #endif #if USE_TRACE_PATNODE doTrace #endif #if USE_PING_PATNODE doPing pingParentTID #endif #if USE_DIE_PATNODE doDie #endif #if USE_TIMING_PATNODE doTiming timestamp parent_timestamp delta_timestamp #endif ) = uniqueID `seq` rnf depth `seq` rnf doConstrainType `seq` rnf typeConstraints `seq` rnf doDelay `seq` rnf delayus #if USE_PAR_PATNODE `seq` rnf doSpark #endif #if USE_PSEQ_PATNODE `seq` rnf doPseq `seq` rnf pseqPerm #endif #if USE_TRACE_PATNODE `seq` rnf doTrace #endif #if USE_PING_PATNODE `seq` rnf doPing `seq` rnf pingParentTID #endif #if USE_DIE_PATNODE `seq` rnf doDie #endif #if USE_TIMING_PATNODE `seq` rnf doTiming `seq` rnf timestamp `seq` rnf parent_timestamp `seq` rnf delta_timestamp #endif #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 = case pas of WI as -> as WS as -> as WR as -> as WN as -> as #if USE_WW_DEEPSEQ WW as -> as #endif TI as -> as -- TS as -> as TR as -> as TN as -> as #if USE_WW_DEEPSEQ TW as -> as #endif _ -> error $ "getPatNodeAttrs: unexpected PatNode: " ++ show pas setPatNodeAttrs :: PatNode -> PatNodeAttrs -> PatNode setPatNodeAttrs pas as' = case pas of WI _ -> WI as' WS _ -> WS as' WR _ -> WR as' WN _ -> WN as' #if USE_WW_DEEPSEQ WW _ -> WW as' #endif TI _ -> TI as' -- TS _ -> TS as' TR _ -> TR as' TN _ -> TN as' #if USE_WW_DEEPSEQ TW _ -> TW as' #endif _ -> error $ "setPatNodeAttrs: unexpected PatNode: " ++ show pas #if USE_PING_PATNODE setPatNodePingParentTID :: ThreadId -> PatNode -> PatNode setPatNodePingParentTID tid pn = pn' where pn' = let as' = (getPatNodeAttrs pn) { pingParentTID = Just tid } in setPatNodeAttrs pn as' #endif 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/, __.__ )   Don't even unwrap the constructor of this node. | WR !PatNodeAttrs -- ^ (/__R__ecurse/, __(__...__)__ )   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/, __!__ )   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 )   @<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, __*__ )   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. -- (Hand write this NFData instance for greater portability.) #if 0 && 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 #if NFDATA_INSTANCE_PATTERN -- (Hand write this NFData instance for greater portability.) --instance NFData PatNode where rnf = DSG.genericRnf instance NFData PatNode where rnf pas = rnf as where as = getPatNodeAttrs pas #if 0 rnf WI = True ; isWI _ = False rnf WR = True ; isWR _ = False rnf WS = True ; isWS _ = False rnf WN = True ; isWN _ = False #if USE_WW_DEEPSEQ rnf WW = True ; isWW _ = False #endif rnf TI = True ; isTI _ = False rnf TR = True ; isTR _ = False rnf TN as = True ; isTN _ = False #if USE_WW_DEEPSEQ rnf TW as = True ; isTW _ = False #endif #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) s2'' = " (" ++ intercalate ";" (typeConstraints as) ++ ")" 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 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 -------------------------------------------------------------------------------