deepseq-bounded 0.6.0.3 → 0.6.1.0
raw patch · 10 files changed
+321/−114 lines, 10 filesdep −cpphsdep ~deepseqdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies removed: cpphs
Dependency ranges changed: deepseq, template-haskell
API changes (from Hackage documentation)
Files
- HTML/transition-5-6-7.html +1/−1
- changelog.txt +14/−0
- deepseq-bounded.cabal +75/−24
- src/Control/DeepSeq/Bounded/Compile_new_grammar.hs +211/−65
- src/Control/DeepSeq/Bounded/NFDataP.hs +2/−0
- src/Control/DeepSeq/Bounded/NFDataP_new_grammar.hs +8/−0
- src/Control/DeepSeq/Bounded/Pattern.hs +2/−18
- src/Control/DeepSeq/Bounded/Pattern_new_grammar.hs +2/−4
- src/Control/DeepSeq/Bounded/Seqable.hs +5/−2
- tests/Blah_new_grammar.hs +1/−0
HTML/transition-5-6-7.html view
@@ -68,7 +68,7 @@ <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.+<li> <span class="red">As of 0.6.1.0, we now have an H98 parser for the new grammar.</span> 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>
changelog.txt view
@@ -9,6 +9,20 @@ http://www.fremissant.net/deepseq-bounded/transition-5-6-7.html (most up to date). +0.6.0.3 -> 0.6.1.0+ - now have an H98 parser for the new grammar, and it's quite+ a bit shorter than the attoparsec+ - I will yank out the attoparsec parser completely in 0.6.2!+ - non-manual USE_CPPHS flag added (also in seqaid and in leaky)+ so that client build system can decide whether cpp is locally available+ or whether they need to install cpphs (and, if they've configured their+ path correctly, to use it)+ - flanking whitespace within type constraints lists is now+ accepted (ignored)+ - whitespace is not preserved beyond the parser; the need would+ have to be demonstrated to support that+ - yet further decrufting of Compile_new_grammar.hs+ 0.6.0.2 -> 0.6.0.3 - realised I should be using Manual: True in all my .cabal flags, or else the constraint solver is free to toggle them!!
deepseq-bounded.cabal view
@@ -2,7 +2,7 @@ ------------------------------------------------------------------------------- name: deepseq-bounded-version: 0.6.0.3+version: 0.6.1.0 synopsis: Bounded deepseq, including support for generic deriving license: BSD3 license-file: LICENSE@@ -12,9 +12,10 @@ bug-reports: http://fremissant.net/deepseq-bounded/trac ---bug-reports: Andrew Seniuk <rasfar@gmail.com> category: Control+--hackage-tags: leak, space, parallel, strictness, forcing, diagnostic, remedial, bsd3, library build-type: Simple stability: provisional-cabal-version: >= 1.16+cabal-version: >= 1.18 -- GHC <= 7.4.2 won't work, unless you're also HASKELL98_FRAGMENT -- (or at least USE_SOP is False).@@ -146,9 +147,9 @@ Manual: True 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. Also, we need an alternative parser for HASKELL98_FRAGMENT, since attoparsec isn't H98...- Default: True---Default: False+ 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. Also, we need an alternative parser for HASKELL98_FRAGMENT, since attoparsec isn't H98... Later: Now that have an H98 parser, not sure there's any reason to /keep/ the atto parser! String patterns are never expected to be long, and parsing string patterns is never expected to be part of a tight loop; and furthermore, NFDataP is the most feature-rich, but least performance-oriented, of the forcing facilities of deepseq-bounded.+--Default: True+ Default: False Manual: True -- Flag DEPTH_USES_INT64@@ -229,11 +230,21 @@ --Default: False Manual: True +-- This does indeed work for me (it is auto-toggled when cpphs is unavailable).+-- Default to False, since it seems more likely there's a native cpp, than+-- that a cpphs installation works smoothly.+Flag USE_CPPHS+ Description: Non-manual flag to allow the build system to try cpphs first, and if that fails, then to try system-wide cpp (typically GNU). I've actually toggled the default, so the build system will try for a system-wide cpp first, and failing that, will try to use cpphs, installing it if necessary. I prefer cpp. I am not getting my most invaluable -Wundef option with cpphs using -optP-Wundef -optP--cpp in my ghc-options. Does cpphs implement it? Not sure...+ Default: False+--Default: True+ Manual: False+ ------------------------------------------------------------------------------- library { - build-tools: cpphs+ if flag(USE_CPPHS)+ build-tools: cpphs hs-source-dirs: src @@ -302,7 +313,11 @@ Control.DeepSeq.Bounded.Generic.GNFDataP_old_grammar ghc-options: -optP-Wundef -fno-warn-overlapping-patterns- ghc-options: -pgmPcpphs -optP--cpp++ if flag(USE_CPPHS)+ ghc-options: -pgmPcpphs -optP--cpp+--else+-- ghc-options: -cpp --ghc-options: -pgmP/usr/bin/cpp --ghc-options: -Wall -fenable-rewrite-rules -ddump-rules -ddump-simpl-stats -ddump-rule-firings@@ -317,10 +332,7 @@ 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,@@ -330,6 +342,13 @@ -- Causes cabal configure to hang, again (was happening with cpphs dep before)! --- , mtl +---- We don't really depend on the cpphs /library/, but installing+---- the library also installs the cpphs executable, so in case+---- build-tools doesn't nab it, this ought to!+--if flag(USE_CPPHS)+-- build-depends:+-- cpphs >= 1.14+ if ! flag(HASKELL98_FRAGMENT) build-depends: syb < 0.5@@ -480,15 +499,25 @@ 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++ -- Not H98 because uses Control.Concurrent which is GHC-specific.+ -- (I'm not sure if Control.Exception is H98 or not, but it uses that too.)+ if ! flag(HASKELL98_FRAGMENT)+ if flag(USE_PING_PATNODE)+ cpp-options: -DUSE_PING_PATNODE=1+ else+ cpp-options: -DUSE_PING_PATNODE=0 else cpp-options: -DUSE_PING_PATNODE=0- if flag(USE_DIE_PATNODE)- cpp-options: -DUSE_DIE_PATNODE=1++ if ! flag(HASKELL98_FRAGMENT)+ if flag(USE_DIE_PATNODE)+ cpp-options: -DUSE_DIE_PATNODE=1+ else+ cpp-options: -DUSE_DIE_PATNODE=0 else cpp-options: -DUSE_DIE_PATNODE=0+ if flag(USE_TIMING_PATNODE) cpp-options: -DUSE_TIMING_PATNODE=1 else@@ -531,7 +560,8 @@ test-suite deepseq-bounded-tests { - build-tools: cpphs+ if flag(USE_CPPHS)+ build-tools: cpphs if flag(HASKELL98_FRAGMENT) default-language: Haskell98@@ -560,8 +590,13 @@ other-modules: Blah_old_grammar ghc-options: -optP-Wundef -fno-warn-overlapping-patterns- ghc-options: -pgmPcpphs -optP--cpp + if flag(USE_CPPHS)+ ghc-options: -pgmPcpphs -optP --cpp+-- ghc-options: -pgmPcpphs -optP--cpp+--else+-- ghc-options: -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@@ -570,15 +605,20 @@ build-depends: base == 4.* - , cpphs >= 1.14- , deepseq-bounded , HUnit == 1.2.* , random == 1.1 - , template-haskell >= 2.8 && <= 3+ , template-haskell >= 2.8 && < 3 +---- We don't really depend on the cpphs /library/, but installing+---- the library also installs the cpphs executable, so in case+---- build-tools doesn't nab it, this ought to!+--if flag(USE_CPPHS)+-- build-depends:+-- cpphs >= 1.14+ if ! flag(HASKELL98_FRAGMENT) build-depends: ghc-prim@@ -703,14 +743,25 @@ cpp-options: -DUSE_TRACE_PATNODE=1 else cpp-options: -DUSE_TRACE_PATNODE=0- if flag(USE_PING_PATNODE)- cpp-options: -DUSE_PING_PATNODE=1++ -- Not H98 because uses Control.Concurrent which is GHC-specific.+ -- (I'm not sure if Control.Exception is H98 or not, but it uses that too.)+ if ! flag(HASKELL98_FRAGMENT)+ if flag(USE_PING_PATNODE)+ cpp-options: -DUSE_PING_PATNODE=1+ else+ cpp-options: -DUSE_PING_PATNODE=0 else cpp-options: -DUSE_PING_PATNODE=0- if flag(USE_DIE_PATNODE)- cpp-options: -DUSE_DIE_PATNODE=1++ if ! flag(HASKELL98_FRAGMENT)+ if flag(USE_DIE_PATNODE)+ cpp-options: -DUSE_DIE_PATNODE=1+ else+ cpp-options: -DUSE_DIE_PATNODE=0 else cpp-options: -DUSE_DIE_PATNODE=0+ if flag(USE_TIMING_PATNODE) cpp-options: -DUSE_TIMING_PATNODE=1 else
src/Control/DeepSeq/Bounded/Compile_new_grammar.hs view
@@ -9,8 +9,6 @@ #error Please set at most one of the flags ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 and ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 to True. #endif -#define ALLOW_ESCAPED_TYPE_LIST_SEPARATOR 1- ------------------------------------------------------------------------------- #if USE_ATTOPARSEC@@ -34,16 +32,11 @@ ------------------------------------------------------------------------------- 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...+#error Sorry, HASKELL98_FRAGMENT incompatible with USE_ATTOPARSEC. #endif compileUsingAttoparsec , -- parsePat ,@@ -52,14 +45,12 @@ #endif )--#endif- where ------------------------------------------------------------------------------- import Control.DeepSeq.Bounded.Pattern+ import Control.DeepSeq.Bounded.Compile_shared_utils import Data.Maybe ( isNothing, fromJust )@@ -84,6 +75,15 @@ import Control.Monad ( mzero ) import Data.Monoid ( mempty ) +#else++ import Control.DeepSeq.Bounded.PatUtil ( liftPats )+ import Data.Char ( isSpace )+ import Data.Char ( isLower )+ import Data.List ( sort )+ import Data.Char ( ord )+ import Data.Maybe ( isJust )+ #endif -------------------------------------------------------------------------------@@ -270,13 +270,8 @@ 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)@@ -294,7 +289,6 @@ (parsePat4 '*' Nothing as) ) ) #endif #else- !_ <- mytrace ("parsePat3: unexpected digit " ++ [b]) $ return () fail $ "parsePat3: unexpected digit " ++ [b] ) ) #endif #else@@ -311,14 +305,12 @@ 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@@ -326,23 +318,18 @@ 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@@ -354,7 +341,6 @@ 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 as else parsePat4_w b mdepth as@@ -364,7 +350,6 @@ 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 ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 '0' -> return (Node (WI as) [])@@ -396,16 +381,13 @@ 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 #if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS '{' -> do #else '(' -> do #endif- !_ <- mytrace "parsePat4_t: entering TR_tail..." $ return () parsePat_WRTR_tail True 'x' as_t---- !_ <- mytrace "parsePat4_t: exited TR_tail!" $ return () #if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 '0' -> return (Node (TI as_t) []) #else@@ -416,7 +398,7 @@ else return (Node (TN as_t_n) []) #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+#elif ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 _ -> fail $ "compilePat: expected '.' or '*' or digit (got " ++ show b ++ ")" #else _ -> fail $ "compilePat: expected '.' or '*' (got " ++ show b ++ ")"@@ -430,20 +412,13 @@ parsePat_WRTR_tail isTR x as = do !_ <- mytrace "parsePat_WRTR_tail." $ return ()- !_ <- mytrace ("**HWRTR1**: isTR="++show isTR++" x="++show x) $ return ()-#if 0- roi <- AT.takeText- error $ "DEVEXIT: " ++ show roi-#endif- !_ <- mytrace ("**HWRTR1.5**: "++show x) $ return ()+-- AT.takeText >>= \ roi -> error $ "DEVEXIT: " ++ show roi pats <- parsePats <|> pure []- !_ <- mytrace ("**HWRTR2**: "++show x) $ return () #if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS AT.char '}' #else AT.char ')' #endif- !_ <- mytrace ("**HWRTR3**: "++show x) $ return () if isTR then return (Node (TR as) pats) else return (Node (WR as) pats)@@ -452,55 +427,35 @@ parse_type_constraints :: AT.Parser [T.Text] parse_type_constraints = do---- AT.take 3 >>= \ test -> error $ "test="++show test- !_ <- mytrace "parse_type_constraints." $ return ()- let endchar = ':' let sepchar = ';'-- -- (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. 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 (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"+ return [seg] )+ <|> (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 ()- let eblocks = AT.parseOnly ( AT.sepBy1'- (AT.takeWhile (/=';'))- (AT.char ';')+ (AT.takeWhile (/=sepchar))+ (AT.char sepchar) ) seg- !_ <- mytrace ("eblocks="++show eblocks) $ return () let blocks = case eblocks of- Left msg -> error $ "parse_type_constraints: eblocks parse failure: " ++ msg- Right blocks -> blocks- !_ <- mytrace ("blocks="++show blocks) $ return ()+ Left msg -> fail $ "parse_type_constraints: eblocks parse failure: " ++ msg+ Right blocks -> map T.strip blocks return blocks {-# INLINE parse_type_constraints #-} @@ -528,9 +483,199 @@ #else +#if 1++ -- This was such a pleasure to write after the attoparsec+ -- learning curve above!!... I wonder if the atto parser+ -- could ever be made to be as concise as this?+ compilePat' :: String -> Pattern+ compilePat' s+ | not $ null s' = error $ "\ncompilePat: input rejected: "+ ++ s+ ++ if isNothing mmsg then "" else "\nParser message: "+ ++ fromJust mmsg+ ++ "\nPatterns parsed so far: ["+ ++ intercalate ", " (map show pats)+ ++ "]"+ | otherwise = case pats of+ [] -> error $ "\ncompilePat: "+ ++ if null s then "empty input" else "vacuous input"+ [pat] -> setPatternPatNodeUniqueIDs 0 pat+ pats -> setPatternPatNodeUniqueIDs 0 $ liftPats pats+ where (pats, mmsg, s') = compilePats s []++ -- String in last component of result is unconsumed input.++ compilePats :: String -> [Pattern] -> ([Pattern], Maybe String, String)+ compilePats s acc+ | null s_ltrim = (reverse acc, Nothing, s_ltrim)+ | otherwise = case cpat s of+ (Left "", s') -> (reverse acc, Nothing, s')+-- (Left "", s') -> compilePats s' acc+ (Left msg, s') -> (reverse acc, Just msg, s')+ (Right pat, s') -> compilePats s' (pat:acc)+ where s_ltrim = dropWhile isSpace s+ #if 0- compilePat' s = ...+ -- nice one from http://stackoverflow.com/a/6270337+ trim :: String -> String+ trim = let f = reverse . dropWhile isSpace in f . f+#endif++-- XXX Don't forget to do a post-pass to change W* nodes+-- to corresponding T* nodes, when : modifier was present!++ cpat :: String -> (Either String Pattern, String)+--cpat _ | trace "J-1: " $ False = undefined+ cpat [] = (Left "unexpected end of input", [])+--cpat s | trace ("J-2: "++show s) $ False = undefined+ cpat s+ | null s'' = error "\ncompilePat: type constraint must precede a pattern node"+ | isW = case c of+ '.' -> (Right $ Node (WI as) [], cs)+ '!' -> (Right $ Node (WS as) [], cs)+ '*' -> case parseInt cs [] of+ (Nothing, cs'') -> (Right $ Node (WW as ) [], cs'')+ (Just is, cs'') -> (Right $ Node (WN $ asn is) [], cs'')+ '(' -> if isNothing mmsg_subpats+ then (Right $ Node (WR as) subpats, cs_subpats)+ else (Left $ fromJust mmsg_subpats, cs_subpats)+ ')' -> (Left "", cs)+ c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"+ | otherwise = case c of+ '.' -> (Right $ Node (TI as) [], cs)+-- '!' -> (Right $ Node (TS as) [], cs)+ '*' -> case parseInt cs [] of+ (Nothing, cs'') -> (Right $ Node (TW as ) [], cs'')+ (Just is, cs'') -> (Right $ Node (TN $ asn is) [], cs'')+ '(' -> if isNothing mmsg_subpats+ then (Right $ Node (TR as) subpats, cs_subpats)+ else (Left $ fromJust mmsg_subpats, cs_subpats)+ ')' -> (Left "", cs)+ c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"+ where+ s' = dropWhile isSpace s+ (c:cs) = s''+ (as_mods, mmsg_mods, s'') = cmods s' -- collect any prefix modifiers+ as = case mmsg_mods of+ Nothing -> as_mods+ Just msg -> error $ "\ncompilePat: " ++ msg+ asn is = as { depth = read is :: Int }+ isW = not $ doConstrainType as+ (subpats, mmsg_subpats, cs_subpats) = compilePats cs []++ -- Accumulate any prefix modifiers into an empty PatNodeAttrs structure.+ cmods :: String -> (PatNodeAttrs, Maybe String, String)+ cmods s = cmods' s emptyPatNodeAttrs+ cmods' :: String -> PatNodeAttrs -> (PatNodeAttrs, Maybe String, String)+ cmods' [] as = (as, Nothing, [])+--cmods' [] as = (as, Just "cmods': unexpected end of input", [])+ cmods' s as = case c of+ ':' -> cmods' cs_types as_types+ '@' -> cmods' cs_delay as_delay+#if USE_PAR_PATNODE+ '=' -> cmods' cs_par as_par+#endif+#if USE_PSEQ_PATNODE+ '>' -> cmods' cs_pseq as_pseq+#endif+#if USE_TRACE_PATNODE+ '+' -> cmods' cs_trace as_trace+#endif+#if USE_PING_PATNODE+ '^' -> cmods' cs_ping as_ping+#endif+#if USE_DIE_PATNODE+ '/' -> cmods' cs_die as_die+#endif+#if USE_TIMING_PATNODE+ '%' -> cmods' cs_timing as_timing+#endif+ _ -> (as, Nothing, s)+ where+ s'@(c:cs) = dropWhile isSpace s+ ( cs_types , as_types ) = parse_type_constraints cs as+ ( cs_delay , as_delay ) = parse_delay cs as+#if USE_PAR_PATNODE+ ( cs_par , as_par ) = ( cs, as { doSpark = True } )+#endif+#if USE_PSEQ_PATNODE+ ( cs_pseq , as_pseq ) = parse_pseq cs as+#endif+#if USE_TRACE_PATNODE+ ( cs_trace , as_trace ) = ( cs, as { doTrace = True } )+#endif+#if USE_PING_PATNODE+ ( cs_ping , as_ping ) = ( cs, as { doPing = True } )+#endif+#if USE_DIE_PATNODE+ ( cs_die , as_die ) = ( cs, as { doDie = True } )+#endif+#if USE_TIMING_PATNODE+ ( cs_timing , as_timing ) = ( cs, as { doTiming = True } )+#endif++ parse_type_constraints :: String -> PatNodeAttrs -> (String, PatNodeAttrs)+ parse_type_constraints s'' as+--- | doConstrainType as = trace "\nwarning: type constraints (:...:) mod given multiple times to a single node, so aggregating type lists." $ (s', as')+ | otherwise = (s', as')+ where+ s = dropWhile isSpace s''+ as' = as { doConstrainType = True+ , typeConstraints = typeConstraints as ++ tys }+ (tys, s') = f s "" []+ -- Take up to the next ';', ':', or '\\' and deal.+ f :: String -> String -> [String] -> ([String],String)+ f s'' tyacc tysacc+ | null s' = error "\ncompilePat: type constraint list not ':'-terminated"+ | '\\' == c = if null cs+ then f cs (c:tyacc) tysacc+ else if ':' == head cs -- note ty is already reversed+ then f (tail cs) ((':':'\\':ty) ++ tyacc) tysacc+ else f cs (('\\':ty) ++ tyacc) tysacc+ | ':' == c = ( reverse $ (reverse $ tyacc ++ ty) : tysacc , dropWhile isSpace cs )+ -- otherwise ';' == c+ | otherwise = f cs "" $ (reverse $ tyacc ++ ty) : tysacc+ where+ s = dropWhile isSpace s''+ (c:cs) = s'+ (ty',s') = span (\c->c/=';'&&c/=':'&&c/='\\') s+ ty = dropWhile isSpace $ reverse ty' -- yeah yeah++ parse_delay :: String -> PatNodeAttrs -> (String, PatNodeAttrs)+ parse_delay [] as = error "\nparse_delay: unexpected end of input"+ parse_delay s'' as+--- | doDelay as = error "\ncompilePat: delay (@) modifier given multiple times to a single node"+--- | doDelay as = trace "\nwarning: delay (@) mod given multiple times to a single node, so summing." $ (s', as')+ | isNothing mis = error $ "\nparse_delay: expected a digit 1-9 (not '" ++ [head s] ++ "')"+ | otherwise = (s', as')+ where+ s = dropWhile isSpace s''+ as' = as { doDelay = True -- (convenient to set both here)+ , delayus = delayus as + i }+ (mis, s') = parseInt s []+ is = fromJust mis+ i = read is :: Int++#if USE_PSEQ_PATNODE+ parse_pseq :: String -> PatNodeAttrs -> (String, PatNodeAttrs)+ parse_pseq s'' as+ | doPseq as = error "\ncompilePat: pseq (>) modifier given multiple times to a single node"+ | not ok = error "\ncompilePat: pseq permutation must cover an initial segment of abc..yz"+-- No harm in allowing it; as for testing arity mismatch, that is not+-- in the parser's purview (at least at this time). It is easily done+-- as a post-parsing check.+--- | null perm = error "\ncompilePat: empty pseq permutation"+ | otherwise = (s', as')+ where+ s = dropWhile isSpace s''+ as' = as { doPseq = True -- (convenient to set both here)+ , pseqPerm = Just $ map (\c -> ord c - ord 'a') perm }+ (perm, s') = span isLower s+ ok = sort perm == take (length perm) ['a'..'z']+#endif+ #else err = intercalate "\n" [ "\n"@@ -540,6 +685,7 @@ , "to work with the PatNode constructors directly. The situation should" , "be remedied by version 0.6.1." ]+ compilePat' :: String -> Pattern compilePat' _ = error err #endif
src/Control/DeepSeq/Bounded/NFDataP.hs view
@@ -182,7 +182,9 @@ -- * A custom exception, raised by choice 'PatNode's, that can be caught in the caller +#if USE_PING_PATNODE , DeepSeqBounded_PingException(..)+#endif -- * Related modules re-exported
src/Control/DeepSeq/Bounded/NFDataP_new_grammar.hs view
@@ -1372,21 +1372,29 @@ p2 <- if doTrace as then trc p1 b msg_trc else return p1+#else+ let p2 = p1 #endif #if USE_PING_PATNODE p3 <- if doPing as then png p2 b msg_png else return p2+#else+ let p3 = p2 #endif #if USE_DIE_PATNODE p4 <- if doDie as then die p3 b msg_die else return p3+#else+ let p4 = p3 #endif #if USE_TIMING_PATNODE p5 <- if doTiming as then timing p4 b msg_timing else return p4+#else+ let p5 = p4 #endif return $! Node p5 [] | otherwise = Node p [] -- don't forget!
src/Control/DeepSeq/Bounded/Pattern.hs view
@@ -37,23 +37,6 @@ -- * 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 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 -- | __Grammar__ -- -- @@@ -162,7 +145,6 @@ -- I'm still not sure if I try accepting a double-colon close here? -- (Checking...) -- /|/ /(/ __.__ /|/ __*__ /[/ /decimalint/ /]/ /)/ __::__ /typename/ /{/ __;__ /typename/ /}/ __:__ /[/ __:__ /]/-#endif #if 0 -- These are now in Compile (but may move them back once sort out some stuff)@@ -176,7 +158,9 @@ -- , emptySparkPatNodeAttrs , getPatNodeAttrs , setPatNodeAttrs+#if USE_PING_PATNODE , setPatNodePingParentTID+#endif , showPerm , showPatRaw , showPatNodeRaw
src/Control/DeepSeq/Bounded/Pattern_new_grammar.hs view
@@ -432,10 +432,12 @@ #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 = ""@@ -698,11 +700,7 @@ #endif s2 = "" s2' = " " ++ show (depth as)-#if TYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR- s2'' = " (" ++ intercalate " " (typeConstraints as) ++ ")"-#else s2'' = " (" ++ intercalate ";" (typeConstraints as) ++ ")"-#endif s2''' = s2' ++ s2'' #if 0 doubleBackslashes :: String -> String
src/Control/DeepSeq/Bounded/Seqable.hs view
@@ -53,8 +53,11 @@ -- This can be controlled dynamically (see <seqaid> project); -- and ideally it would be part of the RTS... ----- Another bonus is, all of Seqable.hs and GSeqable.hs [?]--- are in the HASKELL98_FRAGMENT.+-- Another bonus is, all of Seqable.hs and GSeqable.hs+-- are in the HASKELL98_FRAGMENT. [Later: I don't understand+-- what I'm getting at. Seqable.hs is H98, but only with+-- JUST_ALIAS_GSEQABLE set to False (which is not the default+-- at present)... -------------------------------------------------------------------------------
tests/Blah_new_grammar.hs view
@@ -296,6 +296,7 @@ putStrLn $ shp "+^=()" putStrLn $ shp "=+^:[Int]:*23" #endif+ putStrLn $ shp " ! :G; How:. : A ()$)%&()(*&)*(_)+\"}>>=?}{\\:|B ; C ; D E F : ( . . ) " putStrLn "" #endif