{-# LANGUAGE DeriveAnyClass,
MagicHash,
DerivingStrategies,
UnboxedTuples,
PatternSynonyms #-}
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, netWorth,
addChar, readChar
) where
import Control.Exception (Exception, throw)
import Control.Monad ((<=<))
import Control.Monad.Reader (asks, local, MonadReader)
import Data.STRef (STRef)
import Data.Dependent.Map (DMap)
import Data.Maybe (fromMaybe, isNothing)
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(Coins, willConsume))
import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynSubroutine)
import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset)
import Parsley.Internal.Backend.Machine.Types.Statics (QSubroutine(..), StaFunc, StaSubroutine, StaCont)
import Parsley.Internal.Common (Queue, enqueue, dequeue, poke, Code, RewindQueue)
import Parsley.Internal.Core.CharPred (CharPred, pattern Item, andPred)
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 { forall s o a. Ctx s o a -> DMap MVar (QSubroutine s o a)
μs :: !(DMap MVar (QSubroutine s o a))
, forall s o a. Ctx s o a -> DMap ΦVar (QJoin s o a)
φs :: !(DMap ΦVar (QJoin s o a))
, forall s o a. Ctx s o a -> DMap ΣVar (Reg s)
σs :: !(DMap ΣVar (Reg s))
, forall s o a. Ctx s o a -> Int
debugLevel :: {-# UNPACK #-} !Int
, forall s o a. Ctx s o a -> Int
coins :: {-# UNPACK #-} !Int
, forall s o a. Ctx s o a -> Word
offsetUniq :: {-# UNPACK #-} !Word
, forall s o a. Ctx s o a -> Queue Coins
piggies :: !(Queue Coins)
, forall s o a. Ctx s o a -> Int
netWorth :: {-# UNPACK #-} !Int
, forall s o a.
Ctx s o a -> RewindQueue (Code Char, CharPred, Offset o)
knownChars :: !(RewindQueue (Code Char, CharPred, Offset o))
}
newtype QJoin s o a x = QJoin { forall s o a x. 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 :: forall s o a. DMap MVar (QSubroutine s o a) -> Ctx s o a
emptyCtx DMap MVar (QSubroutine s o a)
μs = 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
-> Int
-> RewindQueue (Code Char, CharPred, Offset o)
-> Ctx s o a
Ctx DMap MVar (QSubroutine s o a)
μs forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type). DMap k2 f
DMap.empty forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type). DMap k2 f
DMap.empty Int
0 Int
0 Word
0 forall (q :: Type -> Type) a. QueueLike q => q a
Queue.empty Int
0 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 :: forall x s o a.
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 = 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
μ (forall s o a x (rs :: [Type]).
StaFunc rs s o a x -> Regs rs -> QSubroutine s o a x
QSubroutine StaSubroutine s o a x
q Regs '[]
NoRegs) (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 :: forall s o a (m :: Type -> Type) x.
MonadReader (Ctx s o a) m =>
MVar x -> m (StaSubroutine s o a x)
askSub MVar x
μ =
do QSubroutine StaFunc rs s o a x
sub Regs rs
rs <- 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
μ
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (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 :: 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
μ = forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall a. a -> Maybe a -> a
fromMaybe (forall a e. Exception e => e -> a
throw (forall x. MVar x -> MissingDependency
missingDependency MVar x
μ)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup MVar x
μ forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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Φ :: forall x s o a. Φ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 = 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
φ (forall s o a x. StaCont s o a x -> QJoin s o a x
QJoin StaCont s o a x
qjoin) (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Φ :: forall s o a (m :: Type -> Type) x.
MonadReader (Ctx s o a) m =>
ΦVar x -> m (StaCont s o a x)
askΦ ΦVar x
φ = forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall s o a x. QJoin s o a x -> StaCont s o a x
unwrapJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
DMap k2 f -> k2 v -> f v
DMap.! ΦVar x
φ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s o a. Ctx s o a -> DMap ΦVar (QJoin s o a)
φs)
data Reg s x = Reg { forall s x. Reg s x -> Maybe (Code (STRef s x))
getReg :: Maybe (Code (STRef s x))
, forall 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Σ :: forall x s o a.
Σ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 = 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
σ (forall s x. Maybe (Code (STRef s x)) -> Maybe (Defunc x) -> Reg s x
Reg Maybe (Code (STRef s x))
qref (forall a. a -> Maybe a
Just Defunc x
x)) (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Σ :: forall x s o a. ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a
cacheΣ ΣVar x
σ Defunc x
x Ctx s o a
ctx = case forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup ΣVar x
σ (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 = 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
σ (forall s x. Maybe (Code (STRef s x)) -> Maybe (Defunc x) -> Reg s x
Reg Maybe (Code (STRef s x))
ref (forall a. a -> Maybe a
Just Defunc x
x)) (forall s o a. Ctx s o a -> DMap ΣVar (Reg s)
σs Ctx s o a
ctx)}
Maybe (Reg s x)
Nothing -> forall a e. Exception e => e -> a
throw (forall x. ΣVar x -> OutOfScopeRegister
outOfScopeRegister ΣVar x
σ)
concreteΣ :: ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ :: forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar x
σ = forall a. a -> Maybe a -> a
fromMaybe (forall a e. Exception e => e -> a
throw (forall x. ΣVar x -> IntangibleRegister
intangibleRegister ΣVar x
σ)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s x. Reg s x -> Maybe (Code (STRef s x))
getReg forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup ΣVar x
σ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s o a. Ctx s o a -> DMap ΣVar (Reg s)
σs)
cachedΣ :: ΣVar x -> Ctx s o a -> Defunc x
cachedΣ :: forall x s o a. ΣVar x -> Ctx s o a -> Defunc x
cachedΣ ΣVar x
σ = forall a. a -> Maybe a -> a
fromMaybe (forall a e. Exception e => e -> a
throw (forall x. ΣVar x -> RegisterFault
registerFault ΣVar x
σ)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s x. Reg s x -> Maybe (Defunc x)
getCached forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup ΣVar x
σ forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (rs :: [Type]) s o a x.
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 rs1
σ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Σ :: forall x s o a.
Σ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 = 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
σ (forall s x. Maybe (Code (STRef s x)) -> Maybe (Defunc x) -> Reg s x
Reg (forall a. a -> Maybe a
Just Code (STRef s x)
qref) forall a. Maybe a
Nothing) (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 :: 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
NoRegs Ctx s o a
_ = StaFunc rs s o a x
sub
provideFreeRegisters StaFunc rs s o a x
f (FreeReg ΣVar r
σ Regs rs1
σs) Ctx s o a
ctx = 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
f (forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar r
σ Ctx s o a
ctx)) Regs rs1
σs Ctx s o a
ctx
debugUp :: Ctx s o a -> Ctx s o a
debugUp :: forall s o a. Ctx s o a -> Ctx s o a
debugUp Ctx s o a
ctx = Ctx s o a
ctx {debugLevel :: Int
debugLevel = forall s o a. Ctx s o a -> Int
debugLevel Ctx s o a
ctx forall a. Num a => a -> a -> a
+ Int
1}
debugDown :: Ctx s o a -> Ctx s o a
debugDown :: forall s o a. Ctx s o a -> Ctx s o a
debugDown Ctx s o a
ctx = Ctx s o a
ctx {debugLevel :: Int
debugLevel = forall s o a. Ctx s o a -> Int
debugLevel Ctx s o a
ctx forall a. Num a => a -> a -> a
- Int
1}
nextUnique :: Ctx s o a -> Ctx s o a
nextUnique :: forall s o a. Ctx s o a -> Ctx s o a
nextUnique Ctx s o a
ctx = Ctx s o a
ctx {offsetUniq :: Word
offsetUniq = forall s o a. Ctx s o a -> Word
offsetUniq Ctx s o a
ctx forall a. Num a => a -> a -> a
+ Word
1}
freshUnique :: MonadReader (Ctx s o a) m => (Word -> m b) -> m b
freshUnique :: forall s o a (m :: Type -> Type) b.
MonadReader (Ctx s o a) m =>
(Word -> m b) -> m b
freshUnique Word -> m b
f =
do Word
unique <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall s o a. Ctx s o a -> Word
offsetUniq
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local 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 :: forall s o a. Coins -> Ctx s o a -> Ctx s o a
storePiggy (Coins Int
0 Int
_ Maybe CharPred
_) Ctx s o a
ctx = Ctx s o a
ctx
storePiggy Coins
coins Ctx s o a
ctx = Ctx s o a
ctx {piggies :: Queue Coins
piggies = forall (q :: Type -> Type) a. QueueLike q => a -> q a -> q a
enqueue Coins
coins (forall s o a. Ctx s o a -> Queue Coins
piggies Ctx s o a
ctx), netWorth :: Int
netWorth = forall s o a. Ctx s o a -> Int
netWorth Ctx s o a
ctx forall a. Num a => a -> a -> a
+ Coins -> Int
willConsume Coins
coins}
breakPiggy :: Ctx s o a -> (Coins, Ctx s o a)
breakPiggy :: forall s o a. Ctx s o a -> (Coins, Ctx s o a)
breakPiggy Ctx s o a
ctx =
let (Coins
coins, Queue Coins
piggies') = forall (q :: Type -> Type) a. QueueLike q => q a -> (a, q a)
dequeue (forall s o a. Ctx s o a -> Queue Coins
piggies Ctx s o a
ctx)
in (Coins
coins, Ctx s o a
ctx {piggies :: Queue Coins
piggies = Queue Coins
piggies', netWorth :: Int
netWorth = forall s o a. Ctx s o a -> Int
netWorth Ctx s o a
ctx forall a. Num a => a -> a -> a
- Coins -> Int
willConsume Coins
coins})
hasCoin :: Ctx s o a -> Bool
hasCoin :: forall s o a. Ctx s o a -> Bool
hasCoin = forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s o a. Int -> Ctx s o a -> Maybe Int
canAfford Int
1
isBankrupt :: Ctx s o a -> Bool
isBankrupt :: forall s o a. Ctx s o a -> Bool
isBankrupt = (forall a. Eq a => a -> a -> Bool
== Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s o a. Ctx s o a -> Int
netWorth
spendCoin :: Ctx s o a -> Ctx s o a
spendCoin :: forall s o a. Ctx s o a -> Ctx s o a
spendCoin Ctx s o a
ctx = Ctx s o a
ctx {coins :: Int
coins = forall s o a. Ctx s o a -> Int
coins Ctx s o a
ctx forall a. Num a => a -> a -> a
- Int
1, netWorth :: Int
netWorth = forall s o a. Ctx s o a -> Int
netWorth Ctx s o a
ctx forall a. Num a => a -> a -> a
- Int
1}
giveCoins :: Int -> Ctx s o a -> Ctx s o a
giveCoins :: forall s o a. 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 = forall s o a. Ctx s o a -> Int
coins Ctx s o a
ctx forall a. Num a => a -> a -> a
+ Int
c, netWorth :: Int
netWorth = forall s o a. Ctx s o a -> Int
netWorth Ctx s o a
ctx forall a. Num a => a -> a -> a
+ Int
c}
refundCoins :: Int -> Ctx s o a -> Ctx s o a
refundCoins :: forall s o a. Int -> Ctx s o a -> Ctx s o a
refundCoins Int
c Ctx s o a
ctx =
forall s o a. Int -> Ctx s o a -> Ctx s o a
giveCoins Int
c Ctx s o a
ctx { knownChars :: RewindQueue (Code Char, CharPred, Offset o)
knownChars = forall a. Int -> RewindQueue a -> RewindQueue a
Queue.rewind Int
c (forall s o a.
Ctx s o a -> RewindQueue (Code Char, CharPred, Offset o)
knownChars Ctx s o a
ctx) }
voidCoins :: Ctx s o a -> Ctx s o a
voidCoins :: forall s o a. 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 = forall (q :: Type -> Type) a. QueueLike q => q a
Queue.empty, knownChars :: RewindQueue (Code Char, CharPred, Offset o)
knownChars = forall (q :: Type -> Type) a. QueueLike q => q a
Queue.empty, netWorth :: Int
netWorth = Int
0}
canAfford :: Int -> Ctx s o a -> Maybe Int
canAfford :: forall s o a. Int -> Ctx s o a -> Maybe Int
canAfford Int
n Ctx s o a
ctx = if forall s o a. Ctx s o a -> Int
coins Ctx s o a
ctx forall a. Ord a => a -> a -> Bool
>= Int
n then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Int
n forall a. Num a => a -> a -> a
- forall s o a. Ctx s o a -> Int
coins Ctx s o a
ctx)
addChar :: CharPred -> Code Char -> Offset o -> Ctx s o a -> Ctx s o a
addChar :: forall o s a.
CharPred -> Code Char -> Offset o -> Ctx s o a -> Ctx s o a
addChar CharPred
p Code Char
c Offset o
o Ctx s o a
ctx = Ctx s o a
ctx { knownChars :: RewindQueue (Code Char, CharPred, Offset o)
knownChars = forall (q :: Type -> Type) a. QueueLike q => a -> q a -> q a
enqueue (Code Char
c, CharPred
p, Offset o
o) (forall s o a.
Ctx s o a -> RewindQueue (Code Char, CharPred, Offset o)
knownChars Ctx s o a
ctx) }
readChar :: Ctx s o a
-> CharPred
-> ((Code Char -> Offset o -> Code b) -> Code b)
-> (Code Char -> CharPred -> CharPred -> Offset o -> Ctx s o a -> Code b)
-> Code b
readChar :: forall s o a b.
Ctx s o a
-> CharPred
-> ((Code Char -> Offset o -> Code b) -> Code b)
-> (Code Char
-> CharPred -> CharPred -> Offset o -> Ctx s o a -> Code b)
-> Code b
readChar Ctx s o a
ctx CharPred
pred (Code Char -> Offset o -> Code b) -> Code b
fallback Code Char
-> CharPred -> CharPred -> Offset o -> Ctx s o a -> Code b
k
| Bool
reclaimable = Ctx s o a -> Code b
unsafeReadChar Ctx s o a
ctx
| Bool
otherwise = (Code Char -> Offset o -> Code b) -> Code b
fallback forall a b. (a -> b) -> a -> b
$ \Code Char
c Offset o
o -> Ctx s o a -> Code b
unsafeReadChar (forall o s a.
CharPred -> Code Char -> Offset o -> Ctx s o a -> Ctx s o a
addChar CharPred
Item Code Char
c Offset o
o Ctx s o a
ctx)
where
reclaimable :: Bool
reclaimable = Bool -> Bool
not (forall (q :: Type -> Type) a. QueueLike q => q a -> Bool
Queue.null (forall s o a.
Ctx s o a -> RewindQueue (Code Char, CharPred, Offset o)
knownChars Ctx s o a
ctx))
unsafeReadChar :: Ctx s o a -> Code b
unsafeReadChar Ctx s o a
ctx = let
optimisePred :: (Code Char, CharPred, Offset o) -> (Code Char, CharPred, Offset o)
optimisePred (Code Char
c, CharPred
oldPred, Offset o
o) = (Code Char
c, CharPred -> CharPred -> CharPred
andPred CharPred
oldPred CharPred
pred, Offset o
o)
((Code Char
_, CharPred
oldPred, Offset o
_), RewindQueue (Code Char, CharPred, Offset o)
q) = forall (q :: Type -> Type) a.
QueueLike q =>
(a -> a) -> q a -> (a, q a)
poke (Code Char, CharPred, Offset o) -> (Code Char, CharPred, Offset o)
optimisePred (forall s o a.
Ctx s o a -> RewindQueue (Code Char, CharPred, Offset o)
knownChars Ctx s o a
ctx)
((Code Char
c, CharPred
optPred, Offset o
o), RewindQueue (Code Char, CharPred, Offset o)
q') = forall (q :: Type -> Type) a. QueueLike q => q a -> (a, q a)
dequeue RewindQueue (Code Char, CharPred, Offset o)
q
in Code Char
-> CharPred -> CharPred -> Offset o -> Ctx s o a -> Code b
k Code Char
c CharPred
oldPred CharPred
optPred Offset o
o (Ctx s o a
ctx { knownChars :: RewindQueue (Code Char, CharPred, Offset o)
knownChars = RewindQueue (Code Char, CharPred, Offset o)
q' })
newtype MissingDependency = MissingDependency IMVar deriving anyclass Show MissingDependency
Typeable 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
Exception
newtype OutOfScopeRegister = OutOfScopeRegister IΣVar deriving anyclass Show OutOfScopeRegister
Typeable 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
Exception
newtype IntangibleRegister = IntangibleRegister IΣVar deriving anyclass Show IntangibleRegister
Typeable 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
Exception
newtype RegisterFault = RegisterFault IΣVar deriving anyclass Show RegisterFault
Typeable 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
Exception
missingDependency :: MVar x -> MissingDependency
missingDependency :: forall x. MVar x -> MissingDependency
missingDependency (MVar IMVar
v) = IMVar -> MissingDependency
MissingDependency IMVar
v
outOfScopeRegister :: ΣVar x -> OutOfScopeRegister
outOfScopeRegister :: forall x. ΣVar x -> OutOfScopeRegister
outOfScopeRegister (ΣVar IΣVar
σ) = IΣVar -> OutOfScopeRegister
OutOfScopeRegister IΣVar
σ
intangibleRegister :: ΣVar x -> IntangibleRegister
intangibleRegister :: forall x. ΣVar x -> IntangibleRegister
intangibleRegister (ΣVar IΣVar
σ) = IΣVar -> IntangibleRegister
IntangibleRegister IΣVar
σ
registerFault :: ΣVar x -> RegisterFault
registerFault :: forall x. Σ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 μ" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IMVar
μ forall a. [a] -> [a] -> [a]
++ String
" has not been compiled"
instance Show OutOfScopeRegister where show :: OutOfScopeRegister -> String
show (OutOfScopeRegister IΣVar
σ) = String
"Register r" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IΣVar
σ forall a. [a] -> [a] -> [a]
++ String
" is out of scope"
instance Show IntangibleRegister where show :: IntangibleRegister -> String
show (IntangibleRegister IΣVar
σ) = String
"Register r" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IΣVar
σ 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" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IΣVar
σ forall a. [a] -> [a] -> [a]
++ String
" from cache has failed"