From 450f27449005d47adcf44a79a29ec45d1691028f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 18 Feb 2020 15:21:47 -0500 Subject: [PATCH] Ensure that the failParsingForTesting flag is always respected. The `runAssignment` code path makes sure to check that the `failParsingForTesting` flag is set and throwing an error if so; this patch ensures that the check happens on every code path. I chose not to change the `runAssignment` code path to use this new executeParserAction function, since that whole spiel is going away. --- src/Control/Carrier/Parse/Measured.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Control/Carrier/Parse/Measured.hs b/src/Control/Carrier/Parse/Measured.hs index 9c90ae0e3..3e2886e0c 100644 --- a/src/Control/Carrier/Parse/Measured.hs +++ b/src/Control/Carrier/Parse/Measured.hs @@ -62,14 +62,12 @@ runParser blob@Blob{..} parser = case parser of ASTParser language -> time "parse.tree_sitter_ast_parse" languageTag $ do config <- asks config - parseToAST (configTreeSitterParseTimeout config) language blob - >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure + executeParserAction (parseToAST (configTreeSitterParseTimeout config) language blob) UnmarshalParser language -> time "parse.tree_sitter_precise_ast_parse" languageTag $ do config <- asks config - parseToPreciseAST (configTreeSitterParseTimeout config) (configTreeSitterUnmarshalTimeout config) language blob - >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure + executeParserAction (parseToPreciseAST (configTreeSitterParseTimeout config) (configTreeSitterUnmarshalTimeout config) language blob) AssignmentParser parser assignment -> runAssignment Assignment.assign parser blob assignment @@ -77,7 +75,13 @@ runParser blob@Blob{..} parser = case parser of time "parse.cmark_parse" languageTag $ let term = cmarkParser blobSource in length term `seq` pure term - where languageTag = [("language" :: String, show (blobLanguage blob))] + where + languageTag = [("language" :: String, show (blobLanguage blob))] + executeParserAction act = do + -- Test harnesses can specify that parsing must fail, for testing purposes. + shouldFailFlag <- asks (Flag.toBool FailTestParsing . configFailParsingForTesting . config) + when shouldFailFlag (throwError (SomeException AssignmentTimedOut)) + act >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure data ParserCancelled = ParserTimedOut | AssignmentTimedOut deriving (Show)