renamed type FDR to FRule to match the constructor.
{-# LANGUAGE OverloadedStrings #-}
module Dyna.Analysis.ANF (
- ANFState(..), NT(..), FDT, NTV, ENF, EVF, FDR(..),
+ ANFState(..), NT(..), FDT, NTV, ENF, EVF, FRule(..),
normTerm, normRule, runNormalize, printANF
) where
------------------------------------------------------------------------}}}
-- Normalize a Rule {{{
-data FDR = FRule DVar DAgg [DVar] DVar -- timv: rename type to FRule?
+data FRule = FRule { fr_functor :: DVar -- timv: rename type to FRule?
+ , fr_aggregator :: DAgg
+ , fr_side :: [DVar]
+ , fr_result :: DVar
+ , fr_span :: T.Span
+ , fr_anf :: ANFState }
deriving (Show)
-- XXX
-normRule :: (Functor m, MonadState ANFState m, MonadReader ANFDict m)
- => T.Spanned P.Rule -- ^ Term to digest
- -> m FDR
-normRule (P.Rule h a es r T.:~ _) = do
+normRule :: T.Spanned P.Rule -- ^ Term to digest
+ -> FRule
+normRule (P.Rule h a es r T.:~ span) = uncurry ($) $ runNormalize $ do
nh <- normTerm False h >>= newUnifNT "_h"
nr <- normTerm True r >>= newUnifNT "_r"
nes <- mapM (\e -> normTerm True e >>= newUnifNT "_c") es
- return $ FRule nh a nes nr
+ return $ FRule nh a nes nr span
------------------------------------------------------------------------}}}
-- Run the normalizer {{{
------------------------------------------------------------------------}}}
-- Pretty Printer {{{
-printANF :: (FDR, ANFState) -> Doc e
-printANF ((FRule h a e result), AS {as_evals = evals, as_unifs = unifs}) =
- parens $ (pretty a)
- <+> valign [ (pretty h)
- , parens $ text "side" <+> (valign $ map pretty e)
- , parens $ text "evals" <+> (pev evals)
- , parens $ text "unifs" <+> (pun unifs)
- , parens $ text "result" <+> (pretty result)
- ]
+printANF :: FRule -> Doc e
+printANF (FRule h a s result span (AS {as_evals = evals, as_unifs = unifs})) =
+ ";;" <+> (text $ show span) `above` (
+ parens $ (pretty a)
+ <+> valign [ (pretty h)
+ , parens $ text "side" <+> (valign $ map pretty s)
+ , parens $ text "evals" <+> (pev evals)
+ , parens $ text "unifs" <+> (pun unifs)
+ , parens $ text "result" <+> (pretty result)
+ ]
+ )
where
pft :: FDT -> Doc e
testNormTerm :: Bool -> B.ByteString -> (NTV, ANFState)
testNormTerm c = runNormalize . normTerm c . unsafeParse P.dterm
-testNormRule :: B.ByteString -> (FDR, ANFState)
+testNormRule :: B.ByteString -> (FRule, ANFState)
testNormRule = runNormalize . normRule . unsafeParse P.drule
-- XXX These functions really would like to have span information, so they
-- could report which line of the source caused an error.
-procANF :: (FDR, ANFState) -> Either String (DFunctAr, DAgg)
-procANF (FRule h a _ _, AS { as_unifs = us }) =
+procANF :: FRule -> Either String (DFunctAr, DAgg)
+procANF (FRule h a _ _ _ (AS { as_unifs = us })) =
case M.lookup h us of
Nothing -> Left $ "I can't process head-variables"
Just t -> case t of
Left _ -> Left "Malformed head"
Right (f,as) -> Right ((f,length as),a)
-buildAggMap :: [(FDR, ANFState)] -> Either String AggMap
+buildAggMap :: [FRule] -> Either String AggMap
buildAggMap = go (M.empty)
where
go m [] = Right m
Crux(..),
DOpAMine(..), detOfDop,
-
+
Action, Cost, Det(..), planEachEval,
adornedQueries
plans -> Just $ L.minimumBy (O.comparing fst) plans)
$ plan_ st sc anf cr hi v
-planEachEval :: DVar -> DVar -> ANFState -> [(DFunctAr, Maybe (Cost,Action))]
-planEachEval hi v anf =
+planEachEval :: DVar -> DVar -> FRule -> [(DFunctAr, Maybe (Cost,Action))]
+planEachEval hi v (FRule { fr_anf = anf }) =
map (\(c,fa) -> (fa, plan possible simpleCost anf c hi v))
$ MA.mapMaybe (\c -> case c of
CFCall _ is f | not $ isMath f
ntMode _ (NTNumeric _) = MBound
-}
-testPlanRule x =
- let (_,anf) = runNormalize $ normRule (unsafeParse DP.drule x)
- in planEachEval "HEAD" "VALUE" anf
+testPlanRule x = planEachEval "HEAD" "VALUE" $ normRule (unsafeParse DP.drule x)
main :: IO ()
main = mapM_ (\(c,msp) -> do
--
-- timv: might want to fuse these into one circuit
--
-combinePlans :: [(FDR,[(DFunctAr, Maybe (Cost,Action))])] ->
- Either String (M.Map DFunctAr [(FDR, Cost, Action)]) -- all plans for functor/arity
- -- XXX are FDR's unique keys? what if a rule is repeated?
+combinePlans :: [(FRule,[(DFunctAr, Maybe (Cost,Action))])] ->
+ Either String (M.Map DFunctAr [(FRule, Cost, Action)]) -- all plans for functor/arity
+ -- XXX: are FDR's unique keys? suppose a rule is repeated?
combinePlans = go (M.empty)
where
go m [] = Right m
-- timv: consider flattening FRUle and ANFState
-py (cruxf,cruxa) (FRule h _ _ r) dope =
+py (cruxf,cruxa) (FRule h _ _ r span _) dope =
"@register" <> (parens $ dquotes $ pretty cruxf <> "/" <> (text $ show cruxa))
`above` "def _(_H, _V):"
`above` (indent 4 $ go dope)
emit = "emit" <> tupled [pretty h, pretty r]
+
processFile fileName = do
+ fh <- openFile (fileName ++ ".plan") WriteMode
+ processFile_ fileName fh
+ hClose fh
+
+
+processFileStdout fileName = do
+ processFile_ fileName stdout
+
+
+processFile_ fileName fh = do
pr <- T.parseFromFileEx (P.dlines <* T.eof) fileName
+
case pr of
T.Failure td -> T.display td
T.Success rs ->
let urs = map (\(P.LRule x T.:~ _) -> x) rs
- anfs = map (runNormalize . normRule) urs
+ anfs = map normRule urs
in do
aggm <- case buildAggMap anfs of -- only used for error checking?
Left e -> throw $ TLEAggPlan e -- multiple aggregators
Right a -> return a
cPlans <- case combinePlans -- crux plans
- $ map (A.second $ planEachEval headVar valVar)
- anfs of
+ $ map (\x -> (x, planEachEval headVar valVar x)) anfs of
Left e -> throw $ TLEUpdPlan e -- no plan found
Right a -> return a
- forM_ (M.toList cPlans) $ \(fa, ps) -> do
- putStrLn $ "\n# =============="
- putStrLn $ "# " ++ show fa
- forM_ ps $ \(r, cost, dope) -> do -- plans for the functor/arity
- -- XXX why has body disappeared?
- putStrLn $ "# --"
- putStrLn $ "# Cost: " ++ (show cost)
- displayIO stdout $ renderPretty 1.0 100
+ forM_ (M.toList cPlans) $ \(fa, ps) -> do -- plans aggregated by functor/arity
+ hPutStrLn fh $ "\n# =============="
+ hPutStrLn fh $ "# " ++ show fa
+ forM_ ps $ \(r, cost, dope) -> do -- display plan
+ hPutStrLn fh $ "# --"
+ hPutStrLn fh $ "# Cost: " ++ (show cost)
+ displayIO fh $ renderPretty 1.0 100
$ py fa r dope
- putStrLn ""
+ hPutStrLn fh ""
+-- hPutStrLn fh ""
- putStrLn ""
where
headVar = "_H"
valVar = "_V"
+
-- TEST: processFile "examples/cky.dyna"
------------------------------------------------------------------------}}}
contents <- B.readFile file
writeFile (file ++ ".anf")
(show $ vcat (map (\(P.LRule x T.:~ _) ->
- printANF $ runNormalize $ normRule x)
+ printANF $ normRule x)
(unsafeParse P.dlines contents))
<> line)
return ()
projects / dyna2 / commitdiff