From: Nathaniel Wesley Filardo Date: Wed, 5 Jun 2013 18:55:16 +0000 (-0400) Subject: More parser work X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=55189e4b2edac6ffa1f31a2e861607952a454a38;p=dyna2 More parser work Allow backends to restrict the set of acceptable aggregators. Feed through rendered parser state. --- diff --git a/src/Dyna/Backend/BackendDefn.hs b/src/Dyna/Backend/BackendDefn.hs index bec013e..ff3c11d 100644 --- a/src/Dyna/Backend/BackendDefn.hs +++ b/src/Dyna/Backend/BackendDefn.hs @@ -7,7 +7,7 @@ module Dyna.Backend.BackendDefn where -import qualified Data.Set as S +import qualified Data.Set as S import Dyna.Analysis.Aggregation (AggMap) import Dyna.Analysis.ANF (Rule) import Dyna.Analysis.DOpAMine (BackendRenderDopIter) @@ -32,8 +32,18 @@ type BackendDriver bs = AggMap -- ^ Aggregation -> IO () data Backend = forall bs . Backend - { -- | Hook for planner to get builtin information - be_builtin :: BackendPossible bs + { -- | Aggregators exported by this backend, if specified. + -- + -- If not given, the parser will use a generic set of + -- aggregators. + -- + -- XXX This is not really right, as the set of aggregators is + -- a property of Dyna, not of the backend, but for the + -- moment... + be_aggregators :: Maybe (S.Set String) + + -- | Hook for planner to get builtin information + , be_builtin :: BackendPossible bs -- | Any constants made available by this backend. -- diff --git a/src/Dyna/Backend/NoBackend.hs b/src/Dyna/Backend/NoBackend.hs index cf28817..7f3149f 100644 --- a/src/Dyna/Backend/NoBackend.hs +++ b/src/Dyna/Backend/NoBackend.hs @@ -35,7 +35,8 @@ import qualified Debug.Trace as XT noBackend :: Backend noBackend = Backend - { be_builtin = primPossible + { be_aggregators = Nothing + , be_builtin = primPossible , be_constants = MA.isJust . primOps -- XXX , be_debug_dop_iter = \_ _ _ _ _ -> empty , be_driver = driver diff --git a/src/Dyna/Backend/Python/Backend.hs b/src/Dyna/Backend/Python/Backend.hs index 493bb8b..26a4eb0 100644 --- a/src/Dyna/Backend/Python/Backend.hs +++ b/src/Dyna/Backend/Python/Backend.hs @@ -25,7 +25,7 @@ import Control.Monad.State import qualified Data.Map as M import qualified Data.Maybe as MA -- import qualified Data.Ord as O --- import qualified Data.Set as S +import qualified Data.Set as S -- import qualified Debug.Trace as XT import Dyna.Analysis.ANF -- import Dyna.Analysis.Aggregation @@ -43,6 +43,20 @@ import System.IO import Text.PrettyPrint.Free -- import qualified Text.Trifecta as T +------------------------------------------------------------------------}}} +-- Supported aggregations {{{ + +aggrs = S.fromList + [ "max=" , "min=" + , "+=" , "*=" + , "and=" , "or=" , "&=" , "|=" + , ":-" + , "majority=" , "set=" , "bag=" + , ":=" + , "dict=" + ] + + ------------------------------------------------------------------------}}} -- DOpAMine Backend Information {{{ @@ -274,7 +288,13 @@ printUpdate fh rule@(Rule _ h _ r _ _ _ _) cost evalix (Just (f,a)) (hv,v) dope -- Driver {{{ driver :: BackendDriver PyDopeBS -driver am um {-qm-} is pp fh = do +driver am um {-qm-} is pr fh = do + -- Parser resume state + hPutStrLn fh "parser_state = \"\"\"" + hPutStrLn fh $ show pr + hPutStrLn fh "\"\"\"" + hPutStrLn fh "" + -- Aggregation mapping forM_ (M.toList am) $ \((f,a),v) -> do hPutStrLn fh $ show $ "agg_decl" @@ -313,7 +333,8 @@ driver am um {-qm-} is pp fh = do -- Export {{{ pythonBackend :: Backend -pythonBackend = Backend builtins +pythonBackend = Backend (Just aggrs) + builtins (MA.isJust . constants) (\o is _ _ (PDBS e) -> e o is) driver diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index 2bc3ad3..c5ea94d 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -298,7 +298,7 @@ processFile fileName = bracket openOut hClose go maybeWarnANF xs = Just $ vcat $ map (uncurry renderSpannedWarn) xs go out = do - P.PDP rs pp <- parse + P.PDP rs pp <- parse (be_aggregators $ dcfg_backend ?dcfg) dump DumpParsed $ (vcat $ map (\(i,_,r) -> text $ show (i,r)) rs) @@ -317,7 +317,7 @@ processFile fileName = bracket openOut hClose go empty aggm) case dcfg_backend ?dcfg of - Backend be_b be_c be_ddi be_d -> + Backend _ be_b be_c be_ddi be_d -> let initializers = MA.mapMaybe (\(f,mca) -> (\(c,a) -> (f,c,a)) `fmap` mca) $ map (\x -> (x, planInitializer be_b x)) frs @@ -345,8 +345,8 @@ processFile fileName = bracket openOut hClose go -- Invoke the backend code generator be_d aggm uPlans' {- qPlans -} initializers' pp out - parse = do - pr <- T.parseFromFileEx (P.oneshotDynaParser <* T.eof) fileName + parse aggs = do + pr <- T.parseFromFileEx (P.oneshotDynaParser aggs <* T.eof) fileName case pr of TR.Failure td -> dynacUserANSIErr $ PPA.align ("Parser error" PPA.<$> td) TR.Success rs -> return rs diff --git a/src/Dyna/ParserHS/OneshotDriver.hs b/src/Dyna/ParserHS/OneshotDriver.hs index e3dd4fe..d8f7b31 100644 --- a/src/Dyna/ParserHS/OneshotDriver.hs +++ b/src/Dyna/ParserHS/OneshotDriver.hs @@ -21,7 +21,9 @@ import Control.Applicative import Control.Lens import Control.Monad.State import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as BU import qualified Data.Map as M +import qualified Data.Set as S import Data.Monoid (mempty) import Dyna.Main.Defns import Dyna.Main.Exception @@ -74,7 +76,10 @@ data PCS = PCS } $(makeLenses ''PCS) -_pcs_dlc pcs = DLC (_pcs_ot_cache pcs) +mkdlc aggs pcs = DLC (_pcs_ot_cache pcs) + (maybe genericAggregators ct aggs) + where + ct = fmap BU.fromString . choice . map (try . string) . S.toList update_pcs_dt = pcs_dt_cache <<~ liftA2 ($) (uses pcs_dt_mk dtmk) (use pcs_dt_over) @@ -162,23 +167,27 @@ pragmasFromPCS (PCS dt_mk dt_over _ ++ [PRuleIx rix] nextRule :: (DeltaParsing m, LookAheadParsing m, MonadState PCS m) - => m (Spanned Rule) -nextRule = do - (l :~ s) <- gets _pcs_dlc >>= parse - case l of - LPragma p -> pcsProcPragma (p :~ s) >> nextRule - LRule r -> return r + => Maybe (S.Set String) + -> m (Spanned Rule) +nextRule aggs = go + where + go = do + (l :~ s) <- gets (mkdlc aggs) >>= parse + case l of + LPragma p -> pcsProcPragma (p :~ s) >> go + LRule r -> return r oneshotDynaParser :: (DeltaParsing m, LookAheadParsing m) - => m ParsedDynaProgram -oneshotDynaParser = (postProcess =<<) - $ flip runStateT defPCS - $ many (try $ do - r <- nextRule - rix <- pcs_ruleix <<%= (+1) - dt <- use pcs_dt_cache - return $ (rix, dt, r)) - <* optional (dynaWhiteSpace (someSpace)) + => Maybe (S.Set String) + -> m ParsedDynaProgram +oneshotDynaParser aggs = (postProcess =<<) + $ flip runStateT defPCS + $ many (try $ do + r <- nextRule aggs + rix <- pcs_ruleix <<%= (+1) + dt <- use pcs_dt_cache + return $ (rix, dt, r)) + <* optional (dynaWhiteSpace (someSpace)) where postProcess (rs,pcs) = return $ PDP rs (pragmasFromPCS pcs) diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index 1a12beb..5a8c46d 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -43,7 +43,7 @@ module Dyna.ParserHS.Parser ( -- * Parser output types NameWithArgs(..), -- ** Surface langauge - Term(..), Rule(..), dynaWhiteSpace, + Term(..), Rule(..), dynaWhiteSpace, genericAggregators, -- ** Pragmas ParsedInst(..), ParsedModeInst, Pragma(..), renderPragma, -- ** Line @@ -51,7 +51,7 @@ module Dyna.ParserHS.Parser ( -- * Action parse, -- * Test harness hooks - testTerm, testAggr, testRule, testPragma, + testTerm, testGenericAggr, testRule, testPragma, ) where import Control.Applicative @@ -217,7 +217,12 @@ parseNameWithArgs n = PNWA <$> n ------------------------------------------------------------------------}}} -- Parser Monad {{{ -data DLCfg = DLC { dlc_opertab :: EOT } +data DLCfg = DLC { dlc_opertab :: EOT + , dlc_aggrs :: forall m . + (CharParsing m, DeltaParsing m, + LookAheadParsing m) + => m B.ByteString + } newtype DynaLanguage m a = DL { unDL :: ReaderT DLCfg m a } deriving (Functor,Applicative,Alternative,Monad,MonadPlus, @@ -485,8 +490,8 @@ tfexpr = buildExpressionParser moreETable tlexpr "Expression" -- Rules {{{ -- XXX There must be a better way. -parseAggr :: (DeltaParsing m, LookAheadParsing m) => m B.ByteString -parseAggr = token +genericAggregators :: (DeltaParsing m, LookAheadParsing m) => m B.ByteString +genericAggregators = token (do an <- optional (identNL dynaAggNameStyle) as <- manyTill (oneOfSet usualpunct) @@ -505,7 +510,8 @@ rule = do _ <- try (char '.' <* lookAhead whiteSpace) return (Rule h "|=" (TFunctor "true" [] :~ hs)) , do - aggr <- parseAggr + aggr <- join $ asks dlc_aggrs + _ <- whiteSpace body <- tfexpr _ <- char '.' return (Rule h aggr body) @@ -751,9 +757,9 @@ testTerm :: (DeltaParsing m, LookAheadParsing m) => DLCfg -> m (Spanned Term) testTerm = configureParser term -testAggr :: (DeltaParsing m, LookAheadParsing m) - => m B.ByteString -testAggr = parseAggr +testGenericAggr :: (DeltaParsing m, LookAheadParsing m) + => m B.ByteString +testGenericAggr = genericAggregators testRule :: (DeltaParsing m, LookAheadParsing m) => DLCfg -> m Rule diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index d9e2c1b..96f0157 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -48,7 +48,7 @@ _tNumeric :: Either Integer Double -> Term _tNumeric = TBase . TNumeric defDLC :: DLCfg -defDLC = DLC (mkEOT defOperSpec True) +defDLC = DLC (mkEOT defOperSpec True) genericAggregators term :: ByteString -> Spanned Term term = unsafeParse (testTerm defDLC <* eof) @@ -185,13 +185,27 @@ case_tyAnnot = e @=? (term fintx) test_aggregators :: [TF.Test] test_aggregators = hUnitTestToTests $ TestList - [ TestLabel "valid" $ TestList $ - map (\x -> (BU.toString x) ~: x ~=? unsafeParse testAggr x) + [ TestLabel "generic valid" $ TestList $ + map (\x -> (BU.toString x) ~: x ~=? unsafeParse testGenericAggr x) ["+=", "*=", ".=", "min=", "max=", "?=", ":-", "max+=" ] - , TestLabel "invalid" $ TestList $ - map (\x -> TestLabel (BU.toString x) $ TestCase $ checkParseFail_ testAggr x) + , TestLabel "generic invalid" $ TestList $ + map (\x -> TestLabel (BU.toString x) $ TestCase + $ checkParseFail_ testGenericAggr x) [".", ". ", "+=3", "+3=", "+=a", "+a=" ] + , TestLabel "custom accept" $ + 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) + , TestLabel "custom reject" $ TestCase + $ checkParseFail_ (testRule cdlc) "a *= b." ] + where + r1 = "a += b." + + cdlc = DLC { dlc_opertab = dlc_opertab defDLC + , dlc_aggrs = fmap BU.fromString (string "+=") + } ------------------------------------------------------------------------}}} -- Rules {{{ @@ -203,7 +217,7 @@ progrules :: ByteString -> [Spanned Rule] progrules = unsafeParse (many (spanned (testRule defDLC)) <* eof) oneshotRules :: ByteString -> [(RuleIx, Spanned Rule)] -oneshotRules = xlate . unsafeParse (oneshotDynaParser) +oneshotRules = xlate . unsafeParse (oneshotDynaParser Nothing) where xlate (PDP rs _) = map (\(i,_,sr) -> (i,sr)) rs