From: Nathaniel Wesley Filardo Date: Tue, 11 Jun 2013 22:02:28 +0000 (-0400) Subject: Cleanups and preliminaries around the parser X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=a5f642791a69bcbf7ea28433078fac7bbc105fde;p=dyna2 Cleanups and preliminaries around the parser While rummaging about, take the opportunity to silence several warnings. --- diff --git a/src/Dyna/Analysis/Aggregation.hs b/src/Dyna/Analysis/Aggregation.hs index 8172cc8..cb353f4 100644 --- a/src/Dyna/Analysis/Aggregation.hs +++ b/src/Dyna/Analysis/Aggregation.hs @@ -36,8 +36,8 @@ procANF (Rule _ h _ _ sp _ crs _) = <+> "is beyond my abilities." Just t -> t -buildAggMap :: [Rule] -> AggMap -buildAggMap = go (M.empty) +buildAggMap :: AggMap -> [Rule] -> AggMap +buildAggMap = go where go m [] = m go m (ar@(Rule _ _ a _ sp _ _ _):xs) = diff --git a/src/Dyna/Backend/Python/Backend.hs b/src/Dyna/Backend/Python/Backend.hs index 85d599a..8499e36 100644 --- a/src/Dyna/Backend/Python/Backend.hs +++ b/src/Dyna/Backend/Python/Backend.hs @@ -34,8 +34,8 @@ import Dyna.Analysis.Mode import Dyna.Analysis.RuleMode import Dyna.Backend.BackendDefn import Dyna.Main.Exception +import qualified Dyna.ParserHS.Parser as P import Dyna.Term.TTerm --- import qualified Dyna.ParserHS.Parser as P import Dyna.XXX.PPrint import Dyna.XXX.MonadUtils import Dyna.XXX.Trifecta (prettySpanLoc) @@ -46,6 +46,7 @@ import Text.PrettyPrint.Free ------------------------------------------------------------------------}}} -- Supported aggregations {{{ +aggrs :: S.Set String aggrs = S.fromList [ "max=" , "min=" , "+=" , "*=" @@ -117,7 +118,10 @@ builtins (f,is,o) = case () of _ | MA.isJust (constants (f,length is)) -> Left True _ -> Left False +infixOp :: Doc e -> a -> [ModedVar] -> Doc e infixOp op _ vis = sepBy op $ mpv vis + +mpv :: [ModedVar] -> [Doc e] mpv = map (pretty . (^.mv_var)) constants :: DFunctAr -> Maybe PyDopeBS @@ -171,33 +175,40 @@ constants = go -- DOpAMine Printout {{{ -- | Print functor and arity based on argument list +pfas :: Pretty a => a -> [b] -> Doc e pfas f args = dquotes $ pretty f <> "/" <> (pretty $ length args) +pfa :: (Pretty f, Pretty n) => f -> n -> Doc e pfa f n = parens $ dquotes $ pretty f <> "/" <> pretty n -- pf f vs = pretty f <> (tupled $ map pretty vs) +functorIndirect :: Pretty a => Doc e -> a -> [b] -> Doc e functorIndirect table f vs = table <> (brackets $ pfas f vs) -- this comes up because can't assign to () -tupledOrUnderscore vs = if length vs > 0 - then parens ((sepBy "," $ map pretty vs) <> ",") - else text "_" +tupledOrUnderscore :: (Pretty a) => [a] -> Doc e +tupledOrUnderscore [] = text "_" +tupledOrUnderscore vs = parens ((sepBy "," $ map pretty vs) <> ",") +pslice :: [ModedVar] -> Doc e pslice vs = brackets $ sepBy "," (map (\x -> if nGround (x^.mv_mi) then pretty (x^.mv_var) else ":") vs) <> "," -- add a comma to ensure getitem is always passed a tuple. +ground2underscore :: ModedVar -> Doc e ground2underscore x = if nGround (x^.mv_mi) then "_" else pretty (x^.mv_var) +piterate :: [ModedVar] -> Doc e piterate vs = if length vs == 0 then "_" else parens $ sepBy "," (map ground2underscore vs) <> "," -- add a comma to ensure tuple. -filterGround = map (^.mv_var) . filter (not.nGround.(^.mv_mi)) +-- filterGround :: [ModedVar] -> [DVar] +-- filterGround = map (^.mv_var) . filter (not.nGround.(^.mv_mi)) -- | Render a single dopamine opcode or its surrogate pdope_ :: DOpAMine PyDopeBS -> State Int (Doc e) @@ -221,10 +232,18 @@ pdope_ (OPWrap v vs f) = return $ pretty v <> (parens $ pfas f vs <> comma <> (sepBy "," $ map pretty vs)) -pdope_ (OPIter v vs f Det (Just (PDBS c))) = return $ pretty (v^.mv_var) +pdope_ (OPIter v vs _ Det (Just (PDBS c))) = return $ pretty (v^.mv_var) <+> equals <+> c v vs +pdope_ (OPIter v vs f d (Just (PDBS c))) = dynacPanic $ + "Unexpected determinism flag (at python code gen):" + <+> pretty v + <+> pretty vs + <+> squotes (pretty f) + <+> text (show d) + <+> parens (pretty $ c v vs) + pdope_ (OPIter o m f _ Nothing) = do i <- incState return $ let mo = m ++ [o] in @@ -271,7 +290,7 @@ printPlanHeader r c mn = do , "'''"] printInitializer :: Handle -> Rule -> Cost -> Actions PyDopeBS -> IO () -printInitializer fh rule@(Rule _ h _ r _ _ ucruxes _) cost dope = do +printInitializer fh rule cost dope = do displayIO fh $ renderPretty 1.0 100 $ "@_initializers.append" -- <> (uncurry pfa $ MA.fromJust $ findHeadFA h ucruxes) `above` "def" <+> char '_' <> tupled ["emit"] <> colon @@ -279,9 +298,12 @@ printInitializer fh rule@(Rule _ h _ r _ _ ucruxes _) cost dope = do `above` pdope dope <> line +printUpdate :: Handle -> Rule -> Cost -> Int -> Maybe DFunctAr -> (DVar, DVar) + -> Actions PyDopeBS -> IO () -- XXX INDIR EVAL -printUpdate :: Handle -> Rule -> Cost -> Int -> Maybe DFunctAr -> (DVar, DVar) -> Actions PyDopeBS -> IO () -printUpdate fh rule@(Rule _ h _ r _ _ _ _) cost evalix (Just (f,a)) (hv,v) dope = do +printUpdate _ _ _ _ Nothing _ _ = + dynacPanic "Python backend does not know how to do indirect evaluations" +printUpdate fh rule cost evalix (Just (f,a)) (hv,v) dope = do displayIO fh $ renderPretty 1.0 100 $ "#" <+> (pfa f a) `above` "def" <+> char '_' <> tupled (map pretty [hv,v,"emit"]) <> colon @@ -301,6 +323,10 @@ driver am um {-qm-} is pr fh = do -- Parser resume state hPutStrLn fh "parser_state = \"\"\"" hPutStrLn fh $ show pr + -- XXX This is more than a little bit of a hack + mapM_ (\((f,a),agg) -> hPutStrLn fh $ show + $ P.renderPragma (P.PIAggr f a agg)) + $ M.toList am hPutStrLn fh "\"\"\"" hPutStrLn fh "" diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index c5ea94d..10ce800 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 (be_aggregators $ dcfg_backend ?dcfg) + P.PDP rs iaggmap pp <- parse (be_aggregators $ dcfg_backend ?dcfg) dump DumpParsed $ (vcat $ map (\(i,_,r) -> text $ show (i,r)) rs) @@ -310,7 +310,7 @@ processFile fileName = bracket openOut hClose go hPutDoc stderr $ vcat $ MA.mapMaybe maybeWarnANF anfWarns - aggm <- return $! buildAggMap frs + aggm <- return $! buildAggMap iaggmap frs dump DumpAgg (M.foldlWithKey (\d f a -> d `above` (pretty f <+> colon <+> pretty a)) diff --git a/src/Dyna/ParserHS/OneshotDriver.hs b/src/Dyna/ParserHS/OneshotDriver.hs index d8f7b31..49b01d6 100644 --- a/src/Dyna/ParserHS/OneshotDriver.hs +++ b/src/Dyna/ParserHS/OneshotDriver.hs @@ -41,6 +41,8 @@ import qualified Text.PrettyPrint.Free as PP data ParsedDynaProgram = PDP { pdp_rules :: [(RuleIx, DisposTab, Spanned Rule)] + , pdp_aggrs :: M.Map DFunctAr DAgg + -- | A rather ugly hack for resumable parsing: this records the set of -- pragmas to restore the current PCS. , pdp_parser_resume :: forall e . PP.Doc e @@ -55,6 +57,7 @@ data PCS = PCS , _pcs_dt_over :: DisposTabOver , _pcs_dt_cache :: DisposTab -- ^ Cache the disposition table + , _pcs_iagg_map :: M.Map DFunctAr DAgg , _pcs_instmap :: M.Map B.ByteString ([DVar] ,ParsedInst ,Span) @@ -76,16 +79,20 @@ data PCS = PCS } $(makeLenses ''PCS) +mkdlc :: Maybe (S.Set String) -> PCS -> DLCfg 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 <<~ +update_pcs_dt, + update_pcs_ot :: (Applicative m, MonadState PCS m) => m () +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) +update_pcs_ot = pcs_ot_cache <~ (flip mkEOT True <$> (use pcs_operspec)) +dtmk :: String -> DisposTabOver -> DisposTab dtmk "dyna" = disposTab_dyna dtmk "prologish" = disposTab_dyna dtmk n = dynacPanic $ "Unknown default disposition table:" @@ -107,6 +114,8 @@ defPCS = PCS { _pcs_dt_mk = "dyna" , _pcs_dt_cache = dtmk (defPCS ^. pcs_dt_mk) (defPCS ^. pcs_dt_over) + , _pcs_iagg_map = M.empty + , _pcs_instmap = mempty -- XXX , _pcs_modemap = mempty -- XXX @@ -122,13 +131,13 @@ pcsProcPragma (PDispos s f as :~ _) = do pcs_dt_over %= dtoMerge (f,length as) (s,as) update_pcs_dt return () -pcsProcPragma (PDisposDefl n :~ s) = do +pcsProcPragma (PDisposDefl n :~ _) = do pcs_dt_mk .= n update_pcs_dt return () -pcsProcPragma (PInst (PNWA n as) pi :~ s) = do +pcsProcPragma (PInst (PNWA n as) i :~ s) = do im <- use pcs_instmap - maybe (pcs_instmap %= M.insert n (as,pi,s)) + maybe (pcs_instmap %= M.insert n (as,i,s)) -- XXX fix this error message once the new trifecta lands upstream -- with its ability to throw Err. (\(_,_,s') -> unexpected $ "duplicate definition of inst: " @@ -153,16 +162,20 @@ pcsProcPragma (p :~ s) = dynacSorry $ "Cannot handle pragma" PP. "at" PP. prettySpanLoc s --- XXX +pragmasFromPCS :: PCS -> PP.Doc e 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) + -- XXX leaving out the item agg map, because that gets refined during + -- the program's execution. + -- ++ (map (\((f,a),agg) -> PIAggr f a agg) $ M.toList iaggmap) + ++ (map (\(n,(as,i,_)) -> PInst (PNWA n as) i) $ M.toList im) ++ (map (\(n,(as,pmf,pmt,_)) -> PMode (PNWA n as) pmf pmt) $ M.toList mm) ++ [PRuleIx rix] @@ -189,7 +202,7 @@ oneshotDynaParser aggs = (postProcess =<<) return $ (rix, dt, r)) <* optional (dynaWhiteSpace (someSpace)) where - postProcess (rs,pcs) = return $ PDP rs (pragmasFromPCS pcs) + postProcess (rs,pcs) = return $ PDP rs (pcs ^. pcs_iagg_map) (pragmasFromPCS pcs) ------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index 5a8c46d..1cd0421 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -117,6 +117,9 @@ data Pragma = PDispos SelfDispos B.ByteString [ArgDispos] -- Note that the override defintions are -- preserved across this operation! -- (XXX is that what we want?) + + | PIAggr B.ByteString Int B.ByteString + -- ^ Assert the aggregator for a functor/arity. | PInst NameWithArgs ParsedInst @@ -577,12 +580,13 @@ parseUniq = choice [ symbol "clobbered" *> pure UClobbered ------------------------------------------------------------------------}}} -- Parsing pragma bodies {{{ -pragmaBody :: (DeltaParsing m, LookAheadParsing m) +pragmaBody :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) => m Pragma pragmaBody = choice - [ -- try $ symbol "aggr" *> parseAggr -- XXX alternate syntax for aggr + [ symbol "dispos_def" *> parseDisposDefl -- set default dispositions , symbol "dispos" *> parseDisposition -- in-place dispositions + , symbol "iaggr" *> parseIAggr -- alternate syntax for aggr , symbol "inst" *> parseInstDecl -- instance delcarations , symbol "mode" *> parseMode -- mode/qmode decls , symbol "oper" *> parseOper -- new {pre,in,post}fix oper @@ -608,6 +612,14 @@ pragmaBody = choice , pure "dyna" ] + parseIAggr = do + f <- parseFunctor + _ <- char '/' + n <- token decimal + when (n > fromIntegral (maxBound :: Int)) $ unexpected "huge number" + a <- join $ asks dlc_aggrs + return (PIAggr f (fromIntegral n) a) + -- XXX Does not handle <= or >= forms yet, which we need for mode -- polymorphism. -- @@ -690,6 +702,12 @@ renderPragma_ (PDispos s f as) = "dispos" PP.<+> rs s ra ADQuote = "&" ra ADEval = "*" +renderPragma_ (PIAggr f a ag) = "iaggr" PP.<+> renderFunctor f + PP.<> PP.char '/' + PP.<> PP.pretty a + PP.<+> PP.pretty ag + PP.<+> PP.empty + renderPragma_ (PInst n i) = "inst" PP.<+> renderPNWA n PP.<+> renderInst i diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index 96f0157..6ee47e4 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -183,11 +183,14 @@ case_tyAnnot = e @=? (term fintx) ------------------------------------------------------------------------}}} -- Aggregators {{{ +okAggrs :: [B.ByteString] +okAggrs = ["+=", "*=", ".=", "min=", "max=", "?=", ":-", "max+=" ] + test_aggregators :: [TF.Test] test_aggregators = hUnitTestToTests $ TestList [ TestLabel "generic valid" $ TestList $ map (\x -> (BU.toString x) ~: x ~=? unsafeParse testGenericAggr x) - ["+=", "*=", ".=", "min=", "max=", "?=", ":-", "max+=" ] + okAggrs , TestLabel "generic invalid" $ TestList $ map (\x -> TestLabel (BU.toString x) $ TestCase $ checkParseFail_ testGenericAggr x) @@ -219,7 +222,7 @@ progrules = unsafeParse (many (spanned (testRule defDLC)) <* eof) oneshotRules :: ByteString -> [(RuleIx, Spanned Rule)] oneshotRules = xlate . unsafeParse (oneshotDynaParser Nothing) 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) @@ -438,6 +441,8 @@ arbPragma :: Gen Pragma arbPragma = oneof [ PDispos <$> arbSD <*> arbAtom <*> listOf arbAD , PDisposDefl <$> elements ["dyna", "prologish"] + , PIAggr <$> arbAtom <*> (getPositive <$> arbitrary) <*> (elements okAggrs) + , PRuleIx <$> (getPositive <$> arbitrary) ] where arbSD = elements [SDInherit, SDEval, SDQuote]