--- /dev/null
+---------------------------------------------------------------------------
+-- | Common, basic definitions of our Analysis modules
+--
+-- Much of this is pending rework once we get to the mode system of Mercury.
+
+module Dyna.Analysis.Base (
+ -- * Normalized Term Representations
+ NT(..), FDT, NTV, ENF, EVF,
+
+ -- * Modes
+ Mode(..), Moded(..), modeOf, isBound, isFree,
+ ModedVar, varOfMV, ModedNT, evnOfMNT, ntvOfMNT,
+
+ -- * DOpAMine
+ DOpAMine(..),
+
+ -- * Determinism
+ Det(..), detOfDop,
+) where
+
+import qualified Data.ByteString as B
+import Dyna.Term.TTerm
+import qualified Text.PrettyPrint.Free as PP
+
+------------------------------------------------------------------------}}}
+-- Normalized Term Representations {{{
+
+-- | A Normalized Term, parametric in the variable case
+--
+-- The Ord instance is solely for Data.Set's use
+data NT v = NTNumeric (Either Integer Double)
+ | NTString B.ByteString
+ | NTVar v
+ deriving (Eq,Ord,Show)
+
+instance (PP.Pretty v) => PP.Pretty (NT v) where
+ pretty (NTNumeric (Left x)) = PP.pretty x
+ pretty (NTNumeric (Right x)) = PP.pretty x
+ pretty (NTString s) = PP.dquotes (PP.pretty s)
+ pretty (NTVar v) = PP.pretty v
+
+
+-- | Normalized Term over 'DVar' (that is, either a primitive or a variable)
+type NTV = NT DVar
+
+-- | Flat Dyna Term (that is, a functor over variables)
+type FDT = (DFunct,[DVar])
+
+-- | Either a variable or a functor of variables)
+type EVF = Either DVar FDT
+
+-- | Either a constant, another variable, or a flat Dyna term
+type ENF = Either NTV FDT
+
+------------------------------------------------------------------------}}}
+-- Modes {{{
+
+data Mode = MBound | MFree deriving (Eq,Ord,Show)
+
+
+data Moded v = MF DVar
+ | MB v
+ deriving (Eq,Ord,Show)
+
+modeOf :: Moded a -> Mode
+modeOf (MF _) = MFree
+modeOf (MB _) = MBound
+
+isBound, isFree :: Moded a -> Bool
+isBound = (== MBound) . modeOf
+isFree = (== MFree ) . modeOf
+
+type ModedVar = Moded DVar
+
+varOfMV :: ModedVar -> DVar
+varOfMV (MF x) = x
+varOfMV (MB x) = x
+
+type ModedNT = NT (ModedVar)
+
+evnOfMNT :: ModedNT -> Either DVar NTV
+evnOfMNT (NTVar mv) = case mv of
+ MB v -> Right (NTVar v)
+ MF v -> Left v
+evnOfMNT (NTString s) = Right (NTString s)
+evnOfMNT (NTNumeric n) = Right (NTNumeric n)
+
+ntvOfMNT :: ModedNT -> NTV
+ntvOfMNT (NTVar mx) = NTVar $ varOfMV mx
+ntvOfMNT (NTString s) = NTString s
+ntvOfMNT (NTNumeric n) = NTNumeric n
+
+------------------------------------------------------------------------}}}
+-- DOpAMine {{{
+
+-- | Dyna OPerational Abstract MachINE
+--
+-- It makes us happy.
+
+-- Opcode Out In Ancillary
+data DOpAMine fbs
+ = OPAsgn DVar NTV -- -+
+ | OPCheq DVar DVar -- ++
+
+ -- | Check that two dvars are not equal. This is used to
+ -- prevent double-counting of hyper-edges when any of their
+ -- tails can be made to be the same item by specialization.
+ --
+ -- XXX While inspired by Blatz & Eisner 2006, it's unclear
+ -- that this is actually what we should be doing. Oh well,
+ -- live and learn.
+ | OPCkne DVar DVar -- ++
+
+ | OPPeel [DVar] DVar DFunct -- -+
+ | OPWrap DVar [DVar] DFunct -- -+
+
+ | OPIter (ModedVar) [ModedVar] DFunct -- ??
+ Det
+ (Maybe fbs)
+ | OPIndr DVar DVar -- -+
+ deriving (Eq,Ord,Show)
+
+------------------------------------------------------------------------}}}
+-- Determinism {{{
+
+data Det = Det -- ^ Exactly one answer
+ | DetSemi -- ^ At most one answer
+ | DetNon -- ^ Unknown number of answers
+ deriving (Eq,Ord,Show)
+
+detOfDop :: DOpAMine fbs -> Det
+detOfDop x = case x of
+ OPAsgn _ _ -> Det
+ OPCheq _ _ -> DetSemi
+ OPCkne _ _ -> DetSemi
+ OPPeel _ _ _ -> DetSemi
+ OPWrap _ _ _ -> Det
+ OPIndr _ _ -> DetSemi
+ OPIter _ _ _ d _ -> d
+
+------------------------------------------------------------------------}}}
Crux(..),
- DOpAMine(..), detOfDop,
-
Action, Cost, Det(..), planInitializer, planEachEval,
adornedQueries
import qualified Data.Set as S
import qualified Debug.Trace as XT
import Dyna.Analysis.ANF
+import Dyna.Analysis.Base
import Dyna.Term.TTerm
import Dyna.Main.Exception
import qualified Dyna.ParserHS.Parser as DP
------------------------------------------------------------------------}}}
-- Modes {{{
-data Mode = MBound | MFree deriving (Eq,Ord,Show)
-
-- | What things have thus far been bound under the plan?
type BindChart = S.Set DVar
varMode :: BindChart -> DVar -> Mode
varMode c v = if v `S.member` c then MBound else MFree
-data Moded v = MF DVar
- | MB v
- deriving (Eq,Ord,Show)
-
-modeOf :: Moded a -> Mode
-modeOf (MF _) = MFree
-modeOf (MB _) = MBound
-
-isBound, isFree :: Moded a -> Bool
-isBound = (== MBound) . modeOf
-isFree = (== MFree ) . modeOf
-
-type ModedVar = Moded DVar
-
modedVar :: BindChart -> DVar -> ModedVar
modedVar b x = case varMode b x of
MBound -> MB x
MFree -> MF x
-varOfMV :: ModedVar -> DVar
-varOfMV (MF x) = x
-varOfMV (MB x) = x
-
-type ModedNT = NT (ModedVar)
-
modedNT :: BindChart -> NTV -> ModedNT
modedNT b (NTVar v) = NTVar $ modedVar b v
modedNT _ (NTString s) = NTString s
modedNT _ (NTNumeric x) = NTNumeric x
-evnOfMNT :: ModedNT -> Either DVar NTV
-evnOfMNT (NTVar mv) = case mv of
- MB v -> Right (NTVar v)
- MF v -> Left v
-evnOfMNT (NTString s) = Right (NTString s)
-evnOfMNT (NTNumeric n) = Right (NTNumeric n)
-
-ntvOfMNT :: ModedNT -> NTV
-ntvOfMNT (NTVar mx) = NTVar $ varOfMV mx
-ntvOfMNT (NTString s) = NTString s
-ntvOfMNT (NTNumeric n) = NTNumeric n
-
------------------------------------------------------------------------}}}
-- Cruxes {{{
cruxIsEval (CFCall _ _ _) = True
cruxIsEval _ = False
-------------------------------------------------------------------------}}}
--- DOpAMine {{{
-
--- | Dyna OPerational Abstract MachINE
---
--- It makes us happy.
-
--- Opcode Out In Ancillary
-data DOpAMine = OPAssign DVar NTV -- -+
- | OPCheck DVar DVar -- ++
-
- -- | Check that two dvars are not equal. This is used to
- -- prevent double-counting of hyper-edges when any of their
- -- tails can be made to be the same item by specialization.
- --
- -- XXX While inspired by Blatz & Eisner 2006, it's unclear
- -- that this is actually what we should be doing. Oh well,
- -- live and learn.
- | OPCheckNE DVar DVar -- ++
-
- | OPGetArgsIf [DVar] DVar DFunct -- -+
- | OPBuild DVar [DVar] DFunct -- -+
-
- -- XXX OPCall and OPIter are actually the same thing,
- -- in the end. OPCall is just the MF+[MB] variant
- -- of OPIter; at the moment we use them to distinguish
- -- builtins, but that's wrong.
- | OPCall DVar [DVar] DFunct -- -+
- | OPIter (ModedVar) [ModedVar] DFunct -- ??
- | OPIndirEval DVar DVar -- -+
- deriving (Eq,Ord,Show)
-
-data Det = Det -- ^ Exactly one answer
- | DetSemi -- ^ At most one answer
- | DetNon -- ^ Unknown number of answers
- deriving (Eq,Ord,Show)
-
-detOfDop :: DOpAMine -> Det
-detOfDop x = case x of
- OPAssign _ _ -> Det
- OPCheck _ _ -> DetSemi
- OPCheckNE _ _ -> DetSemi
- OPGetArgsIf _ _ _ -> DetSemi
- OPBuild _ _ _ -> Det
- OPIndirEval _ _ -> DetSemi
- OPCall _ _ _ -> Det
- OPIter o is _ -> -- XXX
- case (modeOf o, foldr min MBound (map modeOf is)) of
- (_, MBound) -> DetSemi
- _ -> DetNon
-
------------------------------------------------------------------------}}}
-- Actions {{{
-type Action = [DOpAMine]
+type Action fbs = [DOpAMine fbs]
--- XXX we shouldn't need to know this
---
--- XXX please observe duplication of knowledge with
--- Dyna.Analysis.ANF.dynaFunctorArgDispositions
+-- XXX Is this really the right type? Maybe we'd rather that this be a
+-- function rather than a map?
--
--- XXX Also cross-reference python backend
-isMath f = f `elem` [ "^", "+", "-", "*", "/", "&", "|", "~"
- , "%", "**", "<", ">", "<<", ">>"
- , "log", "exp", "and", "or", "not"]
-
--- XXX This function really ought to be generated from some declarations in
--- the source program, rather than hard-coded in quite the way it is.
--- Maybe the knowledge of unification is OK.
-possible :: Crux (ModedVar) (ModedNT) -> [Action]
-possible cr = case cr of
+-- Note that there's a big wad of complexity here: we want to announce, for
+-- example, that predicates may support generation (full-minus moding) but
+-- that they can take bound variables, or that some predicates may insist
+-- upon being run in mode minus, necessitating the insertion of checks.
+-- (Primitives, unfortunately, fall into the latter category! We have to
+-- run +/2 and then check the output, for example). Right now, the backend
+-- is responsible for dealing with the check insertions. That might be
+-- wrong.
+type BackendPossible fbs = (DFunct,[Mode],Mode) -> Either Bool (Det,fbs)
+
+type Possible fbs = Crux (ModedVar) (ModedNT) -> [Action fbs]
+
+{-
+mapMaybeModeCompat mis mo =
+ MA.mapMaybe (\(is',o',d,f) -> do
+ guard $ modeOf mo <= o'
+ && length mis == length is'
+ && and (zipWith (\x y -> modeOf x <= y) mis is')
+ return (d,f))
+-}
+
+possible :: BackendPossible fbs -> Possible fbs
+possible fp cr = case cr of
-- XXX Indirect evaluation is not yet supported
CFEval _ _ -> []
case (evnOfMNT i, o) of
(Left _, MF _) -> []
(Right _, MB o') -> let chk = "_chk" in
- [[ OPAssign chk ni
- , OPCheck chk o']]
- (Left i', MB o') -> [[OPAssign i' (NTVar o')]]
- (Right _, MF o') -> [[OPAssign o' ni]]
+ [[ OPAsgn chk ni
+ , OPCheq chk o']]
+ (Left i', MB o') -> [[OPAsgn i' (NTVar o')]]
+ (Right _, MF o') -> [[OPAsgn o' ni]]
-- Structure building
CFStruct o is funct ->
-- If the output is free, the only supported case is when all
-- inputs are known.
MF o' -> if all isBound is
- then [[OPBuild o' (map varOfMV is) funct]]
+ then [[OPWrap o' (map varOfMV is) funct]]
else []
-- On the other hand, if the output is known, then any subset
-- of the inputs may be known and will be checked.
- MB o' -> [ (OPGetArgsIf is' o' funct)
- : map (\(c,x) -> (OPCheck c x)) cis
+ MB o' -> [ (OPPeel is' o' funct)
+ : map (\(c,x) -> (OPCheq c x)) cis
]
where
mkChks _ (MF i) = (i, Nothing)
-- Unification
CFUnif (MF _) (MF _) -> []
- CFUnif (MB x) (MB y) -> [[OPCheck x y]]
- CFUnif (MB x) (MF y) -> [[OPAssign y (NTVar x)]]
- CFUnif (MF y) (MB x) -> [[OPAssign y (NTVar x)]]
-
- -- Backward-chainable mathematics (this is such a hack XXX)
- CFCall o is funct | isMath funct ->
- if not $ all isBound is
- then inv funct is o
- else let is' = map varOfMV is in
- case o of
- MF o' -> [[OPCall o' is' funct]]
- MB o' -> let cv = "_chk"
- in [[OPCall cv is' funct
- ,OPCheck cv o'
- ]]
-
- -- Otherwise, we assume it's an extensional table and ask to iterate
- -- over it.
- CFCall o is funct | otherwise -> [[OPIter o is funct]]
+ CFUnif (MB x) (MB y) -> [[OPCheq x y]]
+ CFUnif (MB x) (MF y) -> [[OPAsgn y (NTVar x)]]
+ CFUnif (MF y) (MB x) -> [[OPAsgn y (NTVar x)]]
- where
+ CFCall o is funct -> case fp (funct,map modeOf is, modeOf o) of
+ Left False -> [[OPIter o is funct DetNon Nothing ]]
+ Left True -> []
+ Right (d,f) -> [[OPIter o is funct d (Just f)]]
+ where
+{-
-- XXX this really ought to be done some other way
inv :: DFunct -> [ModedVar] -> ModedVar -> [Action]
inv "+" [(MB x), (MF y)] (MB o)
= [[ OPCall x [o,y] "+" ]]
inv _ _ _ = []
+-}
------------------------------------------------------------------------}}}
-- ANF to Cruxes {{{
-- XXX I don't understand why this heuristic works, but it seems to exclude
-- some of the... less intelligent plans.
-simpleCost :: PartialPlan -> Action -> Cost
+simpleCost :: PartialPlan fbs -> Action fbs -> Cost
simpleCost (PP { pp_score = osc, pp_plan = pfx }) act =
2 * osc + (1 + loops pfx) * actCost act
where
actCost = sum . map stepCost
- stepCost :: DOpAMine -> Double
+ stepCost :: DOpAMine fbs -> Double
stepCost x = case x of
- OPAssign _ _ -> 1
- OPCheck _ _ -> -1 -- Checks are issued with Assigns, so
+ OPAsgn _ _ -> 1
+ OPCheq _ _ -> -1 -- Checks are issued with Assigns, so
-- counter-act the cost to encourage them
-- to be earlier in the plan.
- OPCheckNE _ _ -> 0
- OPGetArgsIf _ _ _ -> 0
- OPBuild _ _ _ -> 1 -- Upweight building due to side-effects
+ OPCkne _ _ -> 0
+ OPPeel _ _ _ -> 0
+ OPWrap _ _ _ -> 1 -- Upweight building due to side-effects
-- in the intern table
- OPCall _ _ _ -> 0
- OPIter o is _ -> 2 ** (fromIntegral $ length $ filter isFree (o:is))
- - 1
- OPIndirEval _ _ -> 100
+ OPIter o is _ d _ -> case d of
+ Det -> 0
+ DetSemi -> 1
+ DetNon -> 2 ** (fromIntegral $ length $
+ filter isFree (o:is))
+ - 1
+ OPIndr _ _ -> 100
loops = fromIntegral . length . filter isLoop
- isLoop :: DOpAMine -> Bool
+ isLoop :: DOpAMine fbs -> Bool
isLoop = (== DetNon) . detOfDop
------------------------------------------------------------------------}}}
-- Planning {{{
-data PartialPlan = PP { pp_cruxes :: S.Set (Crux DVar NTV)
- , pp_binds :: BindChart
- , pp_restrictSearch :: Bool
- , pp_score :: Cost
- , pp_plan :: Action
- }
+data PartialPlan fbs = PP { pp_cruxes :: S.Set (Crux DVar NTV)
+ , pp_binds :: BindChart
+ , pp_restrictSearch :: Bool
+ , pp_score :: Cost
+ , pp_plan :: Action fbs
+ }
stepPartialPlan ::
-- | Possible actions
- (Crux (ModedVar) (ModedNT) -> [Action])
+ Possible fbs
-- | Plan scoring function
- -> (PartialPlan -> Action -> Cost)
+ -> (PartialPlan fbs -> Action fbs -> Cost)
-- | The 'DFunctAr', intern representation, and
-- result variable of the
-- a given crux is "before" or "after" the initial one
-- in this ordering.
-> Maybe (DFunctAr, DVar, DVar)
- -> PartialPlan
- -> Either (Cost, Action) [PartialPlan]
+ -> PartialPlan fbs
+ -> Either (Cost, Action fbs) [PartialPlan fbs]
stepPartialPlan steps score mic p =
if S.null (pp_cruxes p)
then Left $ (pp_score p, pp_plan p)
Nothing -> id
Just ((f,a),i,ov) -> concatMap $ \dop ->
case dop of
- OPIter ov' ivs' f' | f' == f
+ OPIter ov' ivs' f' _ _ | f' == f
&& length ivs' == a
&& ov > varOfMV ov'
-> let cv = "_chk"
in [ dop
- , OPBuild cv (map varOfMV ivs') f'
- , OPCheckNE i cv
+ , OPWrap cv (map varOfMV ivs') f'
+ , OPCkne i cv
]
_ -> [dop]
-- XXX we're going to need to initially plan a unification crux as part of
-- backward chaining, but we don't yet.
initializeForCrux :: (Crux DVar a, DVar, DVar)
- -> ((DFunctAr, DVar, DVar), Action)
+ -> ((DFunctAr, DVar, DVar), Action fbs)
initializeForCrux (cr, hi, v) = case cr of
CFCall o is f -> ( ((f,length is), hi, o)
- , [ OPGetArgsIf is hi f, OPAssign o (NTVar v) ])
- _ -> sorryDynac "Don't know how to initially plan !CFCall"
+ , [ OPPeel is hi f, OPAsgn o (NTVar v) ])
+ _ -> dynacSorry "Don't know how to initially plan !CFCall"
-- | Given a normalized form and an initial crux, saturate the graph and
-- get a plan for doing so.
--
-- XXX This has no idea what to do about non-range-restricted rules.
-plan_ :: (Crux (ModedVar) (ModedNT) -> [Action]) -- ^ Available steps
- -> (PartialPlan -> Action -> Cost) -- ^ Scoring function
+plan_ :: Possible fbs -- ^ Available steps
+ -> (PartialPlan fbs -> Action fbs -> Cost) -- ^ Scoring function
-> ANFState -- ^ Normal form
-> Maybe (Crux DVar NTV, DVar, DVar) -- ^ Initial crux,
-- item intern, and
-- value, if any.
- -> [(Cost, Action)] -- ^ If there's a plan...
+ -> [(Cost, Action fbs)] -- ^ If there's a plan...
plan_ st sc anf mi =
let cruxes = eval_cruxes anf
++ unif_cruxes anf
}
in stepAgenda st sc mic initPlan
-plan :: (Crux (ModedVar) (ModedNT) -> [Action])
- -> (PartialPlan -> Action -> Cost)
+plan :: Possible fbs
+ -> (PartialPlan fbs -> Action fbs -> Cost)
-> ANFState
-> Maybe (Crux DVar NTV, DVar, DVar)
- -> Maybe (Cost, Action)
+ -> Maybe (Cost, Action fbs)
plan st sc anf mi =
(\x -> case x of
[] -> Nothing
plans -> Just $ argmin fst plans)
$ plan_ st sc anf mi
-planInitializer :: FRule -> Maybe (Cost,Action)
-planInitializer (FRule { fr_anf = anf }) = plan possible simpleCost anf Nothing
+planInitializer :: BackendPossible fbs -> FRule -> Maybe (Cost,Action fbs)
+planInitializer bp (FRule { fr_anf = anf }) = plan (possible bp)
+ simpleCost anf Nothing
-planEachEval :: DVar -> DVar -> FRule -> [(DFunctAr, Maybe (Cost,Action))]
-planEachEval hi v (FRule { fr_anf = anf }) =
- map (\(c,fa) -> (fa, plan possible simpleCost anf $ Just (c,hi,v)))
+planEachEval :: BackendPossible fbs
+ -> S.Set DFunctAr
+ -> DVar -> DVar -> FRule -> [(DFunctAr, Maybe (Cost,Action fbs))]
+planEachEval bp cs hi v (FRule { fr_anf = anf }) =
+ map (\(c,fa) -> (fa, plan (possible bp) simpleCost anf $ Just (c,hi,v)))
$ MA.mapMaybe (\c -> case c of
- CFCall _ is f | not $ isMath f
+ CFCall _ is f | S.notMember (f,length is) cs
-> Just $ (c,(f,length is))
_ -> Nothing )
$ eval_cruxes anf
-- XXX We really ought to be returning something about math, as well, but
-- as all that's handled specially up here...
-adornedQueries :: Action -> S.Set (DFunct,[Mode],Mode)
+adornedQueries :: Action fbs -> S.Set (DFunct,[Mode],Mode)
adornedQueries = go S.empty
where
go x [] = x
- go x ((OPIter o is f):as) =
+ go x ((OPIter o is f _ _):as) =
go (x `S.union` S.singleton (f, map modeOf is, modeOf o)) as
go x (_:as) = go x as
ntMode _ (NTNumeric _) = MBound
-}
+{-
planEachEval_ hi v (FRule { fr_anf = anf }) =
map (\(c,fa) -> (fa, plan_ possible simpleCost anf $ Just (c,hi,v)))
$ MA.mapMaybe (\c -> case c of
forM_ p (putStrLn . show)
putStrLn "")
. testPlanRule
+-}
------------------------------------------------------------------------}}}
import qualified Data.Set as S
import qualified Debug.Trace as XT
import Dyna.Analysis.ANF
+import Dyna.Analysis.Base
import Dyna.Analysis.Aggregation
import Dyna.Analysis.RuleMode
import Dyna.Main.Exception
import Text.PrettyPrint.Free
import qualified Text.Trifecta as T
-
+------------------------------------------------------------------------}}}
+-- DOpAMine Backend Information {{{
+
+constants = S.fromList
+ [ ("+",2)
+ , ("-",2)
+ , ("*",2)
+ , ("/",2)
+ , ("^",2)
+ , ("&",2)
+ , ("|",2)
+ , ("%",2)
+ , ("**",2)
+ , ("<",2)
+ , (">",2)
+ , ("<<",2)
+ , (">>",2)
+ , ("~",2)
+ , ("log",1)
+ , ("exp",1)
+ , ("and",2)
+ , ("or",2)
+ , ("not",1)
+ , ("true",0)
+ ]
+
+data PyDopeBS = PDBAsIs
+ | PDBRewrite (([ModedVar],ModedVar) -> [DOpAMine PyDopeBS])
+
+builtin (f,is,o) = case () of
+ _ | all (== MBound) is && S.member (f,length is) constants
+ -> case o of
+ MFree -> Right (Det,PDBAsIs)
+ MBound -> Right (DetSemi,
+ PDBRewrite $ \(is,o) -> let chkv = "_chk" in
+ [ OPIter (MF chkv) is f Det $ Just PDBAsIs
+ , OPCheq chkv (varOfMV o)
+ ])
+
+ _ | f == "+"
+ -> case (is,o) of
+ ([MBound,MFree],MBound) -> Right (Det,
+ PDBRewrite $ \([x,y],o) -> [OPIter y [o,x] "-" Det $ Just PDBAsIs])
+ ([MFree,MBound],MBound) -> Right (Det,
+ PDBRewrite $ \([x,y],o) -> [OPIter x [o,y] "-" Det $ Just PDBAsIs])
+ _ -> Left True
+
+ _ | f == "-"
+ -> case (is,o) of
+ ([MBound,MFree],MBound) -> Right (Det,
+ PDBRewrite $ \([x,y],o) -> [OPIter y [x,o] "-" Det $ Just PDBAsIs])
+ ([MFree,MBound],MBound) -> Right (Det,
+ PDBRewrite $ \([x,y],o) -> [OPIter x [o,y] "+" Det $ Just PDBAsIs])
+ _ -> Left True
+
+ _ | S.member (f,length is) constants -> Left True
+ _ -> Left False
------------------------------------------------------------------------}}}
-- DOpAMine Printout {{{
-pdope :: DOpAMine -> Doc e
-pdope (OPIndirEval _ _) = error "indirect evaluation not implemented"
-pdope (OPAssign v val) = pretty v <+> equals <+> pretty val
-pdope (OPCheck v val) = "if" <+> pretty v <+> "!=" <+> pretty val <> ": continue"
-pdope (OPCheckNE v val) = "if" <+> pretty v <+> "==" <+> pretty val <> ": continue"
-pdope (OPGetArgsIf vs id f) =
+pdope :: DOpAMine PyDopeBS -> Either [DOpAMine PyDopeBS] (Doc e)
+pdope (OPIndr _ _) = dynacSorry "indirect evaluation not implemented"
+pdope (OPAsgn v val) = Right $ pretty v <+> equals <+> pretty val
+pdope (OPCheq v val) = Right $ "if" <+> pretty v <+> "!=" <+> pretty val <> ": continue"
+pdope (OPCkne v val) = Right $ "if" <+> pretty v <+> "==" <+> pretty val <> ": continue"
+pdope (OPPeel vs id f) = Right $
"try:" `above` (indent 4 $
tupledOrUnderscore vs
`above` "except (TypeError, AssertionError): continue" -- you'll get a "TypeError: 'NoneType' is not iterable."
-pdope (OPBuild v vs f) = pretty v <+> equals
+pdope (OPWrap v vs f) = Right $ pretty v <+> equals
<+> "build" <> (parens $ fa f vs <> comma <> (sepBy "," $ map pretty vs))
-pdope (OPCall v vs f) = pretty v <+> equals
- <+> functorIndirect "call" f vs
- <> (tupled $ map pretty vs)
+pdope (OPIter v vs f _ (Just b)) =
+ case b of
+ PDBAsIs -> Right $ pretty (varOfMV v)
+ <+> equals
+ <+> functorIndirect "call" f vs
+ <> (tupled $ map (pretty . varOfMV) vs)
+
+ PDBRewrite rf -> Left $ rf (vs,v)
+
-pdope (OPIter o m f) =
+pdope (OPIter o m f _ Nothing) = Right $
let mo = m ++ [o] in
"for" <+> (tupledOrUnderscore $ filterBound mo)
<+> "in" <+> functorIndirect "chart" f m <> pslice mo <> colon
--
-- timv: might want to fuse these into one circuit
--
-combinePlans :: [(FRule,[(DFunctAr, Maybe (Cost,Action))])] ->
- M.Map DFunctAr [(FRule, Cost, Action)]
+combinePlans :: [(FRule,[(DFunctAr, Maybe (Cost,Action fbs))])] ->
+ M.Map DFunctAr [(FRule, Cost, Action fbs)]
combinePlans = go (M.empty)
where
go m [] = m
pretty f <> "/" <> (text $ show a))
go [] = id
- go (x:xs) = let px = pdope x
- indents = case x of OPIter _ _ _ -> True ; _ -> False
+ go (x:xs) = let indents = case x of OPIter _ _ _ d _ -> d /= Det ; _ -> False
in
- above px . (if indents then indent 4 else id) . go xs
+ case pdope x of
+ Left rw -> go (rw++xs)
+ Right px -> above px
+ . (if indents then indent 4 else id)
+ . go xs
emit = "emit" <> tupled [pretty h, pretty r]
printPlan :: Handle
-> (DFunct,Int) -- ^ Functor & arity
-> Maybe (DVar,DVar) -- ^ if update, input intern & value
- -> (FRule, Cost, Action) -- ^ rule and plan
+ -> (FRule, Cost, Action PyDopeBS) -- ^ rule and plan
-> IO ()
printPlan fh fa mu (r, cost, dope) = do -- display plan
hPutStrLn fh $ "# --"
let urs = map (\(P.LRule x T.:~ _) -> x) rs
frs = map normRule urs
initializers = MA.mapMaybe (\(f,mca) -> (\(c,a) -> (f,c,a)) `fmap` mca)
- $ map (\x -> (x, planInitializer x)) frs
+ $ map (\x -> (x, planInitializer builtin x)) frs
in do
aggm <- case buildAggMap frs of
Left e -> throw $ UserProgramError (text e)
}
cPlans <- return $! combinePlans -- crux plans
- $ map (\x -> (x, planEachEval headVar valVar x)) frs
+ $ map (\x -> (x, planEachEval builtin constants headVar valVar x)) frs
forM_ (M.toList cPlans) $ \(fa, ps) -> do -- plans aggregated by functor/arity
hPutStrLn fh ""
hPutStrLn fh $ "# =============="
projects / dyna2 / commitdiff