Allow backends to restrict the set of acceptable aggregators.
Feed through rendered parser state.
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)
-> 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.
--
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
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
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 {{{
-- 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"
-- Export {{{
pythonBackend :: Backend
-pythonBackend = Backend builtins
+pythonBackend = Backend (Just aggrs)
+ builtins
(MA.isJust . constants)
(\o is _ _ (PDBS e) -> e o is)
driver
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)
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
-- 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
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
}
$(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)
++ [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)
-- * Parser output types
NameWithArgs(..),
-- ** Surface langauge
- Term(..), Rule(..), dynaWhiteSpace,
+ Term(..), Rule(..), dynaWhiteSpace, genericAggregators,
-- ** Pragmas
ParsedInst(..), ParsedModeInst, Pragma(..), renderPragma,
-- ** Line
-- * Action
parse,
-- * Test harness hooks
- testTerm, testAggr, testRule, testPragma,
+ testTerm, testGenericAggr, testRule, testPragma,
) where
import Control.Applicative
------------------------------------------------------------------------}}}
-- 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,
-- 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)
_ <- 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)
=> 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
_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)
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 {{{
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
projects / dyna2 / commitdiff