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.

diff --git a/src/Dyna/Analysis/ANFSelftest.hs b/src/Dyna/Analysis/ANFSelftest.hs
index 08b2fc79e0ee0e256986c5a15d4b01bd5d214413..23f4a094b8c79c3b547aa9683d15bcc4a65f0a0b 100644 (file)
--- 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 786432bba1d8c8d98789cf346c2d5a036bc176f9..bec013ec0a117531adf925e1eda090dcd3e87a22 100644 (file)
--- 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 818a7af70a23482f989fd81f36d98d5dafb530b6..cf28817beff610f48e59b8ecd49c548711156359 100644 (file)
--- 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 a6714c9b12375c7728dfa293e8db5f29657033fc..493bb8b07f42326570ef14a52ae94a3c29c59f83 100644 (file)
--- 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 d664371ec64a945376250a664332f621db6f11ea..d477a2a2e2b8f67ae7d807741bcd85ae64fe7bb1 100644 (file)
--- 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 5d8d3fc48e78023a7630505e1bd014b0ded034d6..e3dd4fe36bb83df567876bdf83dfbd1b5f3aa7ef 100644 (file)
--- 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 ba854a5e3fa631a41382bc2bd0f594924f00f597..1f9ef78d54bdfcd0c6371500d7367a1ff8df86d8 100644 (file)
--- 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 ae4ad69a86c9db2dc5d5b4722d5d5a9c430c3d54..d9e2c1bc4ea99d7ace997c414d2fe72f879e49b1 100644 (file)
--- 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
--}
-
-------------------------------------------------------------------------}}}