{-# LANGUAGE TupleSections #-}
module Dyna.Analysis.ANF (
- ANFState(..), FRule(..),
+ ANFState(..), Rule(..),
normTerm, normRule, runNormalize, printANF
) where
------------------------------------------------------------------------}}}
-- 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 {{{
------------------------------------------------------------------------}}}
-- 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)
------------------------------------------------------------------------}}}
-- 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
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
-}
{-
-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
--
-- 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
$ "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"
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
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?"
-- 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,
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 ((<>))
| 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 {{{
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 {{{
nullaryStar :: DeltaParsing m => m (Spanned Term)
nullaryStar = spanned $ flip TFunctor [] <$> (bsf $ string "*")
+ <* (notFollowedBy $ char '(')
term :: DeltaParsing m => m (Spanned Term)
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)
--
-- 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 ]
-- | 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
-- 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 {{{
<* 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
------------------------------------------------------------------------}}}
TermF(..), DTermV, DVar, DFunct, DFunctAr, DTerm,
-- * Rules
- DAgg, DRule(..),
+ DAgg, {- DRule(..), -}
-- * Convenience re-export
UTerm(..)
type DAgg = B.ByteString
+{-
data DRule = Rule !DTerm !DAgg ![DTerm] !DTerm
deriving (Show)
+-}
------------------------------------------------------------------------}}}
projects / dyna2 / commitdiff