{-# LANGUAGE DeriveAnyClass,
             ExistentialQuantification,
             TypeFamilies,
             DerivingStrategies #-}
module Parsley.Internal.Backend.Machine.State (
    HandlerStack, Handler, Cont, SubRoutine, MachineMonad, Func,
    Γ(..), Ctx, OpStack(..),
    QSubRoutine(..), QJoin(..), Machine(..),
    run,
    emptyCtx,
    insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, concreteΣ, cachedΣ,
    askSub, askΦ,
    debugUp, debugDown, debugLevel,
    storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins,
    hasCoin, isBankrupt, liquidate
  ) where

import Control.Exception                            (Exception, throw)
import Control.Monad                                (liftM2)
import Control.Monad.Reader                         (asks, MonadReader, Reader, runReader)
import Control.Monad.ST                             (ST)
import Data.STRef                                   (STRef)
import Data.Dependent.Map                           (DMap)
import Data.Kind                                    (Type)
import Data.Maybe                                   (fromMaybe)
import Parsley.Internal.Backend.Machine.Defunc      (Defunc)
import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΣVar(..), ΦVar, IMVar, IΣVar)
import Parsley.Internal.Backend.Machine.InputRep    (Rep)
import Parsley.Internal.Backend.Machine.LetBindings (Regs(..))
import Parsley.Internal.Common                      (Queue, enqueue, dequeue, Code, Vec)

import qualified Data.Dependent.Map as DMap             ((!), insert, empty, lookup)
import qualified Parsley.Internal.Common.Queue as Queue (empty, null, foldr)

type HandlerStack n s o a = Vec n (Code (Handler s o a))
type Handler s o a = Rep o -> ST s (Maybe a)
type Cont s o a x = x -> Rep o -> ST s (Maybe a)
type SubRoutine s o a x = Cont s o a x -> Rep o -> Handler s o a -> ST s (Maybe a)
type MachineMonad s o xs n r a = Reader (Ctx s o a) (Γ s o xs n r a -> Code (ST s (Maybe a)))

type family Func (rs :: [Type]) s o a x where
  Func '[] s o a x      = SubRoutine s o a x
  Func (r : rs) s o a x = STRef s r -> Func rs s o a x

data QSubRoutine s o a x = forall rs. QSubRoutine  (Code (Func rs s o a x)) (Regs rs)
newtype QJoin s o a x = QJoin { QJoin s o a x -> Code (Cont s o a x)
unwrapJoin :: Code (Cont s o a x) }
newtype Machine s o xs n r a = Machine { Machine s o xs n r a -> MachineMonad s o xs n r a
getMachine :: MachineMonad s o xs n r a }

run :: Machine s o xs n r a -> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run :: Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run = (Ctx s o a -> Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ctx s o a -> Γ s o xs n r a -> Code (ST s (Maybe a)))
 -> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a)))
-> (Machine s o xs n r a
    -> Ctx s o a -> Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Machine s o xs n r a
-> Γ s o xs n r a
-> Ctx s o a
-> Code (ST s (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reader (Ctx s o a) (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Ctx s o a -> Γ s o xs n r a -> Code (ST s (Maybe a))
forall r a. Reader r a -> r -> a
runReader (Reader (Ctx s o a) (Γ s o xs n r a -> Code (ST s (Maybe a)))
 -> Ctx s o a -> Γ s o xs n r a -> Code (ST s (Maybe a)))
-> (Machine s o xs n r a
    -> Reader (Ctx s o a) (Γ s o xs n r a -> Code (ST s (Maybe a))))
-> Machine s o xs n r a
-> Ctx s o a
-> Γ s o xs n r a
-> Code (ST s (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Machine s o xs n r a
-> Reader (Ctx s o a) (Γ s o xs n r a -> Code (ST s (Maybe a)))
forall s o (xs :: [Type]) (n :: Nat) r a.
Machine s o xs n r a -> MachineMonad s o xs n r a
getMachine

data OpStack xs where
  Empty :: OpStack '[]
  Op :: Defunc x -> OpStack xs -> OpStack (x ': xs)

data Reg s x = Reg { Reg s x -> Maybe (Code (STRef s x))
getReg    :: Maybe (Code (STRef s x))
                   , Reg s x -> Maybe (Defunc x)
getCached :: Maybe (Defunc x) }

data Γ s o xs n r a = Γ { Γ s o xs n r a -> OpStack xs
operands :: OpStack xs
                        , Γ s o xs n r a -> Code (Cont s o a r)
retCont  :: Code (Cont s o a r)
                        , Γ s o xs n r a -> Code (Rep o)
input    :: Code (Rep o)
                        , Γ s o xs n r a -> HandlerStack n s o a
handlers :: HandlerStack n s o a }

data Ctx s o a = Ctx { Ctx s o a -> DMap MVar (QSubRoutine s o a)
μs         :: DMap MVar (QSubRoutine s o a)
                     , Ctx s o a -> DMap ΦVar (QJoin s o a)
φs         :: DMap ΦVar (QJoin s o a)
                     , Ctx s o a -> DMap ΣVar (Reg s)
σs         :: DMap ΣVar (Reg s)
                     , Ctx s o a -> Int
debugLevel :: Int
                     , Ctx s o a -> Int
coins      :: Int
                     , Ctx s o a -> Queue Int
piggies    :: Queue Int }

emptyCtx :: DMap MVar (QSubRoutine s o a) -> Ctx s o a
emptyCtx :: DMap MVar (QSubRoutine s o a) -> Ctx s o a
emptyCtx DMap MVar (QSubRoutine s o a)
μs = DMap MVar (QSubRoutine s o a)
-> DMap ΦVar (QJoin s o a)
-> DMap ΣVar (Reg s)
-> Int
-> Int
-> Queue Int
-> Ctx s o a
forall s o a.
DMap MVar (QSubRoutine s o a)
-> DMap ΦVar (QJoin s o a)
-> DMap ΣVar (Reg s)
-> Int
-> Int
-> Queue Int
-> Ctx s o a
Ctx DMap MVar (QSubRoutine s o a)
μs DMap ΦVar (QJoin s o a)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type). DMap k2 f
DMap.empty DMap ΣVar (Reg s)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type). DMap k2 f
DMap.empty Int
0 Int
0 Queue Int
forall a. Queue a
Queue.empty

insertSub :: MVar x -> Code (SubRoutine s o a x) -> Ctx s o a -> Ctx s o a
insertSub :: MVar x -> Code (SubRoutine s o a x) -> Ctx s o a -> Ctx s o a
insertSub MVar x
μ Code (SubRoutine s o a x)
q Ctx s o a
ctx = Ctx s o a
ctx {μs :: DMap MVar (QSubRoutine s o a)
μs = MVar x
-> QSubRoutine s o a x
-> DMap MVar (QSubRoutine s o a)
-> DMap MVar (QSubRoutine s o a)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> f v -> DMap k2 f -> DMap k2 f
DMap.insert MVar x
μ (Code (Func '[] s o a x) -> Regs '[] -> QSubRoutine s o a x
forall s o a x (rs :: [Type]).
Code (Func rs s o a x) -> Regs rs -> QSubRoutine s o a x
QSubRoutine Code (Func '[] s o a x)
Code (SubRoutine s o a x)
q Regs '[]
NoRegs) (Ctx s o a -> DMap MVar (QSubRoutine s o a)
forall s o a. Ctx s o a -> DMap MVar (QSubRoutine s o a)
μs Ctx s o a
ctx)}

insertΦ :: ΦVar x -> Code (Cont s o a x) -> Ctx s o a -> Ctx s o a
insertΦ :: ΦVar x -> Code (Cont s o a x) -> Ctx s o a -> Ctx s o a
insertΦ ΦVar x
φ Code (Cont s o a x)
qjoin Ctx s o a
ctx = Ctx s o a
ctx {φs :: DMap ΦVar (QJoin s o a)
φs = ΦVar x
-> QJoin s o a x
-> DMap ΦVar (QJoin s o a)
-> DMap ΦVar (QJoin s o a)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> f v -> DMap k2 f -> DMap k2 f
DMap.insert ΦVar x
φ (Code (Cont s o a x) -> QJoin s o a x
forall s o a x. Code (Cont s o a x) -> QJoin s o a x
QJoin Code (Cont s o a x)
qjoin) (Ctx s o a -> DMap ΦVar (QJoin s o a)
forall s o a. Ctx s o a -> DMap ΦVar (QJoin s o a)
φs Ctx s o a
ctx)}

insertNewΣ :: ΣVar x -> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a
insertNewΣ :: ΣVar x
-> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a
insertNewΣ ΣVar x
σ Maybe (Code (STRef s x))
qref Defunc x
x Ctx s o a
ctx = Ctx s o a
ctx {σs :: DMap ΣVar (Reg s)
σs = ΣVar x -> Reg s x -> DMap ΣVar (Reg s) -> DMap ΣVar (Reg s)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> f v -> DMap k2 f -> DMap k2 f
DMap.insert ΣVar x
σ (Maybe (Code (STRef s x)) -> Maybe (Defunc x) -> Reg s x
forall s x. Maybe (Code (STRef s x)) -> Maybe (Defunc x) -> Reg s x
Reg Maybe (Code (STRef s x))
qref (Defunc x -> Maybe (Defunc x)
forall a. a -> Maybe a
Just Defunc x
x)) (Ctx s o a -> DMap ΣVar (Reg s)
forall s o a. Ctx s o a -> DMap ΣVar (Reg s)
σs Ctx s o a
ctx)}

insertScopedΣ :: ΣVar x -> Code (STRef s x) -> Ctx s o a -> Ctx s o a
insertScopedΣ :: ΣVar x -> Code (STRef s x) -> Ctx s o a -> Ctx s o a
insertScopedΣ ΣVar x
σ Code (STRef s x)
qref Ctx s o a
ctx = Ctx s o a
ctx {σs :: DMap ΣVar (Reg s)
σs = ΣVar x -> Reg s x -> DMap ΣVar (Reg s) -> DMap ΣVar (Reg s)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> f v -> DMap k2 f -> DMap k2 f
DMap.insert ΣVar x
σ (Maybe (Code (STRef s x)) -> Maybe (Defunc x) -> Reg s x
forall s x. Maybe (Code (STRef s x)) -> Maybe (Defunc x) -> Reg s x
Reg (Code (STRef s x) -> Maybe (Code (STRef s x))
forall a. a -> Maybe a
Just Code (STRef s x)
qref) Maybe (Defunc x)
forall a. Maybe a
Nothing) (Ctx s o a -> DMap ΣVar (Reg s)
forall s o a. Ctx s o a -> DMap ΣVar (Reg s)
σs Ctx s o a
ctx)}

cacheΣ :: ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a
cacheΣ :: ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a
cacheΣ ΣVar x
σ Defunc x
x Ctx s o a
ctx = case ΣVar x -> DMap ΣVar (Reg s) -> Maybe (Reg s x)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup ΣVar x
σ (Ctx s o a -> DMap ΣVar (Reg s)
forall s o a. Ctx s o a -> DMap ΣVar (Reg s)
σs Ctx s o a
ctx) of
  Just (Reg Maybe (Code (STRef s x))
ref Maybe (Defunc x)
_) -> Ctx s o a
ctx {σs :: DMap ΣVar (Reg s)
σs = ΣVar x -> Reg s x -> DMap ΣVar (Reg s) -> DMap ΣVar (Reg s)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> f v -> DMap k2 f -> DMap k2 f
DMap.insert ΣVar x
σ (Maybe (Code (STRef s x)) -> Maybe (Defunc x) -> Reg s x
forall s x. Maybe (Code (STRef s x)) -> Maybe (Defunc x) -> Reg s x
Reg Maybe (Code (STRef s x))
ref (Defunc x -> Maybe (Defunc x)
forall a. a -> Maybe a
Just Defunc x
x)) (Ctx s o a -> DMap ΣVar (Reg s)
forall s o a. Ctx s o a -> DMap ΣVar (Reg s)
σs Ctx s o a
ctx)}
  Maybe (Reg s x)
Nothing          -> OutOfScopeRegister -> Ctx s o a
forall a e. Exception e => e -> a
throw (ΣVar x -> OutOfScopeRegister
forall x. ΣVar x -> OutOfScopeRegister
outOfScopeRegister ΣVar x
σ)

concreteΣ :: ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ :: ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar x
σ = Code (STRef s x) -> Maybe (Code (STRef s x)) -> Code (STRef s x)
forall a. a -> Maybe a -> a
fromMaybe (IntangibleRegister -> Code (STRef s x)
forall a e. Exception e => e -> a
throw (ΣVar x -> IntangibleRegister
forall x. ΣVar x -> IntangibleRegister
intangibleRegister ΣVar x
σ)) (Maybe (Code (STRef s x)) -> Code (STRef s x))
-> (Ctx s o a -> Maybe (Code (STRef s x)))
-> Ctx s o a
-> Code (STRef s x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Reg s x)
-> (Reg s x -> Maybe (Code (STRef s x)))
-> Maybe (Code (STRef s x))
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reg s x -> Maybe (Code (STRef s x))
forall s x. Reg s x -> Maybe (Code (STRef s x))
getReg) (Maybe (Reg s x) -> Maybe (Code (STRef s x)))
-> (Ctx s o a -> Maybe (Reg s x))
-> Ctx s o a
-> Maybe (Code (STRef s x))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ΣVar x -> DMap ΣVar (Reg s) -> Maybe (Reg s x)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup ΣVar x
σ (DMap ΣVar (Reg s) -> Maybe (Reg s x))
-> (Ctx s o a -> DMap ΣVar (Reg s)) -> Ctx s o a -> Maybe (Reg s x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx s o a -> DMap ΣVar (Reg s)
forall s o a. Ctx s o a -> DMap ΣVar (Reg s)
σs

cachedΣ :: ΣVar x -> Ctx s o a -> Defunc x
cachedΣ :: ΣVar x -> Ctx s o a -> Defunc x
cachedΣ ΣVar x
σ = Defunc x -> Maybe (Defunc x) -> Defunc x
forall a. a -> Maybe a -> a
fromMaybe (RegisterFault -> Defunc x
forall a e. Exception e => e -> a
throw (ΣVar x -> RegisterFault
forall x. ΣVar x -> RegisterFault
registerFault ΣVar x
σ)) (Maybe (Defunc x) -> Defunc x)
-> (Ctx s o a -> Maybe (Defunc x)) -> Ctx s o a -> Defunc x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Reg s x)
-> (Reg s x -> Maybe (Defunc x)) -> Maybe (Defunc x)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reg s x -> Maybe (Defunc x)
forall s x. Reg s x -> Maybe (Defunc x)
getCached) (Maybe (Reg s x) -> Maybe (Defunc x))
-> (Ctx s o a -> Maybe (Reg s x)) -> Ctx s o a -> Maybe (Defunc x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ΣVar x -> DMap ΣVar (Reg s) -> Maybe (Reg s x)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup ΣVar x
σ (DMap ΣVar (Reg s) -> Maybe (Reg s x))
-> (Ctx s o a -> DMap ΣVar (Reg s)) -> Ctx s o a -> Maybe (Reg s x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx s o a -> DMap ΣVar (Reg s)
forall s o a. Ctx s o a -> DMap ΣVar (Reg s)
σs

askSub :: MonadReader (Ctx s o a) m => MVar x -> m (Code (SubRoutine s o a x))
askSub :: MVar x -> m (Code (SubRoutine s o a x))
askSub MVar x
μ =
  do QSubRoutine Code (Func rs s o a x)
sub Regs rs
rs <- MVar x -> m (QSubRoutine s o a x)
forall s o a (m :: Type -> Type) x.
MonadReader (Ctx s o a) m =>
MVar x -> m (QSubRoutine s o a x)
askSubUnbound MVar x
μ
     (Ctx s o a -> Code (SubRoutine s o a x))
-> m (Code (SubRoutine s o a x))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (Code (Func rs s o a x)
-> Regs rs -> Ctx s o a -> Code (SubRoutine s o a x)
forall (rs :: [Type]) s o a x.
Code (Func rs s o a x)
-> Regs rs -> Ctx s o a -> Code (SubRoutine s o a x)
provideFreeRegisters Code (Func rs s o a x)
sub Regs rs
rs)

askSubUnbound :: MonadReader (Ctx s o a) m => MVar x -> m (QSubRoutine s o a x)
askSubUnbound :: MVar x -> m (QSubRoutine s o a x)
askSubUnbound MVar x
μ = (Ctx s o a -> QSubRoutine s o a x) -> m (QSubRoutine s o a x)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (QSubRoutine s o a x
-> Maybe (QSubRoutine s o a x) -> QSubRoutine s o a x
forall a. a -> Maybe a -> a
fromMaybe (MissingDependency -> QSubRoutine s o a x
forall a e. Exception e => e -> a
throw (MVar x -> MissingDependency
forall x. MVar x -> MissingDependency
missingDependency MVar x
μ)) (Maybe (QSubRoutine s o a x) -> QSubRoutine s o a x)
-> (Ctx s o a -> Maybe (QSubRoutine s o a x))
-> Ctx s o a
-> QSubRoutine s o a x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar x
-> DMap MVar (QSubRoutine s o a) -> Maybe (QSubRoutine s o a x)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup MVar x
μ (DMap MVar (QSubRoutine s o a) -> Maybe (QSubRoutine s o a x))
-> (Ctx s o a -> DMap MVar (QSubRoutine s o a))
-> Ctx s o a
-> Maybe (QSubRoutine s o a x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx s o a -> DMap MVar (QSubRoutine s o a)
forall s o a. Ctx s o a -> DMap MVar (QSubRoutine s o a)
μs)

provideFreeRegisters :: Code (Func rs s o a x) -> Regs rs -> Ctx s o a -> Code (SubRoutine s o a x)
provideFreeRegisters :: Code (Func rs s o a x)
-> Regs rs -> Ctx s o a -> Code (SubRoutine s o a x)
provideFreeRegisters Code (Func rs s o a x)
sub Regs rs
NoRegs Ctx s o a
_ = Code (Func rs s o a x)
Code (SubRoutine s o a x)
sub
provideFreeRegisters Code (Func rs s o a x)
f (FreeReg ΣVar r
σ Regs rs
σs) Ctx s o a
ctx = Code (Func rs s o a x)
-> Regs rs -> Ctx s o a -> Code (SubRoutine s o a x)
forall (rs :: [Type]) s o a x.
Code (Func rs s o a x)
-> Regs rs -> Ctx s o a -> Code (SubRoutine s o a x)
provideFreeRegisters [||$$f $$(concreteΣ σ ctx)||] Regs rs
σs Ctx s o a
ctx

askΦ :: MonadReader (Ctx s o a) m => ΦVar x -> m (Code (Cont s o a x))
askΦ :: ΦVar x -> m (Code (Cont s o a x))
askΦ ΦVar x
φ = (Ctx s o a -> Code (Cont s o a x)) -> m (Code (Cont s o a x))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (QJoin s o a x -> Code (Cont s o a x)
forall s o a x. QJoin s o a x -> Code (Cont s o a x)
unwrapJoin (QJoin s o a x -> Code (Cont s o a x))
-> (Ctx s o a -> QJoin s o a x) -> Ctx s o a -> Code (Cont s o a x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DMap ΦVar (QJoin s o a) -> ΦVar x -> QJoin s o a x
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
DMap k2 f -> k2 v -> f v
DMap.! ΦVar x
φ) (DMap ΦVar (QJoin s o a) -> QJoin s o a x)
-> (Ctx s o a -> DMap ΦVar (QJoin s o a))
-> Ctx s o a
-> QJoin s o a x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx s o a -> DMap ΦVar (QJoin s o a)
forall s o a. Ctx s o a -> DMap ΦVar (QJoin s o a)
φs)

debugUp :: Ctx s o a -> Ctx s o a
debugUp :: Ctx s o a -> Ctx s o a
debugUp Ctx s o a
ctx = Ctx s o a
ctx {debugLevel :: Int
debugLevel = Ctx s o a -> Int
forall s o a. Ctx s o a -> Int
debugLevel Ctx s o a
ctx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}

debugDown :: Ctx s o a -> Ctx s o a
debugDown :: Ctx s o a -> Ctx s o a
debugDown Ctx s o a
ctx = Ctx s o a
ctx {debugLevel :: Int
debugLevel = Ctx s o a -> Int
forall s o a. Ctx s o a -> Int
debugLevel Ctx s o a
ctx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}

-- Piggy bank functions
storePiggy :: Int -> Ctx s o a -> Ctx s o a
storePiggy :: Int -> Ctx s o a -> Ctx s o a
storePiggy Int
coins Ctx s o a
ctx = Ctx s o a
ctx {piggies :: Queue Int
piggies = Int -> Queue Int -> Queue Int
forall a. a -> Queue a -> Queue a
enqueue Int
coins (Ctx s o a -> Queue Int
forall s o a. Ctx s o a -> Queue Int
piggies Ctx s o a
ctx)}

breakPiggy :: Ctx s o a -> Ctx s o a
breakPiggy :: Ctx s o a -> Ctx s o a
breakPiggy Ctx s o a
ctx = let (Int
coins, Queue Int
piggies') = Queue Int -> (Int, Queue Int)
forall a. Queue a -> (a, Queue a)
dequeue (Ctx s o a -> Queue Int
forall s o a. Ctx s o a -> Queue Int
piggies Ctx s o a
ctx) in Ctx s o a
ctx {coins :: Int
coins = Int
coins, piggies :: Queue Int
piggies = Queue Int
piggies'}

hasCoin :: Ctx s o a -> Bool
hasCoin :: Ctx s o a -> Bool
hasCoin = (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Int -> Bool) -> (Ctx s o a -> Int) -> Ctx s o a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx s o a -> Int
forall s o a. Ctx s o a -> Int
coins

isBankrupt :: Ctx s o a -> Bool
isBankrupt :: Ctx s o a -> Bool
isBankrupt = (Bool -> Bool -> Bool)
-> (Ctx s o a -> Bool) -> (Ctx s o a -> Bool) -> Ctx s o a -> Bool
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (Bool -> Bool
not (Bool -> Bool) -> (Ctx s o a -> Bool) -> Ctx s o a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx s o a -> Bool
forall s o a. Ctx s o a -> Bool
hasCoin) (Queue Int -> Bool
forall a. Queue a -> Bool
Queue.null (Queue Int -> Bool)
-> (Ctx s o a -> Queue Int) -> Ctx s o a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx s o a -> Queue Int
forall s o a. Ctx s o a -> Queue Int
piggies)

spendCoin :: Ctx s o a -> Ctx s o a
spendCoin :: Ctx s o a -> Ctx s o a
spendCoin Ctx s o a
ctx = Ctx s o a
ctx {coins :: Int
coins = Ctx s o a -> Int
forall s o a. Ctx s o a -> Int
coins Ctx s o a
ctx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}

giveCoins :: Int -> Ctx s o a -> Ctx s o a
giveCoins :: Int -> Ctx s o a -> Ctx s o a
giveCoins Int
c Ctx s o a
ctx = Ctx s o a
ctx {coins :: Int
coins = Ctx s o a -> Int
forall s o a. Ctx s o a -> Int
coins Ctx s o a
ctx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c}

voidCoins :: Ctx s o a -> Ctx s o a
voidCoins :: Ctx s o a -> Ctx s o a
voidCoins Ctx s o a
ctx = Ctx s o a
ctx {coins :: Int
coins = Int
0, piggies :: Queue Int
piggies = Queue Int
forall a. Queue a
Queue.empty}

liquidate :: Ctx s o a -> Int
liquidate :: Ctx s o a -> Int
liquidate Ctx s o a
ctx = (Int -> Int -> Int) -> Int -> Queue Int -> Int
forall a b. (a -> b -> b) -> b -> Queue a -> b
Queue.foldr Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Ctx s o a -> Int
forall s o a. Ctx s o a -> Int
coins Ctx s o a
ctx) (Ctx s o a -> Queue Int
forall s o a. Ctx s o a -> Queue Int
piggies Ctx s o a
ctx)

newtype MissingDependency = MissingDependency IMVar deriving anyclass Show MissingDependency
Typeable MissingDependency
Typeable MissingDependency
-> Show MissingDependency
-> (MissingDependency -> SomeException)
-> (SomeException -> Maybe MissingDependency)
-> (MissingDependency -> String)
-> Exception MissingDependency
SomeException -> Maybe MissingDependency
MissingDependency -> String
MissingDependency -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: MissingDependency -> String
$cdisplayException :: MissingDependency -> String
fromException :: SomeException -> Maybe MissingDependency
$cfromException :: SomeException -> Maybe MissingDependency
toException :: MissingDependency -> SomeException
$ctoException :: MissingDependency -> SomeException
$cp2Exception :: Show MissingDependency
$cp1Exception :: Typeable MissingDependency
Exception
newtype OutOfScopeRegister = OutOfScopeRegister IΣVar deriving anyclass Show OutOfScopeRegister
Typeable OutOfScopeRegister
Typeable OutOfScopeRegister
-> Show OutOfScopeRegister
-> (OutOfScopeRegister -> SomeException)
-> (SomeException -> Maybe OutOfScopeRegister)
-> (OutOfScopeRegister -> String)
-> Exception OutOfScopeRegister
SomeException -> Maybe OutOfScopeRegister
OutOfScopeRegister -> String
OutOfScopeRegister -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: OutOfScopeRegister -> String
$cdisplayException :: OutOfScopeRegister -> String
fromException :: SomeException -> Maybe OutOfScopeRegister
$cfromException :: SomeException -> Maybe OutOfScopeRegister
toException :: OutOfScopeRegister -> SomeException
$ctoException :: OutOfScopeRegister -> SomeException
$cp2Exception :: Show OutOfScopeRegister
$cp1Exception :: Typeable OutOfScopeRegister
Exception
newtype IntangibleRegister = IntangibleRegister IΣVar deriving anyclass Show IntangibleRegister
Typeable IntangibleRegister
Typeable IntangibleRegister
-> Show IntangibleRegister
-> (IntangibleRegister -> SomeException)
-> (SomeException -> Maybe IntangibleRegister)
-> (IntangibleRegister -> String)
-> Exception IntangibleRegister
SomeException -> Maybe IntangibleRegister
IntangibleRegister -> String
IntangibleRegister -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: IntangibleRegister -> String
$cdisplayException :: IntangibleRegister -> String
fromException :: SomeException -> Maybe IntangibleRegister
$cfromException :: SomeException -> Maybe IntangibleRegister
toException :: IntangibleRegister -> SomeException
$ctoException :: IntangibleRegister -> SomeException
$cp2Exception :: Show IntangibleRegister
$cp1Exception :: Typeable IntangibleRegister
Exception
newtype RegisterFault = RegisterFault IΣVar deriving anyclass Show RegisterFault
Typeable RegisterFault
Typeable RegisterFault
-> Show RegisterFault
-> (RegisterFault -> SomeException)
-> (SomeException -> Maybe RegisterFault)
-> (RegisterFault -> String)
-> Exception RegisterFault
SomeException -> Maybe RegisterFault
RegisterFault -> String
RegisterFault -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: RegisterFault -> String
$cdisplayException :: RegisterFault -> String
fromException :: SomeException -> Maybe RegisterFault
$cfromException :: SomeException -> Maybe RegisterFault
toException :: RegisterFault -> SomeException
$ctoException :: RegisterFault -> SomeException
$cp2Exception :: Show RegisterFault
$cp1Exception :: Typeable RegisterFault
Exception

missingDependency :: MVar x -> MissingDependency
missingDependency :: MVar x -> MissingDependency
missingDependency (MVar IMVar
v) = IMVar -> MissingDependency
MissingDependency IMVar
v
outOfScopeRegister :: ΣVar x -> OutOfScopeRegister
outOfScopeRegister :: ΣVar x -> OutOfScopeRegister
outOfScopeRegister (ΣVar IΣVar
σ) = IΣVar -> OutOfScopeRegister
OutOfScopeRegister IΣVar
σ
intangibleRegister :: ΣVar x -> IntangibleRegister
intangibleRegister :: ΣVar x -> IntangibleRegister
intangibleRegister (ΣVar IΣVar
σ) = IΣVar -> IntangibleRegister
IntangibleRegister IΣVar
σ
registerFault :: ΣVar x -> RegisterFault
registerFault :: ΣVar x -> RegisterFault
registerFault (ΣVar IΣVar
σ) = IΣVar -> RegisterFault
RegisterFault IΣVar
σ

instance Show MissingDependency where show :: MissingDependency -> String
show (MissingDependency IMVar
μ) = String
"Dependency μ" String -> ShowS
forall a. [a] -> [a] -> [a]
++ IMVar -> String
forall a. Show a => a -> String
show IMVar
μ String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" has not been compiled"
instance Show OutOfScopeRegister where show :: OutOfScopeRegister -> String
show (OutOfScopeRegister IΣVar
σ) = String
"Register r" String -> ShowS
forall a. [a] -> [a] -> [a]
++ IΣVar -> String
forall a. Show a => a -> String
show IΣVar
σ String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is out of scope"
instance Show IntangibleRegister where show :: IntangibleRegister -> String
show (IntangibleRegister IΣVar
σ) = String
"Register r" String -> ShowS
forall a. [a] -> [a] -> [a]
++ IΣVar -> String
forall a. Show a => a -> String
show IΣVar
σ String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is intangible in this scope"
instance Show RegisterFault where show :: RegisterFault -> String
show (RegisterFault IΣVar
σ) = String
"Attempting to access register r" String -> ShowS
forall a. [a] -> [a] -> [a]
++ IΣVar -> String
forall a. Show a => a -> String
show IΣVar
σ String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" from cache has failed"