From eabfdf13f52a18d3c87c893be5b3b95874c83b4f Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Tue, 4 Jun 2013 19:56:52 -0400 Subject: [PATCH] More parser work Attempts to serialize parser state as a wad of pragmas and hand them off to the backend. This is hardly ideal, but it's something. --- src/Dyna/Analysis/ANFSelftest.hs | 7 ++++++- src/Dyna/Backend/BackendDefn.hs | 10 ++++++---- src/Dyna/Backend/NoBackend.hs | 2 +- src/Dyna/Backend/Python/Backend.hs | 2 +- src/Dyna/Main/Driver.hs | 8 +++++--- src/Dyna/ParserHS/OneshotDriver.hs | 26 +++++++++++++++++++------- src/Dyna/ParserHS/Parser.hs | 12 +++++++++--- src/Dyna/ParserHS/Selftest.hs | 22 +++------------------- 8 files changed, 50 insertions(+), 39 deletions(-) diff --git a/src/Dyna/Analysis/ANFSelftest.hs b/src/Dyna/Analysis/ANFSelftest.hs index 08b2fc7..23f4a09 100644 --- a/src/Dyna/Analysis/ANFSelftest.hs +++ b/src/Dyna/Analysis/ANFSelftest.hs @@ -16,19 +16,24 @@ module Dyna.Analysis.ANFSelftest where import qualified Data.ByteString as B import qualified Data.List as L import qualified Data.Map as M +import Data.Monoid import qualified Text.Trifecta as T import Text.PrettyPrint.Free import Dyna.Analysis.ANF +import qualified Dyna.ParserHS.OneshotDriver as PD import qualified Dyna.ParserHS.Parser as P import Dyna.ParserHS.Selftest import Dyna.Term.Normalized +import Dyna.Term.SurfaceSyntax import Dyna.Term.TTerm import Dyna.XXX.TrifectaTest testNormRule :: B.ByteString -> (Rule, ANFWarns) -testNormRule = normRule . unsafeParse P.rawDRule +testNormRule s = normRule ( 0 + , disposTab_dyna mempty + , unsafeParse (T.spanned (P.testRule defDLC)) s) {- e1 = testNormRule "f(X)." diff --git a/src/Dyna/Backend/BackendDefn.hs b/src/Dyna/Backend/BackendDefn.hs index 786432b..bec013e 100644 --- a/src/Dyna/Backend/BackendDefn.hs +++ b/src/Dyna/Backend/BackendDefn.hs @@ -16,17 +16,19 @@ import Dyna.Analysis.RuleMode ( UpdateEvalMap {-, QueryEvalMap -}) import Dyna.Term.TTerm (DFunctAr) import System.IO (Handle) +import qualified Text.PrettyPrint.Free as PP -- XXX The notion of be_constants is not quite right, I think? It is used -- only in Dyna.Analysis.RuleMode.planEachEval to avoid generating some -- plans, but that's not really how we should be doing it. The right -- answer, of course, is to use update mode information, once we have it. -type BackendDriver bs = AggMap -- ^ Aggregation - -> UpdateEvalMap bs -- ^ Rule update - -- -> QueryEvalMap bs -- ^ Rule query +type BackendDriver bs = AggMap -- ^ Aggregation + -> UpdateEvalMap bs -- ^ Rule update + -- -> QueryEvalMap bs -- ^ Rule query -> [(Rule,Cost,Actions bs)] -- ^ Initializers - -> Handle -- ^ Output + -> (forall e . PP.Doc e) -- ^ Parser persistence + -> Handle -- ^ Output -> IO () data Backend = forall bs . Backend diff --git a/src/Dyna/Backend/NoBackend.hs b/src/Dyna/Backend/NoBackend.hs index 818a7af..cf28817 100644 --- a/src/Dyna/Backend/NoBackend.hs +++ b/src/Dyna/Backend/NoBackend.hs @@ -41,7 +41,7 @@ noBackend = Backend , be_driver = driver } -driver am um {-_-} is fh = hPutStrLn fh "No backend selected; stopping." +driver _ _ {-_-} _ _ fh = hPutStrLn fh "No backend selected; stopping." ------------------------------------------------------------------------}}} -- Primitive operations {{{ diff --git a/src/Dyna/Backend/Python/Backend.hs b/src/Dyna/Backend/Python/Backend.hs index a6714c9..493bb8b 100644 --- a/src/Dyna/Backend/Python/Backend.hs +++ b/src/Dyna/Backend/Python/Backend.hs @@ -274,7 +274,7 @@ printUpdate fh rule@(Rule _ h _ r _ _ _ _) cost evalix (Just (f,a)) (hv,v) dope -- Driver {{{ driver :: BackendDriver PyDopeBS -driver am um {-qm-} is fh = do +driver am um {-qm-} is pp fh = do -- Aggregation mapping forM_ (M.toList am) $ \((f,a),v) -> do hPutStrLn fh $ show $ "agg_decl" diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index d664371..d477a2a 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -249,9 +249,11 @@ processFile fileName = bracket openOut hClose go maybeWarnANF xs = Just $ vcat $ map (uncurry renderSpannedWarn) xs go out = do - P.PDP rs _ <- parse + P.PDP rs pp <- parse - dump DumpParsed (vcat $ map (\(i,_,r) -> text $ show (i,r)) rs) + dump DumpParsed $ + (vcat $ map (\(i,_,r) -> text $ show (i,r)) rs) + <> line <> pp let (frs, anfWarns) = unzip $ map normRule rs @@ -292,7 +294,7 @@ processFile fileName = bracket openOut hClose go dump DumpDopUpd (renderDopUpds be_ddi uPlans') -- Invoke the backend code generator - be_d aggm uPlans' {- qPlans -} initializers' out + be_d aggm uPlans' {- qPlans -} initializers' pp out parse = do pr <- T.parseFromFileEx (P.oneshotDynaParser <* T.eof) fileName diff --git a/src/Dyna/ParserHS/OneshotDriver.hs b/src/Dyna/ParserHS/OneshotDriver.hs index 5d8d3fc..e3dd4fe 100644 --- a/src/Dyna/ParserHS/OneshotDriver.hs +++ b/src/Dyna/ParserHS/OneshotDriver.hs @@ -67,18 +67,20 @@ data PCS = PCS -- -- XXX add arity to key? , _pcs_operspec :: OperSpec - , _pcs_opertab :: EOT + , _pcs_ot_cache :: EOT -- ^ Cache the operator table so we are not rebuilding it -- before every parse operation , _pcs_ruleix :: RuleIx } $(makeLenses ''PCS) -_pcs_dlc pcs = DLC (_pcs_opertab pcs) +_pcs_dlc pcs = DLC (_pcs_ot_cache pcs) update_pcs_dt = pcs_dt_cache <<~ liftA2 ($) (uses pcs_dt_mk dtmk) (use pcs_dt_over) +update_pcs_ot = pcs_ot_cache <<~ flip mkEOT True <$> (use pcs_operspec) + dtmk "dyna" = disposTab_dyna dtmk "prologish" = disposTab_dyna dtmk n = dynacPanic $ "Unknown default disposition table:" @@ -104,7 +106,7 @@ defPCS = PCS { _pcs_dt_mk = "dyna" , _pcs_modemap = mempty -- XXX , _pcs_operspec = defOperSpec - , _pcs_opertab = mkEOT (defPCS ^. pcs_operspec) True + , _pcs_ot_cache = mkEOT (defPCS ^. pcs_operspec) True , _pcs_ruleix = 0 } @@ -147,7 +149,17 @@ pcsProcPragma (p :~ s) = dynacSorry $ "Cannot handle pragma" PP. prettySpanLoc s -- XXX -pragmasFromPCS pcs = empty +pragmasFromPCS (PCS dt_mk dt_over _ + im mm + om _ + rix) = + PP.vcat $ map renderPragma $ + (map (\((k,_),(s,as)) -> PDispos s k as) + $ M.toList dt_over) + ++ [PDisposDefl dt_mk] + ++ (map (\(n,(as,pi,_)) -> PInst (PNWA n as) pi) $ M.toList im) + ++ (map (\(n,(as,pmf,pmt,_)) -> PMode (PNWA n as) pmf pmt) $ M.toList mm) + ++ [PRuleIx rix] nextRule :: (DeltaParsing m, LookAheadParsing m, MonadState PCS m) => m (Spanned Rule) @@ -161,12 +173,12 @@ oneshotDynaParser :: (DeltaParsing m, LookAheadParsing m) => m ParsedDynaProgram oneshotDynaParser = (postProcess =<<) $ flip runStateT defPCS - $ many $ do + $ many (try $ do r <- nextRule rix <- pcs_ruleix <<%= (+1) dt <- use pcs_dt_cache - return $ (rix, dt, r) - <* whiteSpace + 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 ba854a5..1f9ef78 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(..), + Term(..), Rule(..), dynaWhiteSpace, -- ** Pragmas ParsedInst(..), ParsedModeInst, Pragma(..), renderPragma, -- ** Line @@ -177,6 +177,9 @@ newtype EOT = EOT { unEOT :: forall m . -- XXX Add support for Haskell-style `foo`. This requires augmenting -- the PFIn branch of interpret below to check for the ` framing and -- change the symbol returned (but not the symbol matched!) +-- +-- XXX On parser failure, we get a huge mass of cruft for "expected: ...", +-- since it blats out the entire operator table. Can we fix that? mkEOT :: OperSpec -> Bool -- ^ add some measure of fail-safety using generic -- parsers @@ -225,7 +228,7 @@ instance MonadTrans DynaLanguage where lift = DL . lift instance (TokenParsing m, MonadPlus m) => TokenParsing (DynaLanguage m) where - someSpace = buildSomeSpaceParser (lift someSpace) dynaCommentStyle + someSpace = dynaWhiteSpace (lift someSpace) semi = lift semi highlight h (DL m) = DL (highlight h m) @@ -258,6 +261,9 @@ dynaCommentStyle = CommentStyle , _commentNesting = True } +dynaWhiteSpace :: (TokenParsing m) => m () -> m () +dynaWhiteSpace m = buildSomeSpaceParser m dynaCommentStyle + ------------------------------------------------------------------------}}} -- Identifier Syles {{{ @@ -494,7 +500,7 @@ parseAggr = token rule :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) => m Rule rule = do - _ <- optional whiteSpace + _ <- whiteSpace h@(_ :~ hs) <- term choice [ do _ <- try (char '.' <* lookAhead whiteSpace) diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index ae4ad69..d9e2c1b 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -183,13 +183,14 @@ case_tyAnnot = e @=? (term fintx) ------------------------------------------------------------------------}}} -- Aggregators {{{ +test_aggregators :: [TF.Test] 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" ] + [".", ". ", "+=3", "+3=", "+=a", "+a=" ] ] ------------------------------------------------------------------------}}} @@ -430,6 +431,7 @@ arbPragma = oneof arbAtom = elements [ "f", "+" ] +prop_pragma_roundtrip :: Property prop_pragma_roundtrip = forAll arbPragma (\p -> p == unsafeParse (testPragma defDLC) (BU.fromString @@ -446,21 +448,3 @@ main :: IO () main = $(defaultMainGenerator) ------------------------------------------------------------------------}}} --- Experimental debris (XXX) {{{ - -{- -runParser :: (Show a) => (forall r . Language (Parser r String) a) -> B.ByteString -> Result TermDoc a -runParser p = parseByteString (dynafy p <* eof) M.mempty - -testParser :: (Show a) => (forall r . Language (Parser r String) a) -> String -> IO () -testParser p = parseTest (dynafy p <* eof) - -testDyna :: (Show a) => (forall r . Language (Parser r String) a) -> String -> Result TermDoc a -testDyna p i = runParser p (BU.fromString i) - -cs r e = case r of - Success w s | S.null w -> assertEqual "XXX" e s - _ -> assertBool "XXX" False --} - -------------------------------------------------------------------------}}} -- 2.50.1