import Dyna.Main.Defns
import Dyna.Term.Normalized
import Dyna.Term.TTerm
+import Dyna.XXX.PPrint
import Text.PrettyPrint.Free
------------------------------------------------------------------------}}}
-- | Check that the input dvar is an interned representation
-- of the given functor (and arity as computed from the list
-- length) and if so, unpack its arguments into those dvars.
- | OPPeel [DVar] DVar DFunct -- -+
+ | OPPeel [DVar] DVar DFunct Det -- -+
-- | The reverse of OPPeel
| OPWrap DVar [DVar] DFunct -- -+
OPAsgn _ _ -> Det
OPCheq _ _ -> DetSemi
OPCkne _ _ -> DetSemi
- OPPeel _ _ _ -> DetSemi
+ OPPeel _ _ _ d -> d
OPWrap _ _ _ -> Det
OPIndr _ _ -> DetSemi
OPIter _ _ _ d _ -> d
r _ (OPCheq a b) = text "OPCheq" <+> pretty a <+> pretty b
r _ (OPCkne a b) = text "OPCkne" <+> pretty a <+> pretty b
r _ (OPIndr a b) = text "OPIndr" <+> pretty a <+> pretty b
- r _ (OPPeel vs v f) = text "OPPeel" <+> pretty vs
- <+> pretty v <+> pretty f
+ r _ (OPPeel vs v f d) = text "OPPeel" <+> pretty vs
+ <+> pretty v
+ <+> pretty f
+ <+> text (show d)
r _ (OPWrap v vs f) = text "OPWrap" <+> pretty v
<+> pretty vs <+> pretty f
r e (OPIter v vs f d b) = text "OPIter"
<> maybe empty
((space <>) . braces . e v vs f d)
b
- r _ (OPEmit h v i vs) = text "OPEmit" <+> pretty h
- <+> pretty v
- <+> pretty i
- <+> pretty vs
+ r _ (OPEmit h v i vs) = text "OPEmit"
+ <+> pretty h
+ <+> pretty v
+ <+> pretty i
+ <+> fillList (map pretty vs)
------------------------------------------------------------------------}}}
import Dyna.Analysis.ANFPretty
import Dyna.Analysis.DOpAMine
import Dyna.Analysis.Mode
-import Dyna.Analysis.Mode.Execution.ContextNoAlias
-import Dyna.Analysis.Mode.Execution.FunctionsNoAlias
+import Dyna.Analysis.Mode.Execution.Context
+import Dyna.Analysis.Mode.Execution.Functions
import Dyna.Term.TTerm
import Dyna.Term.Normalized
import Dyna.Main.Exception
-- | Free, Ground, or Neither. A rather simplistic take on unification.
--
-- XXX There is nothing good about this.
-fgn :: forall a m . (Monad m, MCVT m DVar ~ VR DFunct (NIX DFunct), MCR m DVar)
+fgn :: forall a m k .
+ (Monad m, Functor m,
+ MCVT m k ~ ENKRI DFunct (NIX DFunct) k, MCR m k,
+ MCVT m DVar ~ VR DFunct (NIX DFunct) k, MCR m DVar)
=> DVar -> m a -> m a -> m a -> m a
fgn v cf cg cn = do
ff <- v `subVN` (nHide IFree)
(is', mcis) <- zipWithM maybeCheck is newvars >>= return . unzip
let cis = MA.catMaybes mcis
mapM_ bind is
- return ([ OPPeel is' o funct ] ++ map (uncurry OPCheq) cis)
+ return ([ OPPeel is' o funct DetSemi ]
+ ++ map (uncurry OPCheq) cis)
newvars = map (\n -> BC.pack $ "_chk_" ++ (show n)) [0::Int ..]
-- counter-act the cost to encourage them
-- to be earlier in the plan.
OPCkne _ _ -> 0
- OPPeel _ _ _ -> 0
+ OPPeel _ _ _ _ -> 0
OPWrap _ _ _ -> 1 -- Upweight building due to side-effects
-- in the intern table
OPIter o is _ d _ -> case d of
data PartialPlan fbs = PP { pp_cruxes :: S.Set (Crux DVar TBase)
, pp_binds :: BindChart
- , pp_restrictSearch :: Bool
, pp_score :: Cost
, pp_plan :: Actions fbs
}
stepPartialPlan poss score p =
{- XT.trace ("SPP:\n"
++ " " ++ show (pp_cruxes p) ++ "\n"
- ++ " " ++ show (pp_binds p) ++ "\n"
+ ++ show (indent 2 $ pretty $ pp_binds p) ++ "\n"
) $ -}
if S.null (pp_cruxes p)
then Left $ (pp_score p, pp_plan p)
else Right $
let rc = pp_cruxes p
- in if pp_restrictSearch p
- -- XXX I am not sure this is right
- --
- -- force consideration of non-evaluation cruxes if
- -- any nonevaluation crux has a possible move.
- -- If a non-evaluation plan exists, commit to its
- -- cheapest choice as the only option here.
- --
- -- This prevents us from considering the multitude
- -- stupid plans that begin by evaluating when they
- -- don't have to.
- then case step (S.filter (not . cruxIsEval) rc) of
- [] -> step (S.filter cruxIsEval rc)
- xs -> [argmin (flip score []) xs]
- else step rc
+ -- XXX I am not sure this is right
+ --
+ -- force consideration of non-evaluation cruxes if
+ -- any nonevaluation crux has a possible move.
+ -- If a non-evaluation plan exists, commit to its
+ -- cheapest choice as the only option here.
+ --
+ -- This prevents us from considering the multitude
+ -- stupid plans that begin by evaluating when they
+ -- don't have to.
+ in case step (S.filter (not . cruxIsEval) rc) of
+ [] -> step (S.filter cruxIsEval rc)
+ xs -> [argmin (flip score []) xs]
where
step = S.fold (\crux ps ->
- let bc = pp_binds p
- pl = pp_plan p
- plan = runIdentity $ runSIMCT (poss crux) bc
+ let pl = pp_plan p
+ plan = runIdentity $ runSIMCT (poss crux) (pp_binds p)
rc' = S.delete crux (pp_cruxes p)
- r' = (not $ cruxIsEval crux) || (pp_restrictSearch p)
in either (const ps)
- (\(act,bc') -> PP rc' bc' r' (score p act) (pl ++ act)
+ (\(act,bc') -> PP rc' bc' (score p act) (pl ++ act)
: ps)
plan
) []
planner_ st sc cr mic ictx = runAgenda
$ PP { pp_cruxes = cr
, pp_binds = ctx'
- , pp_restrictSearch = False
, pp_score = 0
, pp_plan = ip
}
-- XREF:INITPLAN
(ip,bis) = case mic of
Nothing -> ([],[])
- Just (CCall o is f, hi, ho) -> ( [ OPPeel is hi f
+ Just (CCall o is f, hi, ho) -> ( [ OPPeel is hi f DetSemi
, OPAsgn o (NTVar ho)]
, o:is)
Just (CEval o i, hi, ho) -> ( [ OPAsgn i (NTVar hi)
-- XXX contribute back to wl-pprint-extras
module Dyna.XXX.PPrint (
- prefixSD, sepBy, valign
+ fillList, fillPunct, prefixSD, sepBy, valign
) where
import qualified Data.Foldable as F
+import qualified Data.Traversable as T
import Text.PrettyPrint.Free
-- | encloseSep with empty enclosers
sepBy :: Doc e -> [Doc e] -> Doc e
sepBy = encloseSep empty empty
+-- | Align and vcat
valign :: F.Foldable f => f (Doc e) -> Doc e
valign = align . vcat
+-- | Punctuate and fill out the ribbon. You almost assuredly want to use
+-- 'align' or 'hang' with this.
+fillPunct :: (T.Traversable f) => Doc e -> f (Doc e) -> Doc e
+fillPunct p l = fillCat (punctuate p l)
+
+-- | Like 'fillPunct' but add list framing and commas and 'align'ment.
+fillList :: (T.Traversable f) => f (Doc e) -> Doc e
+fillList = brackets . align . fillPunct (comma <> space)
+
-- | Prefix all lines of a 'SimpleDoc' with a given string
prefixSD :: String -> SimpleDoc e -> SimpleDoc e
prefixSD p = pt . go
go SEmpty = SEmpty
go (SChar c s) = SChar c (go s)
go (SText i t s) = SText i t (go s)
- go x@(SLine i SEmpty) = x
+ go x@(SLine _ SEmpty) = x
go (SLine i s) = (SLine i (pt $ go s))
go (SEffect e s) = SEffect e (go s)
projects / dyna2 / commitdiff