parsley-core-1.7.2.0: src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs
{-|
Module : Parsley.Internal.Backend.Analysis.Coins
Description : Coins analysis.
License : BSD-3-Clause
Maintainer : Jamie Willis
Stability : experimental
Implements the analysis path required to determine how many tokens of input a given parser
is known to consume at /least/ in order to successfully execute. This provides the needed
metadata to perform the piggybank algorithm in the machine (see
"Parsley.Internal.Backend.Machine.Types.Context" for more information.)
@since 1.5.0.0
-}
module Parsley.Internal.Backend.Analysis.Coins (coinsNeeded, reclaimable) where
import Data.Bifunctor (first)
import Parsley.Internal.Backend.Machine (Instr(..), MetaInstr(..), Handler(..), Coins, plus1, minCoins, maxCoins, zero, minus, plusNotReclaim, willConsume)
import Parsley.Internal.Common.Indexed (cata4, Fix4, Const4(..))
{-|
Calculate the number of tokens that will be consumed by a given machine.
@since 1.5.0.0
-}
coinsNeeded :: Fix4 (Instr o) xs n r a -> Coins
coinsNeeded = fst . getConst4 . cata4 (Const4 . alg True)
{-|
Calculate the number of tokens can be reclaimed by a lookAhead
@since 1.7.2.0
-}
reclaimable :: Fix4 (Instr o) xs n r a -> Coins
reclaimable = fst . getConst4 . cata4 (Const4 . alg False)
bilift2 :: (a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)
bilift2 f g (x1, y1) (x2, y2) = (f x1 x2, g y1 y2)
algCatch :: (Coins, Bool) -> (Coins, Bool) -> (Coins, Bool)
algCatch k (_, True) = k
algCatch (_, True) k = k
algCatch (k1, _) (k2, _) = (minCoins k1 k2, False)
-- Bool represents if an empty is found in a branch (of a Catch)
-- This helps to get rid of `min` being used for `Try` where min is always 0
-- (The input is needed to /succeed/, so if one branch is doomed to fail it doesn't care about coins)
alg :: Bool -> Instr o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
alg _ Ret = (zero, False)
alg _ (Push _ k) = getConst4 k -- was const False on the second parameter, I think that's probably right but a bit presumptive
alg _ (Pop k) = getConst4 k
alg _ (Lift2 _ k) = getConst4 k
alg _ (Sat _ (Const4 k)) = first plus1 k
alg _ (Call _ (Const4 k)) = first (const zero) k
alg _ (Jump _) = (zero, False)
alg _ Empt = (zero, True)
alg _ (Commit k) = getConst4 k
alg _ (Catch k h) = algCatch (getConst4 k) (algHandler h)
alg _ (Tell k) = getConst4 k
alg _ (Seek k) = getConst4 k
alg _ (Case p q) = algCatch (getConst4 p) (getConst4 q)
alg _ (Choices _ ks def) = foldr (algCatch . getConst4) (getConst4 def) ks
alg _ (Iter _ _ h) = first (const zero) (algHandler h)
alg _ (Join _) = (zero, False)
alg _ (MkJoin _ (Const4 b) (Const4 k)) = bilift2 (flip plusNotReclaim . willConsume) (||) b k
alg _ (Swap k) = getConst4 k
alg _ (Dup k) = getConst4 k
alg _ (Make _ _ k) = getConst4 k
alg _ (Get _ _ k) = getConst4 k
alg _ (Put _ _ k) = getConst4 k
alg _ (LogEnter _ k) = getConst4 k
alg _ (LogExit _ k) = getConst4 k
alg _ (MetaInstr (AddCoins _) (Const4 k)) = k
alg _ (MetaInstr (RefundCoins n) (Const4 k)) = first (maxCoins zero . (`minus` n)) k -- These were refunded, so deduct
alg _ (MetaInstr (DrainCoins n) _) = (n, False) -- Used to be `second (const False) k`, but these should be additive?
alg _ (MetaInstr (GiveBursary n) _) = (n, False) -- We know that `n` is the required for `k`
alg _ (MetaInstr (PrefetchChar _) (Const4 k)) = k
alg True (MetaInstr BlockCoins (Const4 k)) = first (const zero) k
alg False (MetaInstr BlockCoins (Const4 k)) = k
algHandler :: Handler o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
algHandler (Same _ yes _ no) = algCatch (getConst4 yes) (getConst4 no)
algHandler (Always _ k) = getConst4 k