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(..))
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)
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)
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
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
_ (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
alg Bool
_ (MetaInstr (DrainCoins Coins
n) Const4 (Coins, Bool) xs n r a
_) = (Coins
n, Bool
False)
alg Bool
_ (MetaInstr (GiveBursary Coins
n) Const4 (Coins, Bool) xs n r a
_) = (Coins
n, Bool
False)
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