Coins.hs

{-# LANGUAGE PatternSynonyms #-}
{-|
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, pattern Zero, minus, items)
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)

algCatch :: (Coins, Bool) -> (Coins, Bool) -> (Coins, Bool)
-- if either of the two halves have an empty, then skip it
algCatch k (Zero, True) = k
algCatch (Zero, True) k = k
-- take the smaller of the two branches
algCatch (k1, _) (k2, _) = (minCoins k1 k2, False)

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

-- 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)
-- All of these move control flow to somewhere else, and this means that there can be no factoring of
-- input across them, return or not: the properties of the foreign call are not known.
alg _     Ret                                       = (Zero, False)
alg _     Call{}                                    = (Zero, False)
alg _     Iter{}                                    = (Zero, False)
alg _     Join{}                                    = (Zero, False) -- this is zero because a DrainCoins is generated just in front!
alg _     Empt                                      = (Zero, True)
-- all of these instructions have no effect on the coins of their continuation, and are just transitive
alg _     (Push _ (Const4 k))                       = k
alg _     (Pop (Const4 k))                          = k
alg _     (Lift2 _ (Const4 k))                      = k
alg _     (Commit (Const4 k))                       = k
alg _     (Tell (Const4 k))                         = k
alg _     (Seek (Const4 k))                         = k
alg _     (MkJoin _ _ (Const4 k))                   = k
alg _     (Swap (Const4 k))                         = k
alg _     (Dup (Const4 k))                          = k
alg _     (Make _ _ (Const4 k))                     = k
alg _     (Get _ _ (Const4 k))                      = k
alg _     (SelectPos _ (Const4 k))                  = k
alg _     (LogEnter _ (Const4 k))                   = k
alg _     (LogExit _ (Const4 k))                    = k
alg _     (MetaInstr (AddCoins _) (Const4 k))       = k
-- cannot allow factoring through a put, because it could stop it from executing
-- but this is done in code gen via a Block, which can be disabled
alg _     (Put _ _ (Const4 k))                      = k
-- reading a character obviously contributes a single coin to the total along with its predicate
alg _     (Sat p (Const4 k))                        = first (plus1 p) k
alg _     (Catch k h)                               = algCatch (getConst4 k) (algHandler h)
alg _     (Case p q)                                = algCatch (getConst4 p) (getConst4 q)
alg _     (Choices _ ks def)                        = foldr (algCatch . getConst4) (getConst4 def) ks
-- as these coins are refunded in `k`, they should be deducted from the required coins for `k`
alg _     (MetaInstr (RefundCoins n) (Const4 k))    = first (`minus` n) k -- TODO: minus could actually keep the predicate knowledge for intersection?
-- we want these propagated out so that they commute across a factored boundary
alg _     (MetaInstr (DrainCoins n) _)              = (items n, False)
-- no point in propagating forward, these are at the front of a binding
alg _     (MetaInstr (GiveBursary _) _)             = (Zero, False)
-- this is the instruction that actions a cut by blocking all coins from traversing it
-- however, this can be disabled when processing a lookahead, unless its strong
alg False (MetaInstr (BlockCoins False) (Const4 k)) = k
alg _  (MetaInstr BlockCoins{} (Const4 k))          = first (const Zero) k