From: Nathaniel Wesley Filardo Date: Tue, 18 Dec 2012 21:43:57 +0000 (-0500) Subject: Plumb through first pass at rule indexing X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=9512c92c58299d800eb1e18ae56cafd89e1a7261;p=dyna2 Plumb through first pass at rule indexing While here, rename FRule to Rule and fallout --- diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 695dac2..184e78e 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -70,7 +70,7 @@ {-# LANGUAGE TupleSections #-} module Dyna.Analysis.ANF ( - ANFState(..), FRule(..), + ANFState(..), Rule(..), normTerm, normRule, runNormalize, printANF ) where @@ -346,22 +346,24 @@ normTerm c (t T.:~ s) = normTerm_ (ECFunctor,if c then ADEval else ADQuote) ------------------------------------------------------------------------}}} -- Normalize a Rule {{{ -data FRule = FRule { fr_functor :: DVar - , fr_aggregator :: DAgg - , fr_side :: [DVar] - , fr_result :: DVar - , fr_span :: T.Span - , fr_anf :: ANFState } +data Rule = Rule { r_index :: Int + , r_functor :: DVar + , r_aggregator :: DAgg + , r_side :: [DVar] + , r_result :: DVar + , r_span :: T.Span + , r_anf :: ANFState + } deriving (Show) -- XXX normRule :: T.Spanned P.Rule -- ^ Term to digest - -> FRule -normRule (P.Rule h a es r T.:~ span) = uncurry ($) $ runNormalize $ do + -> Rule +normRule (P.Rule i h a es r T.:~ span) = uncurry ($) $ runNormalize $ do nh <- normTerm False h >>= newAssignNT "_h" nr <- normTerm True r >>= newAssignNT "_r" nes <- mapM (\e -> normTerm True e >>= newAssignNT "_c") es - return $ FRule nh a nes nr span + return $ Rule i nh a nes nr span ------------------------------------------------------------------------}}} -- Run the normalizer {{{ @@ -377,10 +379,12 @@ runNormalize = ------------------------------------------------------------------------}}} -- Pretty Printer {{{ -printANF :: FRule -> Doc e -printANF (FRule h a s result span +printANF :: Rule -> Doc e +printANF (Rule i h a s result span (AS {as_evals = evals, as_assgn = assgn, as_unifs = unifs})) = text ";;" <+> prettySpanLoc span + `above` + text ";; index" <+> pretty i `above` ( parens $ (pretty a) <+> valign [ (pretty h) diff --git a/src/Dyna/Analysis/Aggregation.hs b/src/Dyna/Analysis/Aggregation.hs index eb08144..09f0ec0 100644 --- a/src/Dyna/Analysis/Aggregation.hs +++ b/src/Dyna/Analysis/Aggregation.hs @@ -23,18 +23,20 @@ type AggMap = M.Map DFunctAr DAgg ------------------------------------------------------------------------}}} -- Associate each item with an aggregator {{{ +-- XXX These functions should be rewritten to use Dyna.Main.Exception + -- XXX These functions really would like to have span information, so they -- could report which line of the source caused an error. -procANF :: FRule -> Either String (DFunctAr, DAgg) -procANF (FRule h a _ _ _ (AS { as_assgn = as })) = +procANF :: Rule -> Either String (DFunctAr, DAgg) +procANF (Rule _ h a _ _ _ (AS { as_assgn = as })) = case M.lookup h as 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 :: [FRule] -> Either String AggMap +buildAggMap :: [Rule] -> Either String AggMap buildAggMap = go (M.empty) where go m [] = Right m diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index 3bd2d9d..41e0831 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -372,14 +372,14 @@ plan st sc anf mi = plans -> Just $ argmin fst plans) $ plan_ st sc anf mi -planInitializer :: BackendPossible fbs -> FRule -> Maybe (Cost,Action fbs) -planInitializer bp (FRule { fr_anf = anf }) = plan (possible bp) - simpleCost anf Nothing +planInitializer :: BackendPossible fbs -> Rule -> Maybe (Cost,Action fbs) +planInitializer bp (Rule { r_anf = anf }) = plan (possible bp) + simpleCost anf Nothing planEachEval :: BackendPossible fbs -> S.Set DFunctAr - -> DVar -> DVar -> FRule -> [(DFunctAr, Maybe (Cost,Action fbs))] -planEachEval bp cs hi v (FRule { fr_anf = anf }) = + -> DVar -> DVar -> Rule -> [(DFunctAr, Maybe (Cost,Action fbs))] +planEachEval bp cs hi v (Rule { r_anf = anf }) = map (\(c,fa) -> (fa, plan (possible bp) simpleCost anf $ Just (c,hi,v))) $ MA.mapMaybe (\c -> case c of CFCall _ is f | S.notMember (f,length is) cs @@ -417,7 +417,7 @@ ntMode _ (NTNumeric _) = MBound -} {- -planEachEval_ hi v (FRule { fr_anf = anf }) = +planEachEval_ hi v (Rule { r_anf = anf }) = map (\(c,fa) -> (fa, plan_ possible simpleCost anf $ Just (c,hi,v))) $ MA.mapMaybe (\c -> case c of CFCall _ is f | not $ isMath f diff --git a/src/Dyna/Backend/Python.hs b/src/Dyna/Backend/Python.hs index d094a18..d021232 100644 --- a/src/Dyna/Backend/Python.hs +++ b/src/Dyna/Backend/Python.hs @@ -196,8 +196,8 @@ pf f vs = pretty f <> (tupled $ map pretty vs) -- -- timv: might want to fuse these into one circuit -- -combinePlans :: [(FRule,[(DFunctAr, Maybe (Cost,Action fbs))])] -> - M.Map DFunctAr [(FRule, Cost, Action fbs)] +combinePlans :: [(Rule,[(DFunctAr, Maybe (Cost,Action fbs))])] -> + M.Map DFunctAr [(Rule, Cost, Action fbs)] combinePlans = go (M.empty) where go m [] = m @@ -210,10 +210,10 @@ combinePlans = go (M.empty) $ "No update plan for " <+> (pretty fa) <+> "in rule at" - <+> (prettySpanLoc $ fr_span fr) + <+> (prettySpanLoc $ r_span fr) Just (c,a) -> go' xs fr ys $ mapInOrApp fa (fr,c,a) m -py (f,a) mu (FRule h _ _ r span _) dope = +py (f,a) mu (Rule _ h _ _ r span _) dope = case mu of Just (hv,v) -> "@register" @@ -245,12 +245,12 @@ py (f,a) mu (FRule h _ _ r span _) dope = printPlan :: Handle -> (DFunct,Int) -- ^ Functor & arity -> Maybe (DVar,DVar) -- ^ if update, input intern & value - -> (FRule, Cost, Action PyDopeBS) -- ^ rule and plan + -> (Rule, Cost, Action PyDopeBS) -- ^ rule and plan -> IO () printPlan fh fa mu (r, cost, dope) = do -- display plan hPutStrLn fh $ "# --" displayIO fh $ prefixSD "# " $ renderPretty 1.0 100 - $ (prettySpanLoc $ fr_span r) <> line + $ (prettySpanLoc $ r_span r) <> line hPutStrLn fh $ "# Cost: " ++ (show cost) displayIO fh $ renderPretty 1.0 100 $ py fa mu r dope <> line @@ -297,7 +297,7 @@ processFile_ fileName fh = do forM_ initializers $ \(f,c,a) -> printPlan fh (findHeadFA f) Nothing (f,c,a) where - findHeadFA (FRule h _ _ _ _ (AS { as_assgn = as })) = + findHeadFA (Rule _ h _ _ _ _ (AS { as_assgn = as })) = case M.lookup h as of Nothing -> error "No unification for head variable?" Just (Left _) -> error "NTVar head?" diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index 6eae106..549f0b4 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -25,11 +25,14 @@ -- anywhere else in the pipeline yet) -- Header material {{{ - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UndecidableInstances #-} module Dyna.ParserHS.Parser ( Term(..), dterm, dtexpr, @@ -38,10 +41,9 @@ module Dyna.ParserHS.Parser ( import Control.Applicative import Control.Monad -import Control.Monad.Trans (MonadTrans,lift) +import Control.Monad.State import qualified Data.ByteString.UTF8 as BU import qualified Data.ByteString as B -import Data.Char (isSpace) import qualified Data.CharSet as CS import qualified Data.HashSet as H import Data.Semigroup ((<>)) @@ -66,20 +68,37 @@ data Term = TFunctor !B.ByteString | TVar !B.ByteString deriving (Eq,Ord,Show) +type RuleIx = Int -- | Rules are not just terms because we want to make it very syntactically -- explicit about the head being a term (though that's not an expressivity -- concern -- just use the parenthesized texpr case) so that there is no -- risk of parsing ambiguity. -data Rule = Rule !(Spanned Term) !B.ByteString ![Spanned Term] !(Spanned Term) +data Rule = Rule !RuleIx !(Spanned Term) !B.ByteString ![Spanned Term] !(Spanned Term) deriving (Eq,Show) --- XXX The span on LRule is a little silly +-- | Smart constructor for building a rule with index +rule :: (Functor f, MonadState RuleIx f) + => f ( Spanned Term + -> B.ByteString + -> [Spanned Term] + -> Spanned Term + -> Rule) +rule = Rule <$> get + -- XXX Having one kind of Pragma is probably wrong data Line = LRule (Spanned Rule) | LPragma !(Spanned Term) deriving (Eq,Show) +------------------------------------------------------------------------}}} +-- Parser Configuration State {{{ + +{- +-- | Configuration data threaded deeply into the parser +data PC m = PC { pc_opertab :: OperatorTable m (Spanned Term) } +type PCM m a = StateT (PC m) m a +-} ------------------------------------------------------------------------}}} -- Utilities {{{ @@ -199,6 +218,11 @@ instance DeltaParsing m => DeltaParsing (DynaLanguage m) where rend = lift rend restOfLine = lift restOfLine +instance MonadState s m => MonadState s (DynaLanguage m) where + get = lift get + put = lift . put + state = lift . state + ------------------------------------------------------------------------}}} -- Atoms {{{ @@ -211,6 +235,7 @@ atom = liftA BU.fromString stringLiteralSQ nullaryStar :: DeltaParsing m => m (Spanned Term) nullaryStar = spanned $ flip TFunctor [] <$> (bsf $ string "*") + <* (notFollowedBy $ char '(') term :: DeltaParsing m => m (Spanned Term) term = token $ choice @@ -241,12 +266,14 @@ term = token $ choice -- confusion with the end-of-rule marker, which is taken to be "dot space" -- or "dot eof"). -- --- XXX is the use of isSpace here correct or do we want whiteSpace? -dotAny :: CharParsing m => m Char -dotAny = char '.' <* satisfy (not . isSpace) +-- XXX dotAny is also likely useful when we get dynabase handling, but we're +-- not there yet. +dotAny :: (TokenParsing m, Monad m) => m Char +dotAny = char '.' <* notFollowedBy whiteSpace -- | A "dot operator" is a dot followed immediately by something that looks --- like a typical operator. +-- like a typical operator. We 'lookAhead' here to avoid the case of a dot +-- by itself as being counted as an operator. dotOper :: (Monad m, TokenParsing m) => m [Char] dotOper = try (lookAhead dotAny *> identNL dynaDotOperStyle) @@ -286,6 +313,7 @@ bf f = do -- -- XXX timv suggests that this should be assocnone for binops as a quick -- fix. Eventually we should still do this properly. +termETable :: DeltaParsing m => [[Operator m (Spanned Term)]] termETable = [ [ Prefix $ uf (spanned $ bsf $ symbol "new") ] , [ Prefix $ uf (spanned $ bsf $ ident dynaPfxOperStyle) ] , [ Infix (bf (spanned $ bsf $ ident dynaOperStyle)) AssocLeft ] @@ -312,13 +340,14 @@ dtexpr = unDL texpr -- | Grab the head (term!) and aggregation operator from a line that -- we hope is a rule. -rulepfx :: DeltaParsing f => f ([Spanned Term] -> Spanned Term -> Rule) -rulepfx = Rule <$> term +rulepfx :: (MonadState RuleIx m, DeltaParsing m) + => m ([Spanned Term] -> Spanned Term -> Rule) +rulepfx = rule <*> term <* whiteSpace <*> (bsf $ ident dynaAggStyle "Aggregator") -rule :: DeltaParsing m => m Rule -rule = choice [ +parseRule :: (MonadState RuleIx m, DeltaParsing m) => m Rule +parseRule = choice [ -- HEAD OP= RESULTEXPR whenever EXPRS . (try (liftA flip rulepfx <*> texpr @@ -334,15 +363,15 @@ rule = choice [ -- timv: using ':-' as the "default" aggregator for facts is -- probably incorrect because it conflicts with '&=' and other -- logical aggregators. - , (\h@(_ :~ s) -> Rule h ":-" [] $ (TFunctor "true" [] :~ s)) <$> term + -- , term >>= \h@(_ :~ s) -> rule h ":-" [] (TFunctor "true" [] :~ s) ] <* optional (char '.') where hrss = highlight ReservedOperator . spanned . symbol -drule :: DeltaParsing m => m (Spanned Rule) -drule = unDL (spanned rule) +drule :: (MonadState RuleIx m, DeltaParsing m) => m (Spanned Rule) +drule = unDL (spanned parseRule) ------------------------------------------------------------------------}}} -- Lines {{{ @@ -354,16 +383,16 @@ dpragma = symbol ":-" <* whiteSpace <* optional (char '.') -progline :: DeltaParsing m => m (Spanned Line) +progline :: (MonadState RuleIx m, DeltaParsing m) => m (Spanned Line) progline = whiteSpace - *> spanned (choice [ LRule <$> drule + *> spanned (choice [ LRule <$> spanned parseRule , LPragma <$> dpragma ]) -dline :: DeltaParsing m => m (Spanned Line) -dline = unDL (progline <* optional whiteSpace) +dline :: (DeltaParsing m) => m (Spanned Line) +dline = evalStateT (unDL (progline <* optional whiteSpace)) 0 dlines :: DeltaParsing m => m [Spanned Line] -dlines = unDL (many (progline <* optional whiteSpace)) +dlines = evalStateT (unDL (many (progline <* optional whiteSpace))) 0 ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Term/TTerm.hs b/src/Dyna/Term/TTerm.hs index 952c402..040c6b3 100644 --- a/src/Dyna/Term/TTerm.hs +++ b/src/Dyna/Term/TTerm.hs @@ -21,7 +21,7 @@ module Dyna.Term.TTerm ( TermF(..), DTermV, DVar, DFunct, DFunctAr, DTerm, -- * Rules - DAgg, DRule(..), + DAgg, {- DRule(..), -} -- * Convenience re-export UTerm(..) @@ -64,7 +64,9 @@ instance (Eq a) => Unifiable (TermF a) where type DAgg = B.ByteString +{- data DRule = Rule !DTerm !DAgg ![DTerm] !DTerm deriving (Show) +-} ------------------------------------------------------------------------}}}