deepseq-bounded 0.6.0.1 → 0.6.0.2
raw patch · 7 files changed
+286/−308 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- changelog.txt +11/−0
- deepseq-bounded.cabal +6/−16
- src/Control/DeepSeq/Bounded/Compile_new_grammar.hs +83/−233
- src/Control/DeepSeq/Bounded/Compile_shared_utils2.hs +6/−9
- src/Control/DeepSeq/Bounded/NFDataP_new_grammar.hs +34/−15
- src/Control/DeepSeq/Bounded/PatUtil_new_grammar.hs +3/−3
- src/Control/DeepSeq/Bounded/Pattern_new_grammar.hs +143/−32
changelog.txt view
@@ -9,6 +9,17 @@ http://www.fremissant.net/deepseq-bounded/transition-5-6-7.html (most up to date). +0.6.0.1 -> 0.6.0.2+ - VACANT_HASH flag removed (permanent value = False)+ - further decrufting of Compile_new_grammar.hs+ - HASKELL98_FRAGMENT tested a bit more (compiles at least,+ and the tests run, but there's still no H98 parser...)+ - manual NFData instance of Pattern (instead of generic deriving)+ so can use it to force non-interleaving of output with warnings,+ even in H98 (and has other uses when debugging)+ - a bit of sanitising of .cabal flag descriptions, and of NFDataP.handleAttrs+ - a few incidental bug fixes; and a few recognised but not yet fixed...+ 0.6.0.0 -> 0.6.0.1 - bugfixes so can build with NEW_IMPROVED_PATTERN_GRAMMAR set False - got rid of three transient flags, which are now "permanently defaulted"
deepseq-bounded.cabal view
@@ -2,7 +2,7 @@ ------------------------------------------------------------------------------- name: deepseq-bounded-version: 0.6.0.1+version: 0.6.0.2 synopsis: Bounded deepseq, including support for generic deriving license: BSD3 license-file: LICENSE@@ -94,27 +94,27 @@ --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.+ Description: Use Control.Parallel.pseq to order the evaluation of recursive submatching. This is done by providing a permutation argument; refer to the Control.DeepSeq.Bounded.Pattern.PatNode API for additional documentation. Configurable per PatNode. Default: True --Default: False Flag USE_TRACE_PATNODE- Description: On match, log a traceline to stderr en passant.+ Description: Log a traceline to stderr en passant. Configurable per PatNode. Fires when node is pattern-matched, whether or not the match succeeds. 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.+ Description: Raise an asynchronous exception en passant. This can be useful for gauging term shape relative to pattern shape, dynamically. Configurable per PatNode. Fires when node is pattern-matched, whether or not the match succeeds. 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.+ Description: 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. Configurable per PatNode. Fires when node is pattern-matched, whether or not the match succeeds. 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.+ Description: 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. Configurable per PatNode. Fires when node is pattern-matched, whether or not the match succeeds. Default: True --Default: False @@ -178,11 +178,6 @@ ---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- 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@@ -346,11 +341,6 @@ 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
src/Control/DeepSeq/Bounded/Compile_new_grammar.hs view
@@ -63,8 +63,9 @@ import Control.DeepSeq.Bounded.Compile_shared_utils import Data.Maybe ( isNothing, fromJust )- import Data.Maybe ( isJust ) + import Data.List ( intercalate )+ import Debug.Trace ( trace ) #if USE_ATTOPARSEC@@ -135,22 +136,27 @@ ------------------------------------------------------------------------------- - -- Deal with all prefix PatNode attributes (PatNodeAttrs).- -- All attributes are now prefix, unless you count the depth- -- number of WN/TN nodes as an attribute. (It is stored- -- in PatNodeAttrs, but it is not really an attribute- -- in the modifier sense -- it is /applicable/ only for- -- the WN and TN node types; and it is /mandatory/ for- -- those types!+ -- Test if next character is non-attribute, up front,+ -- and skip all this attribute stuff in that case!...+ parsePat :: PatNodeAttrs -> AT.Parser Pattern+ parsePat as = do+ !_ <- mytrace "parsePat." $ return ()+ let modchars = ":@=>+^/%"+ mc <- AT.peekChar+ let c = fromJust mc+ if isNothing mc+ then fail "parse_type_constraints: unexpected end-of-input"+ else if c `elem` modchars+ then parsePatAttributes as+ else parsePat3 as+ -- Note: Previously, type constraint was handled in a more -- ad hoc manner. The existence of separate T* nodes is -- evidence of this, but those will likely be removed in 0.7, -- making type constraint just another attribute of W* nodes.- 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 ()+ parsePatAttributes :: PatNodeAttrs -> AT.Parser Pattern+ parsePatAttributes as = do+ !_ <- mytrace "parsePatAttributes." $ return () foldr (<|>) mempty $ -- foldM (<|>) mempty $ -- fold (<|>) mempty $@@ -193,8 +199,7 @@ dud_parser _ _ _ _ = fail "dud_parser" -- (is never run; should use Proxy) no_arg_parser c b a s = do ( (AT.char c) <* AT.skipSpace )- >> (- if b as+ >> (if b as then fail $ "compilePat: duplicate " ++ show c ++ " (" ++ s ++ ") " ++ "node attribute"@@ -228,11 +233,10 @@ 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 }- in parsePat as' )+ >> ( ( parse_type_constraints <* AT.skipSpace )+ >>= \ tcs -> let as' = as { doConstrainType = True+ , typeConstraints = map T.unpack tcs }+ in parsePat as' ) -- Parse the "@50000" delayus attribute, if present. parsePat1' :: PatNodeAttrs -> AT.Parser Pattern@@ -352,7 +356,7 @@ !_ <- mytrace "parsePat4." $ return () !_ <- mytrace ("GOO-1: "++show b++" "++show (doConstrainType as)) $ return () if doConstrainType as- then parsePat4_t b mdepth 0 as+ then parsePat4_t b mdepth as else parsePat4_w b mdepth as -- Actual handler, in case it was /NOT/ a type-constrained node;@@ -362,16 +366,11 @@ !_ <- 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 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-#endif #if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 '1' -> return (Node (WS as) []) #else@@ -381,21 +380,21 @@ 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+ '{' -> parsePat_WRTR_tail False b as #else- '(' -> parsePat_WR_tail b as+ '(' -> parsePat_WRTR_tail False b as #endif #if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS- _ -> fail $ "compilePat: expected one of \"#.*{\" (got " ++ show b ++ ")"+ _ -> fail $ "compilePat: expected one of \".!*{\" (got " ++ show b ++ ")" #else- _ -> fail $ "compilePat: expected one of \"#.*(\" (got " ++ show b ++ ")"+ _ -> 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+ parsePat4_t :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern+ parsePat4_t b mdepth as_t = do !_ <- mytrace "parsePat4_t." $ return () !_ <- mytrace ("parsePat4_t: b="++show b) $ return () case b of@@ -405,18 +404,13 @@ '(' -> do #endif !_ <- mytrace "parsePat4_t: entering TR_tail..." $ return ()- parsePat_TR_tail 'x' as_t+ parsePat_WRTR_tail True '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 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-#endif '*' -> if isNothing mdepth then return (Node (TW as_t) []) else return (Node (TN as_t_n) [])@@ -432,78 +426,32 @@ ------------------------------------------------------------------------------- - -- 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 USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS- AT.skipSpace *> AT.char '{'-#else- AT.skipSpace *> AT.char '('-#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)-- parsePat_TR_tail :: Char -> PatNodeAttrs -> AT.Parser Pattern- parsePat_TR_tail x as_t+ parsePat_WRTR_tail :: Bool -> Char -> PatNodeAttrs -> AT.Parser Pattern+ parsePat_WRTR_tail isTR x as = do- !_ <- mytrace "parsePat_TR_tail." $ return ()- !_ <- mytrace ("**HTR1**: "++show x) $ return ()+ !_ <- mytrace "parsePat_WRTR_tail." $ return ()+ !_ <- mytrace ("**HWRTR1**: isTR="++show isTR++" x="++show x) $ return () #if 0 roi <- AT.takeText error $ "DEVEXIT: " ++ show roi #endif-#if 0-#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS- AT.skipSpace *> AT.char '{'-#else- AT.skipSpace *> AT.char '('-#endif-#endif- !_ <- mytrace ("**HTR1.5**: "++show x) $ return ()+ !_ <- mytrace ("**HWRTR1.5**: "++show x) $ return () pats <- parsePats <|> pure []- !_ <- mytrace ("**HTR2**: "++show x) $ return ()+ !_ <- mytrace ("**HWRTR2**: "++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)+ !_ <- mytrace ("**HWRTR3**: "++show x) $ return ()+ if isTR+ then return (Node (TR as) pats)+ else return (Node (WR as) 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+ parse_type_constraints :: AT.Parser [T.Text]+ parse_type_constraints = do -- AT.take 3 >>= \ test -> error $ "test="++show test @@ -512,16 +460,9 @@ let endchar = ':' let sepchar = ';' - ncs <- if isTR- then pure 0- else AT.string "::" *> pure 2- -- (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 ()@@ -530,125 +471,37 @@ !_ <- 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+ (do+ !_ <- mytrace "loop: <appending backslash>" $ return ()+ AT.char '\\' *> AT.anyChar+ >>= \ c -> ( ( seg `T.snoc` '\\' `T.snoc` c ) : ) <$> loop+ )+ <|> (do+ !_ <- mytrace ("loop: [seg]="++show [seg]) $ return ()+ AT.char endchar+ return [seg] -- we know it was endchar+ )+ <|> (do+ !_ <- mytrace "\"parse_type_constraints: unexpected end of input\"" $ return ()+ fail "parse_type_constraints: unexpected end of input"+ ) segs <- loop !_ <- mytrace ("segs="++show segs) $ return () let seg = T.concat segs !_ <- mytrace ("seg="++T.unpack seg) $ return () - -- (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))-- !_ <- mytrace ("HERE!") $ return ()-- let eblocksncs =--- 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+ let eblocks = AT.parseOnly+ ( AT.sepBy1'+ (AT.takeWhile (/=';'))+ (AT.char ';')+ )+ seg+ !_ <- mytrace ("eblocks="++show eblocks) $ return ()+ let blocks = case eblocks 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)- 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.null, T.length, T.last, and T.init are all O(1).- | T.length t1 > 1 && 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+ Right blocks -> blocks+ !_ <- mytrace ("blocks="++show blocks) $ return ()+ return blocks {-# INLINE parse_type_constraints #-} -------------------------------------------------------------------------------@@ -659,30 +512,15 @@ -- 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 :: T.Text -> AT.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 @@ -691,7 +529,19 @@ #else 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."+#if 0+ compilePat' s = ...+#else+ err = intercalate "\n"+ [ "\n"+ , "Sorry, at this time (version 0.6.0.*) there is no non-attoparsec parser"+ , "for the new pattern grammar. This also implies that HASKELL98_FRAGMENT"+ , "has no pattern DSL facilities (except for showPat), and it is necessary"+ , "to work with the PatNode constructors directly. The situation should"+ , "be remedied by version 0.6.1."+ ]+ compilePat' _ = error err+#endif #endif
@@ -76,6 +76,8 @@ import Control.DeepSeq.Bounded.PatUtil ( liftPats ) import Control.DeepSeq.Bounded.Compile_shared_utils ( parseInt ) +#if 0+ #if DO_DERIVE_DATA_AND_TYPEABLE import Data.Data ( Data ) import Data.Typeable ( Typeable )@@ -87,17 +89,20 @@ import Control.DeepSeq ( NFData ) #endif +#endif import Data.List ( intercalate )+#if 0 import Data.Char ( isDigit ) import Data.Maybe ( isNothing, fromJust ) import Data.Maybe ( isJust ) +#endif import Debug.Trace ( trace )-#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 0 #if NFDATA_INSTANCE_PATTERN -- for helping trace debugging import qualified Control.DeepSeq.Generics as DSG@@ -317,15 +322,11 @@ ++ let as' = as { doConstrainType = False } in showPat (Node (setPatNodeAttrs pas as') chs) -#if VACANT_HASH- | WI{} <- pas = " " ++ descend chs-#else #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-#endif | WR{} <- pas = "" ++ descend chs ++ perhapsEmptySubpatterns #if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 | WS{} <- pas = "1" ++ descend chs@@ -341,14 +342,10 @@ | WW{} <- pas = "*" ++ descend chs #endif -#if VACANT_HASH- | TI{} <- pas = " " ++ descend chs-#else #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 #endif | TR{} <- pas = "" ++ descend chs ++ perhapsEmptySubpatterns --- #if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
src/Control/DeepSeq/Bounded/NFDataP_new_grammar.hs view
@@ -119,6 +119,8 @@ import Control.Concurrent ( forkIO ) #endif + import Control.Concurrent ( threadDelay )+ import Data.Int import Data.Word import Data.Ratio@@ -438,7 +440,7 @@ #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 == (trace "FOO!!" (Node XX [])) = undefined -- FOO!! /is/ printed, though only once (like Boo) -- rnfp p x | trace "Boo!" () `seq` p == Node XX [] = undefined -- NOT works (printed once only) -- rnfp p x | (trace "Boo!" p) == Node XX [] = undefined -- WORKS!!! (printed every time) -- rnfp p x | trace "Boo!" () `seq` p == Node TN{} [] = undefined@@ -1322,6 +1324,7 @@ -- So, which of the PatNodeAttrs product type can be dealt with here? -- NOT doSpark - dealt with downstream in rnfp' -- NOT doPseq - about to be dealt with downstream (hopefully rnfp')...+ -- doDelay -- doTrace -- doPing -- doDie@@ -1330,7 +1333,7 @@ -- XXX Returning Pattern instead of Bool, in a continued attempt -- to outsmart GHC and get certain things to be evaluated... - {-# NOINLINE handleAttrs #-}+ {- NOINLINE handleAttrs #-} #if 0 -- XXX XXX XXX testing only!!!! XXX XXX XXX handleAttrs pat@(Node p _) x = pat@@ -1362,27 +1365,30 @@ --- | 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+ p1 <- if doDelay as+ then dly p0 b else return p0+#if USE_TRACE_PATNODE+ p2 <- if doTrace as+ then trc p1 b msg_trc+ else return p1 #endif #if USE_PING_PATNODE- p2 <- if doPing as- then png p1 b msg_png- else return p1+ p3 <- if doPing as+ then png p2 b msg_png+ else return p2 #endif #if USE_DIE_PATNODE- p3 <- if doDie as- then die p2 b msg_die- else return p2+ p4 <- if doDie as+ then die p3 b msg_die+ else return p3 #endif #if USE_TIMING_PATNODE- p4 <- if doTiming as- then timing p3 b msg_timing- else return p3+ p5 <- if doTiming as+ then timing p4 b msg_timing+ else return p4 #endif- return $! Node p3 []+ return $! Node p5 [] | otherwise = Node p [] -- don't forget! --- | otherwise = p -- don't forget! --- | otherwise = True -- don't forget!@@ -1392,6 +1398,19 @@ #else b = unsafePerformIO $ ( randomIO :: IO Bool ) -- WORKS!!! (even though value is constant!) #endif+ {-# NOINLINE dly #-} -- XXX crucial+ dly p b+--- | trace "dly msg!" False = undefined+ | otherwise = do+ if b+ then do+ !_ <- threadDelay $ delayus as+ return p+-- return $ not b+ else do+ !_ <- threadDelay $ delayus as+ return p+-- return ' #if USE_TRACE_PATNODE msg_trc = "NFDataP: TRACE: " ++ show (uniqueID as) #if ! HASKELL98_FRAGMENT
src/Control/DeepSeq/Bounded/PatUtil_new_grammar.hs view
@@ -434,9 +434,9 @@ firstwarnpassed <- readIORef firstWarningPassed modifyIORef' firstWarningPassed (const True) if firstwarnpassed- then return as- else trace (s ++ ": warning: type constraints unsupported (cleared!)")- $! return as+ then return as+ else trace (s ++ ": warning: type constraints unsupported (cleared!)")+ $! return as else as as'' = as' { doConstrainType = False } pas' = setPatNodeAttrs pas as''
src/Control/DeepSeq/Bounded/Pattern_new_grammar.hs view
@@ -59,10 +59,16 @@ #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 #-} -------------------------------------------------------------------------------@@ -106,13 +112,20 @@ 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@@ -134,7 +147,8 @@ ------------------------------------------------------------------------------- data Rose a = Node a [ Rose a ]-#if NFDATA_INSTANCE_PATTERN+-- (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)@@ -154,12 +168,18 @@ #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 ------------------------------------------------------------------------------- @@ -251,7 +271,8 @@ , delta_timestamp :: !Int #endif }-#if NFDATA_INSTANCE_PATTERN+-- (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@@ -271,8 +292,71 @@ #if NFDATA_INSTANCE_PATTERN instance NFData ThreadId where rnf x = ()- instance NFData PatNodeAttrs where rnf = DSG.genericRnf+-- (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@@ -313,32 +397,40 @@ --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+ 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'- | 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+ 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 setPatNodePingParentTID :: ThreadId -> PatNode -> PatNode setPatNodePingParentTID tid pn = pn'@@ -494,7 +586,8 @@ #endif | XX -- ^ Dummy node type reserved for internal use. -#if NFDATA_INSTANCE_PATTERN+-- (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@@ -512,6 +605,28 @@ #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@@ -613,10 +728,6 @@ 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 -------------------------------------------------------------------------------