While rummaging about, take the opportunity to silence several warnings.
<+> "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) =
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)
------------------------------------------------------------------------}}}
-- Supported aggregations {{{
+aggrs :: S.Set String
aggrs = S.fromList
[ "max=" , "min="
, "+=" , "*="
_ | 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
-- 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)
<> (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
, "'''"]
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
`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
-- 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 ""
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)
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))
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
, _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)
}
$(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:"
, _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
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: "
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]
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)
------------------------------------------------------------------------}}}
-- 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
------------------------------------------------------------------------}}}
-- 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
, 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.
--
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
------------------------------------------------------------------------}}}
-- 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)
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)
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]
projects / dyna2 / commitdiff