Aggregator parsing now much more rigorous & have more self-tests.
Facts now use "|=" aggregation as they should
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)
-- Output {{{
data ParsedDynaProgram = PDP
- { _pdp_rules :: [(RuleIx, DisposTab, Spanned Rule)]
+ { _pdp_rules :: [(RuleIx, DisposTab, Spanned Rule)]
+ , _pdp_next_rix :: RuleIx
}
------------------------------------------------------------------------}}}
return $ (rix, dtmk dto, r)
<* whiteSpace
where
- postProcess (rs,pcs) = return $ PDP rs
+ postProcess (rs,pcs) = return $ PDP rs (pcs^.pcs_ruleix)
------------------------------------------------------------------------}}}
-- * Action
parse,
-- * Test harness hooks
- testTerm, testRule, testPragma,
+ testTerm, testAggr, testRule, testPragma,
) where
import Control.Applicative
, _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
-- | 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
------------------------------------------------------------------------}}}
-- 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 {{{
=> 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
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
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
:~ 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 {{{
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
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
module Dyna.XXX.TrifectaTest(
- unsafeFS, unsafeFF, unsafeParse, checkParseFail
+ unsafeFS, unsafeFF, unsafeFF_, unsafeParse, checkParseFail, checkParseFail_
) where
import Control.Applicative
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
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
-> 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
projects / dyna2 / commitdiff