From 69c9474dbf1526e4f6dc3be29474110a66795b42 Mon Sep 17 00:00:00 2001 From: MirceaS Date: Wed, 2 Dec 2020 18:31:05 +0200 Subject: [PATCH 1/6] inlined `space` and `stringParserToIdParser` Lexer functions --- kore/src/Kore/Parser/Lexer.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/kore/src/Kore/Parser/Lexer.hs b/kore/src/Kore/Parser/Lexer.hs index 275da27bef..2f43af084e 100644 --- a/kore/src/Kore/Parser/Lexer.hs +++ b/kore/src/Kore/Parser/Lexer.hs @@ -84,6 +84,7 @@ space = L.space Parser.space1 lineComment blockComment where lineComment = L.skipLineComment "//" blockComment = L.skipBlockComment "/*" "*/" +{-# INLINE space #-} {- | Parse the character, but skip its result. -} @@ -194,6 +195,7 @@ stringParserToIdParser stringRawParser = do { getId = Text.pack name , idLocation = AstLocationFile pos } +{-# INLINE stringParserToIdParser #-} koreKeywordsSet :: HashSet String koreKeywordsSet = HashSet.fromList keywords From 663cfc59b17b61a2234849a33580e4c91696f6ba Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 2 Dec 2020 14:13:00 -0600 Subject: [PATCH 2/6] Kore.Parser.Lexer: Remove unused primitive parsers --- kore/src/Kore/Parser/Lexer.hs | 26 -------------------------- 1 file changed, 26 deletions(-) diff --git a/kore/src/Kore/Parser/Lexer.hs b/kore/src/Kore/Parser/Lexer.hs index 2f43af084e..b1d5a0d798 100644 --- a/kore/src/Kore/Parser/Lexer.hs +++ b/kore/src/Kore/Parser/Lexer.hs @@ -25,8 +25,6 @@ module Kore.Parser.Lexer , parseId , parseAnyId, parseSetId, isSymbolId , isElementVariableId, isSetVariableId - , elementVariableIdParser - , setVariableIdParser , parseSortId , parseSymbolId , parseModuleName @@ -371,30 +369,6 @@ symbolIdRawParser = do (c :) <$> parseIdRaw KeywordsPermitted else parseIdRaw KeywordsForbidden -{-|Parses a @set-variable-id@, which always starts with @\@@. - -@ - ::= ['@'] -@ --} -setVariableIdParser :: Parser Id -setVariableIdParser = stringParserToIdParser setVariableIdRawParser - -setVariableIdRawParser :: Parser String -setVariableIdRawParser = do - start <- Parser.char '@' - end <- parseIdRaw KeywordsPermitted - return (start:end) - -{-| Parses an @element-variable-id@ - -@ - ::= -@ --} -elementVariableIdParser :: Parser Id -elementVariableIdParser = parseId - {- | Parses a C-style string literal, unescaping it. @ From 3047aa10c47de59cba08f5e99b3648dc1f6be7ef Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 2 Dec 2020 14:37:14 -0600 Subject: [PATCH 3/6] Run Parser over Text, not String Using Text instead of String reduces peak memory use by 43% and total allocation by 24%. Never use String. --- kore/app/format/Main.hs | 4 ++- kore/app/share/GlobalMain.hs | 7 ++-- kore/src/Kore/Parser.hs | 7 ++-- kore/src/Kore/Parser/Lexer.hs | 54 ++++++++++++++--------------- kore/src/Kore/Parser/ParserUtils.hs | 7 ++-- 5 files changed, 44 insertions(+), 35 deletions(-) diff --git a/kore/app/format/Main.hs b/kore/app/format/Main.hs index adbec03992..795202c082 100644 --- a/kore/app/format/Main.hs +++ b/kore/app/format/Main.hs @@ -2,6 +2,7 @@ module Main (main) where import Prelude.Kore +import qualified Data.Text.IO as Text import Options.Applicative import System.IO ( stdout @@ -78,4 +79,5 @@ main = -- | Read a 'KoreDefinition' from the given file name or signal an error. readKoreOrDie :: FilePath -> IO ParsedDefinition readKoreOrDie fileName = - readFile fileName >>= either error return . parseKoreDefinition fileName + Text.readFile fileName + >>= either error return . parseKoreDefinition fileName diff --git a/kore/app/share/GlobalMain.hs b/kore/app/share/GlobalMain.hs index e01139538f..8ca843aea8 100644 --- a/kore/app/share/GlobalMain.hs +++ b/kore/app/share/GlobalMain.hs @@ -49,6 +49,7 @@ import Data.Text ( Text , pack ) +import qualified Data.Text.IO as Text import Data.Time.Format ( defaultTimeLocale , formatTime @@ -511,12 +512,14 @@ parseDefinition :: FilePath -> Main ParsedDefinition parseDefinition = mainParse parseKoreDefinition mainParse - :: (FilePath -> String -> Either String a) + :: (FilePath -> Text -> Either String a) -> String -> Main a mainParse parser fileName = do contents <- - clockSomethingIO "Reading the input file" $ liftIO $ readFile fileName + Text.readFile fileName + & liftIO + & clockSomethingIO "Reading the input file" parseResult <- clockSomething "Parsing the file" (parser fileName contents) case parseResult of diff --git a/kore/src/Kore/Parser.hs b/kore/src/Kore/Parser.hs index 560921d808..678566bcc8 100644 --- a/kore/src/Kore/Parser.hs +++ b/kore/src/Kore/Parser.hs @@ -34,6 +34,9 @@ module Kore.Parser import Prelude.Kore +import Data.Text + ( Text + ) import Text.Megaparsec ( eof ) @@ -58,7 +61,7 @@ else. -} parseKoreDefinition :: FilePath -- ^ Filename used for error messages - -> String -- ^ The concrete syntax of a valid Kore definition + -> Text -- ^ The concrete syntax of a valid Kore definition -> Either String ParsedDefinition parseKoreDefinition = parseOnly (Lexer.space *> koreParser) @@ -70,6 +73,6 @@ message otherwise. The input must contain a valid Kore pattern and nothing else. -} parseKorePattern :: FilePath -- ^ Filename used for error messages - -> String -- ^ The concrete syntax of a valid Kore pattern + -> Text -- ^ The concrete syntax of a valid Kore pattern -> Either String ParsedPattern parseKorePattern = parseOnly (Lexer.space *> Parser.parsePattern) diff --git a/kore/src/Kore/Parser/Lexer.hs b/kore/src/Kore/Parser/Lexer.hs index b1d5a0d798..64979d1f27 100644 --- a/kore/src/Kore/Parser/Lexer.hs +++ b/kore/src/Kore/Parser/Lexer.hs @@ -46,6 +46,9 @@ import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map +import Data.Text + ( Text + ) import qualified Data.Text as Text import Text.Megaparsec ( SourcePos (..) @@ -96,7 +99,7 @@ skipChar = Monad.void . Parser.char See also: 'L.symbol', 'space' -} -symbol :: String -> Parser () +symbol :: Text -> Parser () symbol = Monad.void . L.symbol space colon :: Parser () @@ -162,7 +165,7 @@ consumes any trailing whitespace. See also: 'space' -} -keyword :: String -> Parser () +keyword :: Text -> Parser () keyword s = lexeme $ do _ <- Parser.chunk s -- Check that the next character cannot be part of an @id@, i.e. check that @@ -182,20 +185,16 @@ sourcePosToFileLocation , column = unPos column' } -{- Takes a parser for the string of the identifier - and returns an 'Id' annotated with position. --} -stringParserToIdParser :: Parser String -> Parser Id -stringParserToIdParser stringRawParser = do +{- | Annotate a 'Text' parser with an 'AstLocation'. + -} +parseIntoId :: Parser Text -> Parser Id +parseIntoId stringRawParser = do !pos <- sourcePosToFileLocation <$> getSourcePos - name <- lexeme stringRawParser - return Id - { getId = Text.pack name - , idLocation = AstLocationFile pos - } -{-# INLINE stringParserToIdParser #-} + getId <- lexeme stringRawParser + return Id { getId, idLocation = AstLocationFile pos } +{-# INLINE parseIntoId #-} -koreKeywordsSet :: HashSet String +koreKeywordsSet :: HashSet Text koreKeywordsSet = HashSet.fromList keywords where keywords = @@ -224,17 +223,17 @@ genericIdRawParser :: (Char -> Bool) -- ^ contains the characters allowed for @⟨prefix-char⟩@. -> (Char -> Bool) -- ^ contains the characters allowed for @⟨body-char⟩@. -> IdKeywordParsing - -> Parser String + -> Parser Text genericIdRawParser isFirstChar isBodyChar idKeywordParsing = do c <- Parser.satisfy isFirstChar "first identifier character" cs <- Parser.takeWhileP (Just "identifier character") isBodyChar - let genericId = c : cs + let genericId = Text.cons c cs keywordsForbidden = idKeywordParsing == KeywordsForbidden isKeyword = HashSet.member genericId koreKeywordsSet when (keywordsForbidden && isKeyword) $ fail ( "Identifiers should not be keywords: '" - ++ genericId + ++ Text.unpack genericId ++ "'." ) return genericId @@ -293,9 +292,9 @@ isIdChar c = isIdFirstChar c || isIdOtherChar c An identifier cannot be a keyword. -} parseId :: Parser Id -parseId = stringParserToIdParser (parseIdRaw KeywordsForbidden) +parseId = parseIntoId (parseIdRaw KeywordsForbidden) -parseIdRaw :: IdKeywordParsing -> Parser String +parseIdRaw :: IdKeywordParsing -> Parser Text parseIdRaw = genericIdRawParser isIdFirstChar isIdChar {- | Parse a module name. @@ -309,7 +308,7 @@ parseModuleName = lexeme moduleNameRawParser moduleNameRawParser :: Parser ModuleName moduleNameRawParser = - ModuleName . Text.pack <$> parseIdRaw KeywordsForbidden + ModuleName <$> parseIdRaw KeywordsForbidden {- | Parses a 'Sort' 'Id' @@ -338,17 +337,17 @@ isSetVariableId Id { getId } = Text.head getId == '@' parseSpecialId :: Parser Id parseSpecialId = - stringParserToIdParser parseSpecialIdString + parseIntoId parseSpecialIdString where parseSpecialIdString = - (:) <$> Parser.char '\\' <*> parseIdRaw KeywordsPermitted + Text.cons <$> Parser.char '\\' <*> parseIdRaw KeywordsPermitted parseSetId :: Parser Id parseSetId = - stringParserToIdParser parseSetIdString + parseIntoId parseSetIdString where parseSetIdString = - (:) <$> Parser.char '@' <*> parseIdRaw KeywordsPermitted + Text.cons <$> Parser.char '@' <*> parseIdRaw KeywordsPermitted {- | Parses a 'Symbol' 'Id' @@ -357,16 +356,15 @@ parseSetId = @ -} parseSymbolId :: Parser Id -parseSymbolId = - stringParserToIdParser symbolIdRawParser "symbol or alias identifier" +parseSymbolId = parseIntoId symbolIdRawParser "symbol or alias identifier" -symbolIdRawParser :: Parser String +symbolIdRawParser :: Parser Text symbolIdRawParser = do c <- peekChar' if c == '\\' then do skipChar '\\' - (c :) <$> parseIdRaw KeywordsPermitted + Text.cons c <$> parseIdRaw KeywordsPermitted else parseIdRaw KeywordsForbidden {- | Parses a C-style string literal, unescaping it. diff --git a/kore/src/Kore/Parser/ParserUtils.hs b/kore/src/Kore/Parser/ParserUtils.hs index 6905d21759..09d2520cd2 100644 --- a/kore/src/Kore/Parser/ParserUtils.hs +++ b/kore/src/Kore/Parser/ParserUtils.hs @@ -21,6 +21,9 @@ import Prelude.Kore hiding ( takeWhile ) +import Data.Text + ( Text + ) import Data.Void ( Void ) @@ -34,7 +37,7 @@ import Text.Megaparsec.Error ( errorBundlePretty ) -type Parser = Parsec Void String +type Parser = Parsec Void Text {-|'peekChar' is similar to Attoparsec's 'peekChar'. It returns the next available character in the input, without consuming it. Returns 'Nothing' @@ -55,7 +58,7 @@ peekChar' = lookAhead anySingle a FilePath that is used for generating error messages and an input string and produces either a parsed object, or an error message. -} -parseOnly :: Parser a -> FilePath -> String -> Either String a +parseOnly :: Parser a -> FilePath -> Text -> Either String a parseOnly parser filePathForErrors input = case parse parser filePathForErrors input of Left err -> Left (errorBundlePretty err) From 900d983037f46390cf410bd9e18dc3f2c54e8f8c Mon Sep 17 00:00:00 2001 From: MirceaS Date: Fri, 4 Dec 2020 02:21:06 +0200 Subject: [PATCH 4/6] fixed unit tests --- kore/src/Kore/Log/KoreLogOptions.hs | 8 ++--- kore/src/Kore/Log/Registry.hs | 2 +- kore/src/Kore/Repl.hs | 3 +- kore/src/Kore/Repl/Interpreter.hs | 4 +-- kore/src/Kore/Repl/Parser.hs | 7 +++-- kore/test/Test/Kore/Builtin/Builtin.hs | 4 +-- kore/test/Test/Kore/Parser.hs | 43 ++++++++++++++------------ kore/test/Test/Kore/Parser/Lexer.hs | 9 ++++-- kore/test/Test/Kore/Parser/Parser.hs | 3 +- kore/test/Test/Kore/Repl/Parser.hs | 12 +++---- kore/test/Test/Kore/Unparser.hs | 4 +-- 11 files changed, 57 insertions(+), 42 deletions(-) diff --git a/kore/src/Kore/Log/KoreLogOptions.hs b/kore/src/Kore/Log/KoreLogOptions.hs index 2dbbf0007a..34f27db0b3 100644 --- a/kore/src/Kore/Log/KoreLogOptions.hs +++ b/kore/src/Kore/Log/KoreLogOptions.hs @@ -205,17 +205,17 @@ parseEntryTypes = ] parseCommaSeparatedEntries = - Options.maybeReader $ Parser.parseMaybe parseEntryTypes' + Options.maybeReader $ Parser.parseMaybe parseEntryTypes' . Text.pack - parseEntryTypes' :: Parser.Parsec String String EntryTypes + parseEntryTypes' :: Parser.Parsec String Text EntryTypes parseEntryTypes' = Set.fromList <$> Parser.sepEndBy parseSomeTypeRep comma comma = void (Parser.char ',') - parseSomeTypeRep :: Parser.Parsec String String SomeTypeRep + parseSomeTypeRep :: Parser.Parsec String Text SomeTypeRep parseSomeTypeRep = Parser.takeWhile1P (Just "SomeTypeRep") (flip notElem [',', ' ']) - >>= parseEntryType . Text.pack + >>= parseEntryType parseSeverity :: Parser Severity parseSeverity = diff --git a/kore/src/Kore/Log/Registry.hs b/kore/src/Kore/Log/Registry.hs index 71dc819e53..74aa3496c5 100644 --- a/kore/src/Kore/Log/Registry.hs +++ b/kore/src/Kore/Log/Registry.hs @@ -218,7 +218,7 @@ lookupTextFromTypeWithError type' = <> show type' <> " It should be added to Kore.Log.Registry.registry." -parseEntryType :: Ord e => Text -> Parser.Parsec e String SomeTypeRep +parseEntryType :: Ord e => Text -> Parser.Parsec e Text SomeTypeRep parseEntryType entryText = maybe empty return $ Map.lookup entryText (textToType registry) diff --git a/kore/src/Kore/Repl.hs b/kore/src/Kore/Repl.hs index 5e84853b77..ace8321b6d 100644 --- a/kore/src/Kore/Repl.hs +++ b/kore/src/Kore/Repl.hs @@ -45,6 +45,7 @@ import Data.List ) import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq +import qualified Data.Text as Text import Kore.Attribute.RuleIndex ( RuleIndex (..) ) @@ -176,7 +177,7 @@ runRepl repl0 = do str <- prompt let command = - fromMaybe ShowUsage $ parseMaybe commandParser str + fromMaybe ShowUsage $ parseMaybe commandParser (Text.pack str) when (shouldStore command) $ field @"commands" Lens.%= (Seq.|> str) void $ replInterpreter printIfNotEmpty command diff --git a/kore/src/Kore/Repl/Interpreter.hs b/kore/src/Kore/Repl/Interpreter.hs index acaabe9245..3ef2cdc7b6 100644 --- a/kore/src/Kore/Repl/Interpreter.hs +++ b/kore/src/Kore/Repl/Interpreter.hs @@ -1251,7 +1251,7 @@ tryAlias replAlias@ReplAlias { name } printAux printKore = do parsedCommand = fromMaybe ShowUsage - $ parseMaybe commandParser command + $ parseMaybe commandParser (Text.pack command) config <- ask (cont, st') <- get >>= runInterpreter parsedCommand config put st' @@ -1500,7 +1500,7 @@ parseEvalScript file scriptModeOutput = do if exists then do contents <- lift . liftIO $ readFile file - let result = runParser scriptParser file contents + let result = runParser scriptParser file (Text.pack contents) either parseFailed executeScript result else lift . liftIO . putStrLn $ "Cannot find " <> file diff --git a/kore/src/Kore/Repl/Parser.hs b/kore/src/Kore/Repl/Parser.hs index 7f390fc9aa..c6291b3843 100644 --- a/kore/src/Kore/Repl/Parser.hs +++ b/kore/src/Kore/Repl/Parser.hs @@ -31,6 +31,9 @@ import qualified Data.Set as Set import Data.String ( IsString (..) ) +import Data.Text + ( Text + ) import qualified Data.Text as Text import Text.Megaparsec ( Parsec @@ -57,7 +60,7 @@ import qualified Kore.Log as Log import qualified Kore.Log.Registry as Log import Kore.Repl.Data -type Parser = Parsec ReplParseError String +type Parser = Parsec ReplParseError Text newtype ReplParseError = ReplParseError { unReplParseError :: String } deriving (Eq, Ord) @@ -449,7 +452,7 @@ spaceNoNewline :: Parser () spaceNoNewline = void . many $ oneOf [' ', '\t', '\r', '\f', '\v'] -literal :: String -> Parser () +literal :: Text -> Parser () literal str = void $ Char.string str <* spaceNoNewline decimal :: Integral a => Parser a diff --git a/kore/test/Test/Kore/Builtin/Builtin.hs b/kore/test/Test/Kore/Builtin/Builtin.hs index 1354a3a4ac..8e39b651d0 100644 --- a/kore/test/Test/Kore/Builtin/Builtin.hs +++ b/kore/test/Test/Kore/Builtin/Builtin.hs @@ -112,7 +112,7 @@ import Kore.Syntax.Definition import qualified Kore.Unification.Procedure as Unification import Kore.Unification.UnificationProcedure import Kore.Unparser - ( unparseToString + ( unparseToText ) import qualified Logic import SMT @@ -303,6 +303,6 @@ hpropUnparse -> Hedgehog.Property hpropUnparse gen = Hedgehog.property $ do builtin <- Hedgehog.forAll gen - let syntax = unparseToString builtin + let syntax = unparseToText builtin expected = Builtin.externalize builtin Right expected Hedgehog.=== parseKorePattern "" syntax diff --git a/kore/test/Test/Kore/Parser.hs b/kore/test/Test/Kore/Parser.hs index 95e36892bc..41303647db 100644 --- a/kore/test/Test/Kore/Parser.hs +++ b/kore/test/Test/Kore/Parser.hs @@ -12,6 +12,11 @@ module Test.Kore.Parser import Prelude.Kore +import Data.Text + ( Text + , unpack + ) + import Test.Tasty ( TestTree , testGroup @@ -35,38 +40,38 @@ import Text.Megaparsec import Kore.Parser.ParserUtils data SuccessfulTest a = SuccessfulTest - { successInput :: String + { successInput :: Text , successExpected :: a } data FailureTest = FailureTest - { failureInput :: String + { failureInput :: Text , failureExpected :: String } data ParserTest a = Success (SuccessfulTest a) | Failure FailureTest - | Skip [String] - | FailureWithoutMessage [String] + | Skip [Text] + | FailureWithoutMessage [Text] -success :: String -> a -> ParserTest a +success :: Text -> a -> ParserTest a success input expected = Success SuccessfulTest { successInput = input , successExpected = expected } -parsesTo_ :: String -> a -> ParserTest a +parsesTo_ :: Text -> a -> ParserTest a parsesTo_ = success -fails :: String -> () -> ParserTest a +fails :: Text -> () -> ParserTest a fails input _ = FailureWithoutMessage [input] parseTree :: HasCallStack => (Show a, Eq a) => ShowErrorComponent e - => Parsec e String a + => Parsec e Text a -> [ParserTest a] -> [TestTree] parseTree parser = map (parseTest parser) @@ -75,16 +80,16 @@ parseTest :: HasCallStack => (Show a, Eq a) => ShowErrorComponent e - => Parsec e String a + => Parsec e Text a -> ParserTest a -> TestTree parseTest parser (Success test) = testCase - ("Parsing '" ++ successInput test ++ "'") + ("Parsing '" ++ unpack (successInput test) ++ "'") (parseSuccess (successExpected test) parser (successInput test)) parseTest parser (Failure test) = testCase - ("Failing to parse '" ++ failureInput test ++ "'") + ("Failing to parse '" ++ unpack (failureInput test) ++ "'") (parseFailureWithMessage (failureExpected test) parser (failureInput test)) parseTest parser (FailureWithoutMessage tests) = @@ -92,7 +97,7 @@ parseTest parser (FailureWithoutMessage tests) = (map (\input -> testCase - ("Failing to parse '" ++ input ++ "'") + ("Failing to parse '" ++ unpack input ++ "'") (parseFailureWithoutMessage parser input) ) tests @@ -117,18 +122,18 @@ parseSkipTest parser (Skip tests) = (map (\input -> testCase - ("Skipping '" ++ input ++ "'") + ("Skipping '" ++ unpack input ++ "'") (parseSkip parser input) ) tests ) parseSkipTest _ (Success test) = testCase - ("Parsing success test '" ++ successInput test ++ "'") + ("Parsing success test '" ++ unpack (successInput test) ++ "'") (assertBool "Not Expecting Success Tests here" False) parseSkipTest parser test = parseTest parser test -parse' :: ShowErrorComponent e => Parsec e String a -> String -> Either String a +parse' :: ShowErrorComponent e => Parsec e Text a -> Text -> Either String a parse' parser input = parse (parser <* eof) "" input & Bifunctor.first errorBundlePretty @@ -137,16 +142,16 @@ parseSuccess :: HasCallStack => (Show a, Eq a) => ShowErrorComponent e - => a -> Parsec e String a -> String -> Assertion + => a -> Parsec e Text a -> Text -> Assertion parseSuccess expected parser input = assertEqual "" (Right expected) (parse' parser input) -parseSkip :: ShowErrorComponent e => Parsec e String () -> String -> Assertion +parseSkip :: ShowErrorComponent e => Parsec e Text () -> Text -> Assertion parseSkip parser input = assertEqual "" (Right ()) (parse' parser input) parseFailureWithoutMessage - :: ShowErrorComponent e => Parsec e String a -> String -> Assertion + :: ShowErrorComponent e => Parsec e Text a -> Text -> Assertion parseFailureWithoutMessage parser input = assertBool "" (isLeft (parse' parser input)) @@ -154,6 +159,6 @@ parseFailureWithMessage :: HasCallStack => (Show a, Eq a) => ShowErrorComponent e - => String -> Parsec e String a -> String -> Assertion + => String -> Parsec e Text a -> Text -> Assertion parseFailureWithMessage expected parser input = assertEqual "" (Left expected) (parse' parser input) diff --git a/kore/test/Test/Kore/Parser/Lexer.hs b/kore/test/Test/Kore/Parser/Lexer.hs index 903c230ed3..fcf89d3483 100644 --- a/kore/test/Test/Kore/Parser/Lexer.hs +++ b/kore/test/Test/Kore/Parser/Lexer.hs @@ -15,6 +15,11 @@ module Test.Kore.Parser.Lexer import Prelude.Kore +import Data.Text + ( Text + , unpack + ) + import Test.Tasty ( TestTree ) @@ -277,7 +282,7 @@ test_parseStringLiteral = ] ] -invalidEscape :: String -> ParserTest a +invalidEscape :: Text -> ParserTest a invalidEscape failureInput = Failure FailureTest { failureInput, failureExpected } where @@ -285,7 +290,7 @@ invalidEscape failureInput = unlines [ ":1:4:" , " |" - , "1 | " ++ failureInput + , "1 | " ++ unpack failureInput , " | ^" , "expecting escape sequence" ] diff --git a/kore/test/Test/Kore/Parser/Parser.hs b/kore/test/Test/Kore/Parser/Parser.hs index b7961154d6..677af5832d 100644 --- a/kore/test/Test/Kore/Parser/Parser.hs +++ b/kore/test/Test/Kore/Parser/Parser.hs @@ -17,6 +17,7 @@ import Data.Generics.Product ) import Data.Text ( Text + , pack ) import Data.Sup @@ -1534,7 +1535,7 @@ definitionParserTests = ] } , success - ( "[\"a\"] " + (pack $ "[\"a\"] " ++ "module M sort c{}[] endmodule [\"b\"] " ++ "module N sort d{}[] endmodule [\"e\"]" ) diff --git a/kore/test/Test/Kore/Repl/Parser.hs b/kore/test/Test/Kore/Repl/Parser.hs index 26e0b9d9da..832227d290 100644 --- a/kore/test/Test/Kore/Repl/Parser.hs +++ b/kore/test/Test/Kore/Repl/Parser.hs @@ -584,13 +584,13 @@ debugAttemptEquationTests = { Log.selected = fromList [] } - , ("debug-attempt-equation " <> totalBalanceSymbolId) + , Text.pack ("debug-attempt-equation " <> totalBalanceSymbolId) `parsesTo_` DebugAttemptEquation Log.DebugAttemptEquationOptions { Log.selected = fromList [totalBalanceSymbolId] } - , ("debug-attempt-equation " <> totalBalanceSymbolId <> " " <> plusSymbolId) + , Text.pack ("debug-attempt-equation " <> totalBalanceSymbolId <> " " <> plusSymbolId) `parsesTo_` DebugAttemptEquation Log.DebugAttemptEquationOptions { Log.selected = fromList @@ -618,13 +618,13 @@ debugApplyEquationTests = { Log.selected = fromList [] } - , ("debug-apply-equation " <> totalBalanceSymbolId) + , Text.pack ("debug-apply-equation " <> totalBalanceSymbolId) `parsesTo_` DebugApplyEquation Log.DebugApplyEquationOptions { Log.selected = fromList [totalBalanceSymbolId] } - , ("debug-apply-equation " <> totalBalanceSymbolId <> " " <> plusSymbolId) + , Text.pack ("debug-apply-equation " <> totalBalanceSymbolId <> " " <> plusSymbolId) `parsesTo_` DebugApplyEquation Log.DebugApplyEquationOptions { Log.selected = fromList @@ -652,13 +652,13 @@ debugEquationTests = { Log.selected = fromList [] } - , ("debug-equation " <> totalBalanceSymbolId) + , Text.pack ("debug-equation " <> totalBalanceSymbolId) `parsesTo_` DebugEquation Log.DebugEquationOptions { Log.selected = fromList [totalBalanceSymbolId] } - , ("debug-equation " <> totalBalanceSymbolId <> " " <> plusSymbolId) + , Text.pack ("debug-equation " <> totalBalanceSymbolId <> " " <> plusSymbolId) `parsesTo_` DebugEquation Log.DebugEquationOptions { Log.selected = fromList diff --git a/kore/test/Test/Kore/Unparser.hs b/kore/test/Test/Kore/Unparser.hs index a4b14c3f9b..613de0ebf6 100644 --- a/kore/test/Test/Kore/Unparser.hs +++ b/kore/test/Test/Kore/Unparser.hs @@ -313,7 +313,7 @@ roundtrip roundtrip generator parser = Hedgehog.property $ do generated <- Hedgehog.forAll generator - parse' parser (unparseToString generated) === Right generated + parse' parser (unparseToText generated) === Right generated unparseParseTest :: (HasCallStack, Unparse a, Debug a, Diff a) => Parser a -> a -> TestTree @@ -322,7 +322,7 @@ unparseParseTest parser astInput = "Parsing + unparsing." (assertEqual "" (Right astInput) - (parse' parser (unparseToString astInput))) + (parse' parser (unparseToText astInput))) unparseTest :: (HasCallStack, Unparse a, Debug a) => a -> String -> TestTree unparseTest astInput expected = From bc05ca9eb2f6ddce18eb30e66eb24e0ecb7d0a87 Mon Sep 17 00:00:00 2001 From: MirceaS Date: Mon, 7 Dec 2020 18:13:21 +0200 Subject: [PATCH 5/6] addressed comments --- kore/src/Kore/Parser/Lexer.hs | 41 ++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/kore/src/Kore/Parser/Lexer.hs b/kore/src/Kore/Parser/Lexer.hs index 64979d1f27..c7fef09c38 100644 --- a/kore/src/Kore/Parser/Lexer.hs +++ b/kore/src/Kore/Parser/Lexer.hs @@ -225,10 +225,10 @@ genericIdRawParser -> IdKeywordParsing -> Parser Text genericIdRawParser isFirstChar isBodyChar idKeywordParsing = do - c <- Parser.satisfy isFirstChar "first identifier character" - cs <- Parser.takeWhileP (Just "identifier character") isBodyChar - let genericId = Text.cons c cs - keywordsForbidden = idKeywordParsing == KeywordsForbidden + (genericId, _) <- Parser.match + $ (Parser.satisfy isFirstChar "first identifier character") + >> Parser.takeWhileP (Just "identifier character") isBodyChar + let keywordsForbidden = idKeywordParsing == KeywordsForbidden isKeyword = HashSet.member genericId koreKeywordsSet when (keywordsForbidden && isKeyword) $ fail @@ -292,11 +292,14 @@ isIdChar c = isIdFirstChar c || isIdOtherChar c An identifier cannot be a keyword. -} parseId :: Parser Id -parseId = parseIntoId (parseIdRaw KeywordsForbidden) +parseId = parseIntoId parseIdText parseIdRaw :: IdKeywordParsing -> Parser Text parseIdRaw = genericIdRawParser isIdFirstChar isIdChar +parseIdText :: Parser Text +parseIdText = parseIdRaw KeywordsForbidden + {- | Parse a module name. @ @@ -320,7 +323,9 @@ parseSortId :: Parser Id parseSortId = parseId "sort identifier" parseAnyId :: Parser Id -parseAnyId = (parseSpecialId <|> parseSetId <|> parseId) "identifier" +parseAnyId = parseIntoId + (parseSpecialIdText <|> parseSetIdText <|> parseIdText) + "identifier" isSymbolId :: Id -> Bool isSymbolId Id { getId } = @@ -335,19 +340,16 @@ isElementVariableId Id { getId } = isSetVariableId :: Id -> Bool isSetVariableId Id { getId } = Text.head getId == '@' -parseSpecialId :: Parser Id -parseSpecialId = - parseIntoId parseSpecialIdString - where - parseSpecialIdString = - Text.cons <$> Parser.char '\\' <*> parseIdRaw KeywordsPermitted +parseSpecialIdText :: Parser Text +parseSpecialIdText = fst <$> Parser.match + (Parser.char '\\' >> parseIdRaw KeywordsPermitted) + +parseSetIdText :: Parser Text +parseSetIdText = fst <$> Parser.match + (Parser.char '@' >> parseIdRaw KeywordsPermitted) parseSetId :: Parser Id -parseSetId = - parseIntoId parseSetIdString - where - parseSetIdString = - Text.cons <$> Parser.char '@' <*> parseIdRaw KeywordsPermitted +parseSetId = parseIntoId parseSetIdText {- | Parses a 'Symbol' 'Id' @@ -362,9 +364,8 @@ symbolIdRawParser :: Parser Text symbolIdRawParser = do c <- peekChar' if c == '\\' - then do - skipChar '\\' - Text.cons c <$> parseIdRaw KeywordsPermitted + then fst <$> Parser.match + (Parser.char '\\' >> parseIdRaw KeywordsPermitted) else parseIdRaw KeywordsForbidden {- | Parses a C-style string literal, unescaping it. From 1ba70f87254e9db6456466a900c75c0df52960f8 Mon Sep 17 00:00:00 2001 From: MirceaS Date: Wed, 9 Dec 2020 14:52:26 +0200 Subject: [PATCH 6/6] addressed PR comments --- kore/src/Kore/Parser/Lexer.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/kore/src/Kore/Parser/Lexer.hs b/kore/src/Kore/Parser/Lexer.hs index c7fef09c38..9f195e91d2 100644 --- a/kore/src/Kore/Parser/Lexer.hs +++ b/kore/src/Kore/Parser/Lexer.hs @@ -225,9 +225,10 @@ genericIdRawParser -> IdKeywordParsing -> Parser Text genericIdRawParser isFirstChar isBodyChar idKeywordParsing = do - (genericId, _) <- Parser.match - $ (Parser.satisfy isFirstChar "first identifier character") - >> Parser.takeWhileP (Just "identifier character") isBodyChar + (genericId, _) <- Parser.match $ do + _ <- Parser.satisfy isFirstChar "first identifier character" + _ <- Parser.takeWhileP (Just "identifier character") isBodyChar + pure () let keywordsForbidden = idKeywordParsing == KeywordsForbidden isKeyword = HashSet.member genericId koreKeywordsSet when (keywordsForbidden && isKeyword) @@ -361,12 +362,9 @@ parseSymbolId :: Parser Id parseSymbolId = parseIntoId symbolIdRawParser "symbol or alias identifier" symbolIdRawParser :: Parser Text -symbolIdRawParser = do - c <- peekChar' - if c == '\\' - then fst <$> Parser.match - (Parser.char '\\' >> parseIdRaw KeywordsPermitted) - else parseIdRaw KeywordsForbidden +symbolIdRawParser = fmap fst $ Parser.match $ + (Parser.char '\\' >> parseIdRaw KeywordsPermitted) + <|> parseIdRaw KeywordsForbidden {- | Parses a C-style string literal, unescaping it.