From 8b1fbd9954a274e60ceb90dec8996f18848f54ec Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Thu, 27 Jun 2013 22:55:52 -0400 Subject: [PATCH] Tweaks to parser Introduce [,,,] syntax for anonymous tuples (an alias for "tuple(,,,)"). Modify rule span information to avoid subsequent whitespace. --- src/Dyna/ParserHS/Parser.hs | 23 +++++++++++++---------- src/Dyna/ParserHS/Selftest.hs | 32 ++++++++++++++++++++++++-------- 2 files changed, 37 insertions(+), 18 deletions(-) diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index f10376b..9b18891 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -326,11 +326,14 @@ term = token $ choice <* (notFollowedBy $ char '(') , try $ nullaryStar + , spanned $ nakedbrak , spanned $ parenfunc ] where parenfunc = TFunctor <$> parseFunctor - <*> parens (tlexpr `sepBy` symbolic ',') + <*> parens (tlexpr `sepBy` symbolic ',') + + nakedbrak = TFunctor "tuple" <$> brackets (tlexpr `sepBy` symbolic ',') mkta ty te = TAnnot (AnnType ty) te @@ -421,17 +424,17 @@ genericAggregators = token ) "Aggregator" rule :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) - => m Rule + => m (Spanned Rule) rule = token $ do h@(_ :~ hs) <- term choice [ do - _ <- try (char '.' <* lookAhead whiteSpace) - return (Rule h "|=" (TFunctor "true" [] :~ hs)) + (_ :~ ds) <- try (spanned (char '.') <* lookAhead whiteSpace) + return (Rule h "|=" (TFunctor "true" [] :~ ds) :~ (hs <> ds)) , do - aggr <- token $ join $ asks dlc_aggrs - body <- tfexpr - _ <- char '.' - return (Rule h aggr body) + aggr <- token $ join $ asks dlc_aggrs + body <- tfexpr + _ :~ ds <- spanned (char '.') + return (Rule h aggr body :~ (hs <> ds)) ] ------------------------------------------------------------------------}}} @@ -683,7 +686,7 @@ pragma = token $ dline :: (MonadReader DLCfg m, DeltaParsing m, LookAheadParsing m) => m (Spanned PLine) dline = spanned (choice [ PLPragma <$> pragma - , PLRule <$> spanned rule + , PLRule <$> rule ]) configureParser :: (DeltaParsing m, LookAheadParsing m) @@ -708,7 +711,7 @@ testGenericAggr :: (DeltaParsing m, LookAheadParsing m) testGenericAggr = genericAggregators testRule :: (DeltaParsing m, LookAheadParsing m) - => DLCfg -> m Rule + => DLCfg -> m (Spanned Rule) testRule = configureParser rule testPragma :: (DeltaParsing m, LookAheadParsing m) diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index cfbbda4..86d346d 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -155,6 +155,20 @@ case_colonFunctor = e @=? (term pvv) :~ Span (Columns 0 0) (Columns 17 17) pvv pvv = "possible(Var:Val)" +case_bracketTuple :: Assertion +case_bracketTuple = e @=? (term s) + where + e = TFunctor "tuple" + [ _tNumeric (Left 1) :~ Span (Columns 1 1) (Columns 2 2) s + , TFunctor "+" + [ _tNumeric (Left 2) :~ Span (Columns 3 3) (Columns 4 4) s + , _tNumeric (Left 3) :~ Span (Columns 5 5) (Columns 6 6) s + ] + :~ Span (Columns 3 3) (Columns 6 6) s + ] + :~ Span (Columns 0 0) (Columns 7 7) s + s = "[1,2+3]" + -- case_nullaryStar :: Assertion -- case_nullaryStar = e @=? (term gs) -- where @@ -200,7 +214,7 @@ test_aggregators = hUnitTestToTests $ TestList (\_ -> return ())) [".", ". ", "+=3", "+3=", "+=a", "+a=" ] , TestLabel "custom accept" $ - let r = unsafeParse (testRule cdlc) r1 + let r :~ _ = unsafeParse (testRule cdlc) r1 in r ~=? Rule (TFunctor "a" [] :~ Span (Columns 0 0) (Columns 2 2) r1) "+=" (TFunctor "b" [] :~ Span (Columns 5 5) (Columns 6 6) r1) @@ -220,10 +234,10 @@ test_aggregators = hUnitTestToTests $ TestList -- Rules {{{ progrule :: ByteString -> Spanned Rule -progrule = unsafeParse (whiteSpace *> spanned (testRule defDLC <* eof)) +progrule = unsafeParse (whiteSpace *> (testRule defDLC <* eof)) progrules :: ByteString -> [Spanned Rule] -progrules = unsafeParse (whiteSpace *> many (spanned (testRule defDLC)) <* eof) +progrules = unsafeParse (whiteSpace *> many (testRule defDLC) <* eof) oneshotRules :: ByteString -> [(RuleIx, Spanned Rule)] oneshotRules = xlate . unsafeParse (oneshotDynaParser Nothing) @@ -236,7 +250,7 @@ case_ruleFact = e @=? (progrule sr) e = Rule (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 4 4) sr) "|=" - (TFunctor "true" [] :~ Span (Columns 0 0) (Columns 4 4) sr) + (TFunctor "true" [] :~ Span (Columns 4 4) (Columns 5 5) sr) :~ ts ts = Span (Columns 0 0) (Columns 5 5) sr sr = "goal." @@ -368,7 +382,9 @@ case_rules = e @=? (progrules sr) (_tNumeric (Left 2) :~ Span (Columns 22 22) (Columns 24 24) sr) :~ s2 ] - s1 = Span (Columns 0 0) (Columns 12 12) sr + -- Here and elsewhere, it is important that the rules not abut! The + -- whitespace separating them is not to be counted in either one. + s1 = Span (Columns 0 0) (Columns 11 11) sr s2 = Span (Columns 12 12) (Columns 25 25) sr sr = "goal += 1 . laog min= 2 ." @@ -391,7 +407,7 @@ case_rules_with_ruleix_pragmas = e @=? (oneshotRules sr) ) ] - s1 = Span (Columns 13 13) (Columns 24 24) sr + s1 = Span (Columns 13 13) (Columns 23 23) sr s2 = Span (Columns 24 24) (Columns 36 36) sr sr = ":- ruleix 5. goal += 1. laog min= 2." @@ -416,7 +432,7 @@ case_rulesWhitespace = e @=? (progrules sr) l1 = " += 1 .\n" l2 = "%test \n" l3 = " goal += 2 ." - s1 = Span (Columns 2 2) (Lines 3 1 31 1) l0 + s1 = Span (Columns 2 2) (Lines 1 7 22 7) l0 s2 = Span (Lines 3 1 31 1) (Lines 3 12 42 12) l3 sr = B.concat [l0,l1,l2,l3] @@ -438,7 +454,7 @@ case_rulesDotExpr = e @=? (progrules sr) (_tNumeric (Left 1) :~ Span (Columns 25 25) (Columns 27 27) sr) :~ s2 ] - s1 = Span (Columns 0 0) (Columns 17 17) sr + s1 = Span (Columns 0 0) (Columns 16 16) sr s2 = Span (Columns 17 17) (Columns 28 28) sr sr = "goal += foo.bar. goal += 1 ." -- 2.50.1