{-|
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 :: Fix4 (Instr o) xs n r a -> Coins
coinsNeeded = (Coins, Bool) -> Coins
forall a b. (a, b) -> a
fst ((Coins, Bool) -> Coins)
-> (Fix4 (Instr o) xs n r a -> (Coins, Bool))
-> Fix4 (Instr o) xs n r a
-> Coins
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 (Const4 (Coins, Bool) xs n r a -> (Coins, Bool))
-> (Fix4 (Instr o) xs n r a -> Const4 (Coins, Bool) xs n r a)
-> Fix4 (Instr o) xs n r a
-> (Coins, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (i' :: [Type]) (j' :: Nat) k'.
 Instr o (Const4 (Coins, Bool)) i' j' k' a
 -> Const4 (Coins, Bool) i' j' k' a)
-> Fix4 (Instr o) xs n r a -> Const4 (Coins, Bool) xs n r a
forall (f :: ([Type] -> Nat -> Type -> Type -> Type)
             -> [Type] -> Nat -> Type -> Type -> Type)
       (a :: [Type] -> Nat -> Type -> Type -> Type) (i :: [Type])
       (j :: Nat) k x.
IFunctor4 f =>
(forall (i' :: [Type]) (j' :: Nat) k'.
 f a i' j' k' x -> a i' j' k' x)
-> Fix4 f i j k x -> a i j k x
cata4 ((Coins, Bool) -> Const4 (Coins, Bool) i' j' k' a
forall k1 k2 k3 k5 a (i :: k1) (j :: k2) (k4 :: k3) (l :: k5).
a -> Const4 a i j k4 l
Const4 ((Coins, Bool) -> Const4 (Coins, Bool) i' j' k' a)
-> (Instr o (Const4 (Coins, Bool)) i' j' k' a -> (Coins, Bool))
-> Instr o (Const4 (Coins, Bool)) i' j' k' a
-> Const4 (Coins, Bool) i' j' k' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Instr o (Const4 (Coins, Bool)) i' j' k' a -> (Coins, Bool)
forall o (xs :: [Type]) (n :: Nat) r a.
Bool -> Instr o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
alg Bool
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 :: Fix4 (Instr o) xs n r a -> Coins
reclaimable = (Coins, Bool) -> Coins
forall a b. (a, b) -> a
fst ((Coins, Bool) -> Coins)
-> (Fix4 (Instr o) xs n r a -> (Coins, Bool))
-> Fix4 (Instr o) xs n r a
-> Coins
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 (Const4 (Coins, Bool) xs n r a -> (Coins, Bool))
-> (Fix4 (Instr o) xs n r a -> Const4 (Coins, Bool) xs n r a)
-> Fix4 (Instr o) xs n r a
-> (Coins, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (i' :: [Type]) (j' :: Nat) k'.
 Instr o (Const4 (Coins, Bool)) i' j' k' a
 -> Const4 (Coins, Bool) i' j' k' a)
-> Fix4 (Instr o) xs n r a -> Const4 (Coins, Bool) xs n r a
forall (f :: ([Type] -> Nat -> Type -> Type -> Type)
             -> [Type] -> Nat -> Type -> Type -> Type)
       (a :: [Type] -> Nat -> Type -> Type -> Type) (i :: [Type])
       (j :: Nat) k x.
IFunctor4 f =>
(forall (i' :: [Type]) (j' :: Nat) k'.
 f a i' j' k' x -> a i' j' k' x)
-> Fix4 f i j k x -> a i j k x
cata4 ((Coins, Bool) -> Const4 (Coins, Bool) i' j' k' a
forall k1 k2 k3 k5 a (i :: k1) (j :: k2) (k4 :: k3) (l :: k5).
a -> Const4 a i j k4 l
Const4 ((Coins, Bool) -> Const4 (Coins, Bool) i' j' k' a)
-> (Instr o (Const4 (Coins, Bool)) i' j' k' a -> (Coins, Bool))
-> Instr o (Const4 (Coins, Bool)) i' j' k' a
-> Const4 (Coins, Bool) i' j' k' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Instr o (Const4 (Coins, Bool)) i' j' k' a -> (Coins, Bool)
forall o (xs :: [Type]) (n :: Nat) r a.
Bool -> Instr o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
alg Bool
False)

bilift2 :: (a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)
bilift2 :: (a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)
bilift2 a -> b -> c
f x -> y -> z
g (a
x1, x
y1) (b
x2, y
y2) = (a -> b -> c
f a
x1 b
x2, x -> y -> z
g x
y1 y
y2)

algCatch :: (Coins, Bool) -> (Coins, Bool) -> (Coins, Bool)
algCatch :: (Coins, Bool) -> (Coins, Bool) -> (Coins, Bool)
algCatch (Coins, Bool)
k (Coins
_, Bool
True) = (Coins, Bool)
k
algCatch (Coins
_, Bool
True) (Coins, Bool)
k = (Coins, Bool)
k
algCatch (Coins
k1, Bool
_) (Coins
k2, Bool
_) = (Coins -> Coins -> Coins
minCoins Coins
k1 Coins
k2, Bool
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 :: Bool -> Instr o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
alg Bool
_     Instr o (Const4 (Coins, Bool)) xs n r a
Ret                                     = (Coins
zero, Bool
False)
alg Bool
_     (Push Defunc x
_ Const4 (Coins, Bool) (x : xs) n r a
k)                              = Const4 (Coins, Bool) (x : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (x : xs) n r a
k -- was const False on the second parameter, I think that's probably right but a bit presumptive
alg Bool
_     (Pop Const4 (Coins, Bool) xs n r a
k)                                 = Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs n r a
k
alg Bool
_     (Lift2 Defunc (x -> y -> z)
_ Const4 (Coins, Bool) (z : xs) n r a
k)                             = Const4 (Coins, Bool) (z : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (z : xs) n r a
k
alg Bool
_     (Sat Defunc (Char -> Bool)
_ (Const4 (Coins, Bool)
k))                      = (Coins -> Coins) -> (Coins, Bool) -> (Coins, Bool)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Coins -> Coins
plus1 (Coins, Bool)
k
alg Bool
_     (Call MVar x
_ (Const4 (Coins, Bool)
k))                     = (Coins -> Coins) -> (Coins, Bool) -> (Coins, Bool)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Coins -> Coins -> Coins
forall a b. a -> b -> a
const Coins
zero) (Coins, Bool)
k
alg Bool
_     (Jump MVar r
_)                                = (Coins
zero, Bool
False)
alg Bool
_     Instr o (Const4 (Coins, Bool)) xs n r a
Empt                                    = (Coins
zero, Bool
True)
alg Bool
_     (Commit Const4 (Coins, Bool) xs n r a
k)                              = Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs n r a
k
alg Bool
_     (Catch Const4 (Coins, Bool) xs ('Succ n) r a
k Handler o (Const4 (Coins, Bool)) (o : xs) n r a
h)                             = (Coins, Bool) -> (Coins, Bool) -> (Coins, Bool)
algCatch (Const4 (Coins, Bool) xs ('Succ n) r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs ('Succ n) r a
k) (Handler o (Const4 (Coins, Bool)) (o : xs) n r a -> (Coins, Bool)
forall o (xs :: [Type]) (n :: Nat) r a.
Handler o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
algHandler Handler o (Const4 (Coins, Bool)) (o : xs) n r a
h)
alg Bool
_     (Tell Const4 (Coins, Bool) (o : xs) n r a
k)                                = Const4 (Coins, Bool) (o : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (o : xs) n r a
k
alg Bool
_     (Seek Const4 (Coins, Bool) xs n r a
k)                                = Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs n r a
k
alg Bool
_     (Case Const4 (Coins, Bool) (x : xs) n r a
p Const4 (Coins, Bool) (y : xs) n r a
q)                              = (Coins, Bool) -> (Coins, Bool) -> (Coins, Bool)
algCatch (Const4 (Coins, Bool) (x : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (x : xs) n r a
p) (Const4 (Coins, Bool) (y : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (y : xs) n r a
q)
alg Bool
_     (Choices [Defunc (x -> Bool)]
_ [Const4 (Coins, Bool) xs n r a]
ks Const4 (Coins, Bool) xs n r a
def)                      = (Const4 (Coins, Bool) xs n r a -> (Coins, Bool) -> (Coins, Bool))
-> (Coins, Bool)
-> [Const4 (Coins, Bool) xs n r a]
-> (Coins, Bool)
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Coins, Bool) -> (Coins, Bool) -> (Coins, Bool)
algCatch ((Coins, Bool) -> (Coins, Bool) -> (Coins, Bool))
-> (Const4 (Coins, Bool) xs n r a -> (Coins, Bool))
-> Const4 (Coins, Bool) xs n r a
-> (Coins, Bool)
-> (Coins, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4) (Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs n r a
def) [Const4 (Coins, Bool) xs n r a]
ks
alg Bool
_     (Iter MVar Void
_ Const4 (Coins, Bool) '[] One Void a
_ Handler o (Const4 (Coins, Bool)) (o : xs) n r a
h)                            = (Coins -> Coins) -> (Coins, Bool) -> (Coins, Bool)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Coins -> Coins -> Coins
forall a b. a -> b -> a
const Coins
zero) (Handler o (Const4 (Coins, Bool)) (o : xs) n r a -> (Coins, Bool)
forall o (xs :: [Type]) (n :: Nat) r a.
Handler o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
algHandler Handler o (Const4 (Coins, Bool)) (o : xs) n r a
h)
alg Bool
_     (Join ΦVar x
_)                                = (Coins
zero, Bool
False)
alg Bool
_     (MkJoin ΦVar x
_ (Const4 (Coins, Bool)
b) (Const4 (Coins, Bool)
k))        = (Coins -> Coins -> Coins)
-> (Bool -> Bool -> Bool)
-> (Coins, Bool)
-> (Coins, Bool)
-> (Coins, Bool)
forall a b c x y z.
(a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)
bilift2 ((Coins -> Int -> Coins) -> Int -> Coins -> Coins
forall a b c. (a -> b -> c) -> b -> a -> c
flip Coins -> Int -> Coins
plusNotReclaim (Int -> Coins -> Coins)
-> (Coins -> Int) -> Coins -> Coins -> Coins
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coins -> Int
willConsume) Bool -> Bool -> Bool
(||) (Coins, Bool)
b (Coins, Bool)
k
alg Bool
_     (Swap Const4 (Coins, Bool) (x : y : xs) n r a
k)                                = Const4 (Coins, Bool) (x : y : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (x : y : xs) n r a
k
alg Bool
_     (Dup Const4 (Coins, Bool) (x : x : xs) n r a
k)                                 = Const4 (Coins, Bool) (x : x : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (x : x : xs) n r a
k
alg Bool
_     (Make ΣVar x
_ Access
_ Const4 (Coins, Bool) xs n r a
k)                            = Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs n r a
k
alg Bool
_     (Get ΣVar x
_ Access
_ Const4 (Coins, Bool) (x : xs) n r a
k)                             = Const4 (Coins, Bool) (x : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (x : xs) n r a
k
alg Bool
_     (Put ΣVar x
_ Access
_ Const4 (Coins, Bool) xs n r a
k)                             = Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs n r a
k
alg Bool
_     (SelectPos PosSelector
_ Const4 (Coins, Bool) (Int : xs) n r a
k)                         = Const4 (Coins, Bool) (Int : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (Int : xs) n r a
k
alg Bool
_     (LogEnter String
_ Const4 (Coins, Bool) xs ('Succ ('Succ n)) r a
k)                          = Const4 (Coins, Bool) xs ('Succ ('Succ n)) r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs ('Succ ('Succ n)) r a
k
alg Bool
_     (LogExit String
_ Const4 (Coins, Bool) xs n r a
k)                           = Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs n r a
k
alg Bool
_     (MetaInstr (AddCoins Coins
_) (Const4 (Coins, Bool)
k))     = (Coins, Bool)
k
alg Bool
_     (MetaInstr (RefundCoins Coins
n) (Const4 (Coins, Bool)
k))  = (Coins -> Coins) -> (Coins, Bool) -> (Coins, Bool)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Coins -> Coins -> Coins
maxCoins Coins
zero (Coins -> Coins) -> (Coins -> Coins) -> Coins -> Coins
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coins -> Coins -> Coins
`minus` Coins
n)) (Coins, Bool)
k -- These were refunded, so deduct
alg Bool
_     (MetaInstr (DrainCoins Coins
n) Const4 (Coins, Bool) xs n r a
_)            = (Coins
n, Bool
False)                            -- Used to be `second (const False) k`, but these should be additive?
alg Bool
_     (MetaInstr (GiveBursary Coins
n) Const4 (Coins, Bool) xs n r a
_)           = (Coins
n, Bool
False)                            -- We know that `n` is the required for `k`
alg Bool
_     (MetaInstr (PrefetchChar Bool
_) (Const4 (Coins, Bool)
k)) = (Coins, Bool)
k
alg Bool
True  (MetaInstr MetaInstr n
BlockCoins (Const4 (Coins, Bool)
k))       = (Coins -> Coins) -> (Coins, Bool) -> (Coins, Bool)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Coins -> Coins -> Coins
forall a b. a -> b -> a
const Coins
zero) (Coins, Bool)
k
alg Bool
False (MetaInstr MetaInstr n
BlockCoins (Const4 (Coins, Bool)
k))       = (Coins, Bool)
k

algHandler :: Handler o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
algHandler :: Handler o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
algHandler (Same Bool
_ Const4 (Coins, Bool) xs n r a
yes Bool
_ Const4 (Coins, Bool) (o : xs) n r a
no) = (Coins, Bool) -> (Coins, Bool) -> (Coins, Bool)
algCatch (Const4 (Coins, Bool) xs n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) xs n r a
yes) (Const4 (Coins, Bool) (o : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (o : xs) n r a
no)
algHandler (Always Bool
_ Const4 (Coins, Bool) (o : xs) n r a
k) = Const4 (Coins, Bool) (o : xs) n r a -> (Coins, Bool)
forall a k1 (i :: k1) k2 (j :: k2) k3 (k4 :: k3) k5 (l :: k5).
Const4 a i j k4 l -> a
getConst4 Const4 (Coins, Bool) (o : xs) n r a
k