From a9ae3443e665d583e3126543fd07f23746c572a4 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Mon, 3 Jun 2013 23:29:27 -0400 Subject: [PATCH] Fix some parser bugs Aggregator parsing now much more rigorous & have more self-tests. Facts now use "|=" aggregation as they should --- src/Dyna/Main/Driver.hs | 2 +- src/Dyna/ParserHS/OneshotDriver.hs | 5 ++- src/Dyna/ParserHS/Parser.hs | 65 +++++++++++++++--------------- src/Dyna/ParserHS/Selftest.hs | 44 ++++++++++++++++++-- src/Dyna/XXX/TrifectaTest.hs | 14 +++++-- 5 files changed, 87 insertions(+), 43 deletions(-) diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index 8daf8cc..d664371 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -249,7 +249,7 @@ processFile fileName = bracket openOut hClose go maybeWarnANF xs = Just $ vcat $ map (uncurry renderSpannedWarn) xs go out = do - P.PDP rs <- parse + P.PDP rs _ <- parse dump DumpParsed (vcat $ map (\(i,_,r) -> text $ show (i,r)) rs) diff --git a/src/Dyna/ParserHS/OneshotDriver.hs b/src/Dyna/ParserHS/OneshotDriver.hs index 4f2ca32..0735f0b 100644 --- a/src/Dyna/ParserHS/OneshotDriver.hs +++ b/src/Dyna/ParserHS/OneshotDriver.hs @@ -36,7 +36,8 @@ import qualified Text.PrettyPrint.Free as PP -- Output {{{ data ParsedDynaProgram = PDP - { _pdp_rules :: [(RuleIx, DisposTab, Spanned Rule)] + { _pdp_rules :: [(RuleIx, DisposTab, Spanned Rule)] + , _pdp_next_rix :: RuleIx } ------------------------------------------------------------------------}}} @@ -148,6 +149,6 @@ oneshotDynaParser = (postProcess =<<) $ flip runStateT defPCS return $ (rix, dtmk dto, r) <* whiteSpace where - postProcess (rs,pcs) = return $ PDP rs + postProcess (rs,pcs) = return $ PDP rs (pcs^.pcs_ruleix) ------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index 47b7633..f752bf7 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -51,7 +51,7 @@ module Dyna.ParserHS.Parser ( -- * Action parse, -- * Test harness hooks - testTerm, testRule, testPragma, + testTerm, testAggr, testRule, testPragma, ) where import Control.Applicative @@ -323,13 +323,11 @@ dynaOperStyle = IdentifierStyle , _styleReservedHighlight = ReservedOperator } -dynaAggStyle :: TokenParsing m => IdentifierStyle m -dynaAggStyle = IdentifierStyle - { _styleName = "Aggregator" - , _styleStart = (oneOfSet $ usualpunct CS.\\ CS.fromList ".,") - <|> lower - , _styleLetter = (oneOfSet $ usualpunct) - <|> alphaNum +dynaAggNameStyle :: TokenParsing m => IdentifierStyle m +dynaAggNameStyle = IdentifierStyle + { _styleName = "Aggregator Name" + , _styleStart = lower + , _styleLetter = letter , _styleReserved = mempty , _styleHighlight = Operator , _styleReservedHighlight = ReservedOperator @@ -337,8 +335,8 @@ dynaAggStyle = IdentifierStyle -- | Aggregators must end with one of these symbols; used to prevent -- an over-zealous interpretation of concatenation as a rule. -aggTermSyms :: H.HashSet Char -aggTermSyms = H.fromList "=-" +aggTermSyms :: CS.CharSet +aggTermSyms = CS.fromList "=-" dynaNameStyle :: TokenParsing m => IdentifierStyle m dynaNameStyle = IdentifierStyle @@ -480,33 +478,32 @@ tfexpr = buildExpressionParser moreETable tlexpr "Expression" ------------------------------------------------------------------------}}} -- Rules {{{ -parseAggr :: (DeltaParsing m) => m B.ByteString -parseAggr = +-- XXX There must be a better way. +parseAggr :: (DeltaParsing m, LookAheadParsing m) => m B.ByteString +parseAggr = token (do - a <- ident dynaAggStyle - when (not $ (last a) `H.member` aggTermSyms) $ - unexpected "Improper terminal character in aggregator" - bsf (pure a) + an <- optional (identNL dynaAggNameStyle) + as <- manyTill (oneOfSet usualpunct) + (try $ lookAhead $ oneOfSet aggTermSyms + <* notFollowedBy (oneOfSet usualpunct)) + ae <- oneOfSet aggTermSyms + bsf (pure $ maybe id (++) an $ as ++ [ae]) ) "Aggregator" rule :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) => m Rule -rule = optional whiteSpace - *> choice [ - -- HEAD AGGR TFEXPR . - try $ Rule <$> term - <* whiteSpace - <*> parseAggr - <*> tfexpr - - -- HEAD . - , do - h@(_ :~ s) <- term - Rule <$> pure h - <*> pure "&=" - <*> pure (TFunctor "true" [] :~ s) - ] - <* {- optional -} (char '.') +rule = do + _ <- optional whiteSpace + h@(_ :~ hs) <- term + choice [ do + _ <- try (char '.' <* lookAhead whiteSpace) + return (Rule h "|=" (TFunctor "true" [] :~ hs)) + , do + aggr <- parseAggr + body <- tfexpr + _ <- char '.' + return (Rule h aggr body) + ] ------------------------------------------------------------------------}}} -- Pragmas {{{ @@ -679,6 +676,10 @@ testTerm :: (DeltaParsing m, LookAheadParsing m) => DLCfg -> m (Spanned Term) testTerm = configureParser term +testAggr :: (DeltaParsing m, LookAheadParsing m) + => m B.ByteString +testAggr = parseAggr + testRule :: (DeltaParsing m, LookAheadParsing m) => DLCfg -> m Rule testRule = configureParser rule diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index 7e9ad17..706096b 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -19,6 +19,7 @@ module Dyna.ParserHS.Selftest where import Control.Applicative import Data.ByteString (ByteString) import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as BU -- import Data.Foldable (toList) -- import Data.Monoid (mempty) -- import qualified Data.Sequence as S @@ -29,10 +30,10 @@ import Dyna.ParserHS.OneshotDriver import Dyna.Term.SurfaceSyntax import Dyna.Term.TTerm (Annotation(..), TBase(..)) import Dyna.XXX.TrifectaTest -import qualified Test.Framework as TF +import Test.Framework as TF import Test.Framework.Providers.HUnit import Test.Framework.TH -import Test.HUnit +import Test.HUnit as H import Text.Trifecta import Text.Trifecta.Delta @@ -176,6 +177,18 @@ case_tyAnnot = e @=? (term fintx) :~ Span (Columns 0 0) (Columns 9 9) fintx fintx = "f(:int X)" +------------------------------------------------------------------------}}} +-- Aggregators {{{ + +test_aggregators = hUnitTestToTests $ TestList + [ TestLabel "valid" $ TestList $ + map (\x -> (BU.toString x) ~: x ~=? unsafeParse testAggr x) + ["+=", "*=", ".=", "min=", "max=", "?=", ":-", "max+=" ] + , TestLabel "invalid" $ TestList $ + map (\x -> TestLabel (BU.toString x) $ TestCase $ checkParseFail_ testAggr x) + [".", ". ", "+=3", "+=a" ] + ] + ------------------------------------------------------------------------}}} -- Rules {{{ @@ -188,14 +201,14 @@ progrules = unsafeParse (many (spanned (testRule defDLC)) <* eof) oneshotRules :: ByteString -> [(RuleIx, Spanned Rule)] oneshotRules = xlate . unsafeParse (oneshotDynaParser) where - xlate (PDP rs) = map (\(i,_,sr) -> (i,sr)) rs + xlate (PDP rs _) = map (\(i,_,sr) -> (i,sr)) rs case_ruleFact :: Assertion case_ruleFact = e @=? (progrule sr) where e = Rule (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 4 4) sr) - "&=" + "|=" (TFunctor "true" [] :~ Span (Columns 0 0) (Columns 4 4) sr) :~ ts ts = Span (Columns 0 0) (Columns 5 5) sr @@ -212,6 +225,29 @@ case_ruleSimple = e @=? (progrule sr) ts = Span (Columns 0 0) (Columns 10 10) sr sr = "goal += 1." +case_ruleSimple_funny_spacing :: Assertion +case_ruleSimple_funny_spacing = e @=? (progrule sr) + where + e = Rule + (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) + "+=" + (TFunctor "a" [] :~ Span (Columns 7 7) (Columns 8 8) sr) + :~ ts + ts = Span (Columns 0 0) (Columns 9 9) sr + sr = "goal +=a." + +case_ruleSimple_no_spaces :: Assertion +case_ruleSimple_no_spaces = e @=? (progrule sr) + where + e = Rule + (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 4 4) sr) + "+=" + (TFunctor "a" [] :~ Span (Columns 6 6) (Columns 7 7) sr) + :~ ts + ts = Span (Columns 0 0) (Columns 8 8) sr + sr = "goal+=a." + + case_ruleSimple0 :: Assertion case_ruleSimple0 = e @=? (progrule sr) where diff --git a/src/Dyna/XXX/TrifectaTest.hs b/src/Dyna/XXX/TrifectaTest.hs index 7c4fd56..13eeb2b 100644 --- a/src/Dyna/XXX/TrifectaTest.hs +++ b/src/Dyna/XXX/TrifectaTest.hs @@ -1,5 +1,5 @@ module Dyna.XXX.TrifectaTest( - unsafeFS, unsafeFF, unsafeParse, checkParseFail + unsafeFS, unsafeFF, unsafeFF_, unsafeParse, checkParseFail, checkParseFail_ ) where import Control.Applicative @@ -14,7 +14,7 @@ unsafeFS (Success a) = a unsafeFS (Failure td) = error $ "Errors: " ++ show td unsafeFF :: String -> Result t -> Assertion -unsafeFF _ (Success _) = error $ "Unexpected success" +unsafeFF _ (Success _) = assertFailure "Unexpected success" unsafeFF e (Failure td) = e @=? flip PPA.displayS "" (filterSD $ PPA.renderCompact td) where @@ -25,11 +25,13 @@ unsafeFF e (Failure td) = e @=? flip PPA.displayS "" filterSD (PPA.SLine i x) = PPA.SLine i (filterSD x) filterSD (PPA.SSGR _ x) = filterSD x +unsafeFF_ :: Result t -> Assertion +unsafeFF_ (Success _) = assertFailure "Unexpected success" +unsafeFF_ (Failure _) = return () + unsafeParse :: (Parser a) -> ByteString -> a unsafeParse p = unsafeFS . parseByteString (p <* eof) mempty --- XXX this fails to properly check the last argument of the "Diagnostic"s --- we get (the [Diagnostic m] argument). We should fix that eventually. checkParseFail :: (Show a) => Parser a -> ByteString @@ -37,4 +39,8 @@ checkParseFail :: (Show a) -> Assertion checkParseFail p i e = unsafeFF e $ parseByteString (p <* eof) mempty i +checkParseFail_ :: Parser a + -> ByteString + -> Assertion +checkParseFail_ p i = unsafeFF_ $ parseByteString (p <* eof) mempty i -- 2.50.1