{-# LANGUAGE DeriveAnyClass,
MagicHash,
DerivingStrategies,
UnboxedTuples #-}
module Parsley.Internal.Backend.Machine.Types.Context (
Ctx,
QJoin,
emptyCtx,
insertSub, askSub,
insertΦ, askΦ,
insertNewΣ, cacheΣ,
concreteΣ, cachedΣ,
takeFreeRegisters,
debugUp, debugDown, debugLevel,
freshUnique, nextUnique,
storePiggy, breakPiggy, spendCoin, giveCoins, refundCoins, voidCoins,
coins, hasCoin, isBankrupt, canAfford,
addChar, readChar
) where
import Control.Exception (Exception, throw)
import Control.Monad (liftM2, (<=<))
import Control.Monad.Reader (asks, local, MonadReader)
import Data.STRef (STRef)
import Data.Dependent.Map (DMap)
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.LetBindings (Regs(..))
import Parsley.Internal.Backend.Machine.Types.Coins (Coins, willConsume, canReclaim)
import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynSubroutine)
import Parsley.Internal.Backend.Machine.Types.Input (Input)
import Parsley.Internal.Backend.Machine.Types.Statics (QSubroutine(..), StaFunc, StaSubroutine, StaCont)
import Parsley.Internal.Common (Queue, enqueue, dequeue, Code, RewindQueue)
import qualified Data.Dependent.Map as DMap ((!), insert, empty, lookup)
import qualified Parsley.Internal.Common.QueueLike as Queue (empty, null)
import qualified Parsley.Internal.Common.RewindQueue as Queue (rewind)
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 -> Word
offsetUniq :: Word
, Ctx s o a -> Queue Coins
piggies :: Queue Coins
, Ctx s o a -> RewindQueue (Code Char, Input o)
knownChars :: RewindQueue (Code Char, Input o)
}
newtype QJoin s o a x = QJoin { QJoin s o a x -> StaCont s o a x
unwrapJoin :: StaCont s o a x }
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
-> Word
-> Queue Coins
-> RewindQueue (Code Char, Input o)
-> 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
-> Word
-> Queue Coins
-> RewindQueue (Code Char, Input o)
-> 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 Word
0 Queue Coins
forall (q :: Type -> Type) a. QueueLike q => q a
Queue.empty RewindQueue (Code Char, Input o)
forall (q :: Type -> Type) a. QueueLike q => q a
Queue.empty
insertSub :: MVar x
-> StaSubroutine s o a x
-> Ctx s o a
-> Ctx s o a
insertSub :: MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar x
μ StaSubroutine 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
μ (StaFunc '[] s o a x -> Regs '[] -> QSubroutine s o a x
forall s o a x (rs :: [Type]).
StaFunc rs s o a x -> Regs rs -> QSubroutine s o a x
QSubroutine StaFunc '[] s o a x
StaSubroutine 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)}
askSub :: MonadReader (Ctx s o a) m => MVar x -> m (StaSubroutine s o a x)
askSub :: MVar x -> m (StaSubroutine s o a x)
askSub MVar x
μ =
do QSubroutine StaFunc 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 -> StaSubroutine s o a x) -> m (StaSubroutine s o a x)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (StaFunc rs s o a x -> Regs rs -> Ctx s o a -> StaSubroutine s o a x
forall (rs :: [Type]) s o a x.
StaFunc rs s o a x -> Regs rs -> Ctx s o a -> StaSubroutine s o a x
provideFreeRegisters StaFunc 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)
insertΦ :: ΦVar x
-> StaCont s o a x
-> Ctx s o a
-> Ctx s o a
insertΦ :: ΦVar x -> StaCont s o a x -> Ctx s o a -> Ctx s o a
insertΦ ΦVar x
φ StaCont 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
φ (StaCont s o a x -> QJoin s o a x
forall s o a x. StaCont s o a x -> QJoin s o a x
QJoin StaCont 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)}
askΦ :: MonadReader (Ctx s o a) m => ΦVar x -> m (StaCont s o a x)
askΦ :: ΦVar x -> m (StaCont s o a x)
askΦ ΦVar x
φ = (Ctx s o a -> StaCont s o a x) -> m (StaCont s o a x)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (QJoin s o a x -> StaCont s o a x
forall s o a x. QJoin s o a x -> StaCont s o a x
unwrapJoin (QJoin s o a x -> StaCont s o a x)
-> (Ctx s o a -> QJoin s o a x) -> Ctx s o a -> StaCont 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)
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) }
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)}
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
. (Reg s x -> Maybe (Code (STRef s x))
forall s x. Reg s x -> Maybe (Code (STRef s x))
getReg (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 (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m 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
. (Reg s x -> Maybe (Defunc x)
forall s x. Reg s x -> Maybe (Defunc x)
getCached (Reg s x -> Maybe (Defunc x))
-> (Ctx s o a -> Maybe (Reg s x)) -> Ctx s o a -> Maybe (Defunc x)
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m 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))
takeFreeRegisters :: Regs rs
-> Ctx s o a
-> (Ctx s o a -> DynSubroutine s o a x)
-> DynFunc rs s o a x
takeFreeRegisters :: Regs rs
-> Ctx s o a
-> (Ctx s o a -> DynSubroutine s o a x)
-> DynFunc rs s o a x
takeFreeRegisters Regs rs
NoRegs Ctx s o a
ctx Ctx s o a -> DynSubroutine s o a x
body = Ctx s o a -> DynSubroutine s o a x
body Ctx s o a
ctx
takeFreeRegisters (FreeReg ΣVar r
σ Regs rs
σs) Ctx s o a
ctx Ctx s o a -> DynSubroutine s o a x
body = [||\(!reg) -> $$(takeFreeRegisters σs (insertScopedΣ σ [||reg||] ctx) body)||]
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)}
provideFreeRegisters :: StaFunc rs s o a x -> Regs rs -> Ctx s o a -> StaSubroutine s o a x
provideFreeRegisters :: StaFunc rs s o a x -> Regs rs -> Ctx s o a -> StaSubroutine s o a x
provideFreeRegisters StaFunc rs s o a x
sub Regs rs
NoRegs Ctx s o a
_ = StaFunc rs s o a x
StaSubroutine s o a x
sub
provideFreeRegisters StaFunc rs s o a x
f (FreeReg ΣVar r
σ Regs rs
σs) Ctx s o a
ctx = StaFunc rs s o a x -> Regs rs -> Ctx s o a -> StaSubroutine s o a x
forall (rs :: [Type]) s o a x.
StaFunc rs s o a x -> Regs rs -> Ctx s o a -> StaSubroutine s o a x
provideFreeRegisters (StaFunc rs s o a x
Code (STRef s r) -> StaFunc rs s o a x
f (ΣVar r -> Ctx s o a -> Code (STRef s r)
forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar r
σ Ctx s o a
ctx)) Regs rs
σs Ctx s o a
ctx
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}
nextUnique :: Ctx s o a -> Ctx s o a
nextUnique :: Ctx s o a -> Ctx s o a
nextUnique Ctx s o a
ctx = Ctx s o a
ctx {offsetUniq :: Word
offsetUniq = Ctx s o a -> Word
forall s o a. Ctx s o a -> Word
offsetUniq Ctx s o a
ctx Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1}
freshUnique :: MonadReader (Ctx s o a) m => (Word -> m b) -> m b
freshUnique :: (Word -> m b) -> m b
freshUnique Word -> m b
f =
do Word
unique <- (Ctx s o a -> Word) -> m Word
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks Ctx s o a -> Word
forall s o a. Ctx s o a -> Word
offsetUniq
(Ctx s o a -> Ctx s o a) -> m b -> m b
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
nextUnique (Word -> m b
f Word
unique)
storePiggy :: Coins -> Ctx s o a -> Ctx s o a
storePiggy :: Coins -> Ctx s o a -> Ctx s o a
storePiggy Coins
coins Ctx s o a
ctx = Ctx s o a
ctx {piggies :: Queue Coins
piggies = Coins -> Queue Coins -> Queue Coins
forall (q :: Type -> Type) a. QueueLike q => a -> q a -> q a
enqueue Coins
coins (Ctx s o a -> Queue Coins
forall s o a. Ctx s o a -> Queue Coins
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 (Coins
coins, Queue Coins
piggies') = Queue Coins -> (Coins, Queue Coins)
forall (q :: Type -> Type) a. QueueLike q => q a -> (a, q a)
dequeue (Ctx s o a -> Queue Coins
forall s o a. Ctx s o a -> Queue Coins
piggies Ctx s o a
ctx) in Ctx s o a
ctx {coins :: Int
coins = Coins -> Int
willConsume Coins
coins, piggies :: Queue Coins
piggies = Queue Coins
piggies'}
hasCoin :: Ctx s o a -> Bool
hasCoin :: Ctx s o a -> Bool
hasCoin = Int -> Ctx s o a -> Bool
forall s o a. Int -> Ctx s o a -> Bool
canAfford Int
1
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 Coins -> Bool
forall (q :: Type -> Type) a. QueueLike q => q a -> Bool
Queue.null (Queue Coins -> Bool)
-> (Ctx s o a -> Queue Coins) -> Ctx s o a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx s o a -> Queue Coins
forall s o a. Ctx s o a -> Queue Coins
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 :: Coins -> Ctx s o a -> Ctx s o a
giveCoins :: Coins -> Ctx s o a -> Ctx s o a
giveCoins Coins
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
+ Coins -> Int
willConsume Coins
c}
refundCoins :: Coins -> Ctx s o a -> Ctx s o a
refundCoins :: Coins -> Ctx s o a -> Ctx s o a
refundCoins Coins
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
+ Coins -> Int
willConsume Coins
c
, knownChars :: RewindQueue (Code Char, Input o)
knownChars = Int
-> RewindQueue (Code Char, Input o)
-> RewindQueue (Code Char, Input o)
forall a. Int -> RewindQueue a -> RewindQueue a
Queue.rewind (Coins -> Int
canReclaim Coins
c) (Ctx s o a -> RewindQueue (Code Char, Input o)
forall s o a. Ctx s o a -> RewindQueue (Code Char, Input o)
knownChars Ctx s o a
ctx)
}
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 Coins
piggies = Queue Coins
forall (q :: Type -> Type) a. QueueLike q => q a
Queue.empty, knownChars :: RewindQueue (Code Char, Input o)
knownChars = RewindQueue (Code Char, Input o)
forall (q :: Type -> Type) a. QueueLike q => q a
Queue.empty}
canAfford :: Int -> Ctx s o a -> Bool
canAfford :: Int -> Ctx s o a -> Bool
canAfford Int
n = (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n) (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
addChar :: Code Char -> Input o -> Ctx s o a -> Ctx s o a
addChar :: Code Char -> Input o -> Ctx s o a -> Ctx s o a
addChar Code Char
c Input o
o Ctx s o a
ctx = Ctx s o a
ctx { knownChars :: RewindQueue (Code Char, Input o)
knownChars = (Code Char, Input o)
-> RewindQueue (Code Char, Input o)
-> RewindQueue (Code Char, Input o)
forall (q :: Type -> Type) a. QueueLike q => a -> q a -> q a
enqueue (Code Char
c, Input o
o) (Ctx s o a -> RewindQueue (Code Char, Input o)
forall s o a. Ctx s o a -> RewindQueue (Code Char, Input o)
knownChars Ctx s o a
ctx) }
readChar :: Ctx s o a
-> ((Code Char -> Input o -> Code b) -> Code b)
-> (Code Char -> Input o -> Ctx s o a -> Code b)
-> Code b
readChar :: Ctx s o a
-> ((Code Char -> Input o -> Code b) -> Code b)
-> (Code Char -> Input o -> Ctx s o a -> Code b)
-> Code b
readChar Ctx s o a
ctx (Code Char -> Input o -> Code b) -> Code b
fallback Code Char -> Input o -> Ctx s o a -> Code b
k
| Bool
reclaimable = Ctx s o a
-> (Code Char -> Input o -> Ctx s o a -> Code b) -> Code b
forall s o a t.
Ctx s o a -> (Code Char -> Input o -> Ctx s o a -> t) -> t
unsafeReadChar Ctx s o a
ctx Code Char -> Input o -> Ctx s o a -> Code b
k
| Bool
otherwise = (Code Char -> Input o -> Code b) -> Code b
fallback ((Code Char -> Input o -> Code b) -> Code b)
-> (Code Char -> Input o -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code Char
c Input o
o -> Ctx s o a
-> (Code Char -> Input o -> Ctx s o a -> Code b) -> Code b
forall s o a t.
Ctx s o a -> (Code Char -> Input o -> Ctx s o a -> t) -> t
unsafeReadChar (Code Char -> Input o -> Ctx s o a -> Ctx s o a
forall o s a. Code Char -> Input o -> Ctx s o a -> Ctx s o a
addChar Code Char
c Input o
o Ctx s o a
ctx) Code Char -> Input o -> Ctx s o a -> Code b
k
where
reclaimable :: Bool
reclaimable = Bool -> Bool
not (RewindQueue (Code Char, Input o) -> Bool
forall (q :: Type -> Type) a. QueueLike q => q a -> Bool
Queue.null (Ctx s o a -> RewindQueue (Code Char, Input o)
forall s o a. Ctx s o a -> RewindQueue (Code Char, Input o)
knownChars Ctx s o a
ctx))
unsafeReadChar :: Ctx s o a -> (Code Char -> Input o -> Ctx s o a -> t) -> t
unsafeReadChar Ctx s o a
ctx Code Char -> Input o -> Ctx s o a -> t
k = let ((Code Char
c, Input o
o), RewindQueue (Code Char, Input o)
q) = RewindQueue (Code Char, Input o)
-> ((Code Char, Input o), RewindQueue (Code Char, Input o))
forall (q :: Type -> Type) a. QueueLike q => q a -> (a, q a)
dequeue (Ctx s o a -> RewindQueue (Code Char, Input o)
forall s o a. Ctx s o a -> RewindQueue (Code Char, Input o)
knownChars Ctx s o a
ctx) in Code Char -> Input o -> Ctx s o a -> t
k Code Char
c Input o
o (Ctx s o a
ctx { knownChars :: RewindQueue (Code Char, Input o)
knownChars = RewindQueue (Code Char, Input o)
q })
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"