{-|
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) where

import Parsley.Internal.Backend.Machine (Instr(..), MetaInstr(..), Handler(..), Coins, plus1, minCoins, 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
. Instr o (Const4 (Coins, Bool)) i' j' k' a -> (Coins, Bool)
forall o (xs :: [Type]) (n :: Nat) r a.
Instr o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
alg)

first :: (a -> b) -> (a, x) -> (b, x)
first :: (a -> b) -> (a, x) -> (b, x)
first = ((a -> b) -> (x -> x) -> (a, x) -> (b, x))
-> (x -> x) -> (a -> b) -> (a, x) -> (b, x)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> (x -> x) -> (a, x) -> (b, x)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
bimap x -> x
forall a. a -> a
id

--second :: (a -> b) -> (x, a) -> (x, b)
--second = bimap id

bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
bimap = ((a -> b, c -> d) -> (a, c) -> (b, d))
-> (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((a -> b) -> a -> b)
-> ((c -> d) -> c -> d) -> (a -> b, c -> d) -> (a, c) -> (b, d)
forall a b c x y z.
(a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)
bilift2 (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($) (c -> d) -> c -> d
forall a b. (a -> b) -> a -> b
($))

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 :: Instr o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
alg :: Instr o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)
alg Instr o (Const4 (Coins, Bool)) xs n r a
Ret                                     = (Coins
zero, Bool
False)
alg (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 (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 (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 (Sat Defunc (Char -> Bool)
_ (Const4 (Coins, Bool)
k))                      = (Coins -> Coins) -> (Coins, Bool) -> (Coins, Bool)
forall a b x. (a -> b) -> (a, x) -> (b, x)
first Coins -> Coins
plus1 (Coins, Bool)
k
alg (Call MVar x
_ (Const4 (Coins, Bool)
k))                     = (Coins -> Coins) -> (Coins, Bool) -> (Coins, Bool)
forall a b x. (a -> b) -> (a, x) -> (b, x)
first (Coins -> Coins -> Coins
forall a b. a -> b -> a
const Coins
zero) (Coins, Bool)
k
alg (Jump MVar r
_)                                = (Coins
zero, Bool
False)
alg Instr o (Const4 (Coins, Bool)) xs n r a
Empt                                    = (Coins
zero, Bool
True)
alg (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 (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 (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 (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 (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 (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 (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 a b x. (a -> b) -> (a, x) -> (b, x)
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 (Join ΦVar x
_)                                = (Coins
zero, Bool
False)
alg (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 (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 (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 (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 (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 (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 (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 (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 (MetaInstr (AddCoins Coins
_) (Const4 (Coins, Bool)
k))     = (Coins, Bool)
k
alg (MetaInstr (RefundCoins Coins
n) (Const4 (Coins, Bool)
k))  = (Coins -> Coins) -> (Coins, Bool) -> (Coins, Bool)
forall a b x. (a -> b) -> (a, x) -> (b, x)
first (Coins -> Coins -> Coins
minCoins 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 (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 (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 (MetaInstr (PrefetchChar Bool
_) (Const4 (Coins, Bool)
k)) = (Coins, Bool)
k
alg (MetaInstr MetaInstr n
BlockCoins (Const4 (Coins, Bool)
k))       = (Coins -> Coins) -> (Coins, Bool) -> (Coins, Bool)
forall a b x. (a -> b) -> (a, x) -> (b, x)
first (Coins -> Coins -> Coins
forall a b. a -> b -> a
const Coins
zero) (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