{-# LANGUAGE DeriveAnyClass,
             MagicHash,
             DerivingStrategies,
             UnboxedTuples #-}
{-|
Module      : Parsley.Internal.Backend.Machine.Types.Context
Description : Fully static context required to generate a parser
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

This module contains the compile-time state of a parser, which is
used to aid code generation.

@since 1.4.0.0
-}
module Parsley.Internal.Backend.Machine.Types.Context (
    -- * Core Data-types
    Ctx,
    QJoin,
    emptyCtx,

    -- * Subroutines
    -- $sub-doc
    insertSub, askSub,

    -- * Join Points
    -- $join-doc
    insertΦ, askΦ,

    -- * Registers
    -- $reg-doc

    -- ** Putters
    insertNewΣ, cacheΣ,
    -- ** Getters
    concreteΣ, cachedΣ,
    takeFreeRegisters,

    -- * Debug Level Tracking
    -- $debug-doc
    debugUp, debugDown, debugLevel,

    -- * Unique Offsets
    -- $offset-doc
    freshUnique, nextUnique,

    -- * Token Credit System (Piggy-banks)
    -- $piggy-doc

    -- ** Modifiers
    storePiggy, breakPiggy, spendCoin, giveCoins, refundCoins, voidCoins,
    -- ** Getters
    coins, hasCoin, isBankrupt, canAfford,
    -- ** Input Reclamation
    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)

-- Core Data-types
{-|
The `Ctx` stores information that aids or facilitates the generation of parser code,
but its components are fully static and do not materialise as runtime values, but
may form part of the generated code.

@since 1.0.0.0
-}
data Ctx s o a = Ctx { Ctx s o a -> DMap MVar (QSubroutine s o a)
μs         :: DMap MVar (QSubroutine s o a)     -- ^ Map of subroutine bindings.
                     , Ctx s o a -> DMap ΦVar (QJoin s o a)
φs         :: DMap ΦVar (QJoin s o a)           -- ^ Map of join point bindings.
                     , Ctx s o a -> DMap ΣVar (Reg s)
σs         :: DMap ΣVar (Reg s)                 -- ^ Map of available registers.
                     , Ctx s o a -> Int
debugLevel :: Int                               -- ^ Approximate depth of debug combinator.
                     , Ctx s o a -> Int
coins      :: Int                               -- ^ Number of tokens free to consume without length check.
                     , Ctx s o a -> Word
offsetUniq :: Word                              -- ^ Next unique offset identifier.
                     , Ctx s o a -> Queue Coins
piggies    :: Queue Coins                       -- ^ Queue of future length check credit.
                     , Ctx s o a -> RewindQueue (Code Char, Input o)
knownChars :: RewindQueue (Code Char, Input o) -- ^ Characters that can be reclaimed on backtrack.
                     }

{-|
`QJoin` represents Φ-nodes in the generated parser, and is represented
as a `Parsley.Internal.Backend.Machine.Types.Statics.StaCont`.

@since 1.0.0.0
-}
newtype QJoin s o a x = QJoin { QJoin s o a x -> StaCont s o a x
unwrapJoin :: StaCont s o a x }

{-|
Creates an empty `Ctx` populated with a map of the top-level (recursive)
bindings: information about their required free-registers is included.

@since 1.0.0.0
-}
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

-- Subroutines
{- $sub-doc
Subroutines are the representations of let-bindings or recursive parsers
in the original user program. They are factored out to prevent code-explosion.

The names of these bindings are helpfully stored within the `Ctx` and can be
accessed statically. While the initial context is always populated with the
top-level recursive bindings, additional bindings can be added "dynamically"
during evaluation, for instance iterative bindings and recursive bindings that
capture their free-registers.
-}
{-|
Registers a new subroutine into the context, which will be available
according to "local" @Reader@ semantics.

@since 1.2.0.0
-}
insertSub :: MVar x                -- ^ The name of the binding.
          -> StaSubroutine s o a x -- ^ The binding to register.
          -> Ctx s o a             -- ^ The current context.
          -> Ctx s o a             -- ^ The new context.
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)}

{-|
Fetches a binding from the context according to its name (See `Parsley.Internal.Core.Identifiers.MVar`).
In the (hopefully impossible!) event that it is not found in the map, will throw a @MissingDependency@
exception. If this binding had free registers, these are generously provided by the `Ctx`.

@since 1.2.0.0
-}
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)

-- Join Points
{- $join-doc
Similar to the subroutines, join points (or Φ-nodes) are used by the parsley engine
to factor out common branches of code. When generated, access to these bindings is
available via the `Ctx`.
-}
{-|
Registers a new binding into the `Ctx` so that it can be retrieved later. Binding
expires according to "local" @Reader@ semantics.

@since 1.0.0.0
-}
insertΦ :: ΦVar x          -- ^ The name of the new binding.
        -> StaCont s o a x -- ^ The binding to add.
        -> Ctx s o a       -- ^ The old context.
        -> Ctx s o a       -- ^ The new context.
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)}

{-|
Fetches a binding from the `Ctx`.

@since 1.2.0.0
-}
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)

-- Registers
{- $reg-doc
Registers are used within parsley to persist state across different parts of a parser.
Across recursion and call-boundaries, these materialise as @STRef@s. These are stored
in the `Ctx` and can be looked up when required.

However, parsley does not mandate that registers /must/ exist in this form. Registers
can be subject to caching, where a register's static "most-recently known" may be
stored within the `Ctx` in addition to the "true" binding. This can, in effect, mean
that registers do not exist at runtime. Both forms of register data can be extracted,
however exceptions will guard against mis-management.
-}
data Reg s x = Reg { Reg s x -> Maybe (Code (STRef s x))
getReg    :: Maybe (Code (STRef s x)) -- ^ The "true" register
                   , Reg s x -> Maybe (Defunc x)
getCached :: Maybe (Defunc x) }       -- ^ The "most-recently known" value

{-|
Registers a recently created register into the `Ctx`. This must be provided with
the original value in the register, which is injected into the cache.

@since 1.0.0.0
-}
insertNewΣ :: ΣVar x                   -- ^ The name of the register.
           -> Maybe (Code (STRef s x)) -- ^ The runtime representation, if available.
           -> Defunc x                 -- ^ The initial value stored into the register.
           -> Ctx s o a                -- ^ The old context.
           -> Ctx s o a                -- ^ The new context.
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)}

{-|
Updated the "last-known value" of a register in the cache.

@since 1.0.0.0
-}
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
σ)

{-|
Fetches a known to be concrete register (i.e. one that must be materialised
at runtime as an @STRef@). If this register does not exist, this throws an
@IntangibleRegister@ exception.

@since 1.0.0.0
-}
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)

{-|
Fetches the cached "last-known value" of a register. If the cache is unaware of
this value, a @RegisterFault@ exception is thrown.

@since 1.0.0.0
-}
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))

{-|
When a binding is generated, it needs to generate function arguments for each of the
free registers it requires. This is performed by this function, which also adds each
of these freshly bound registers into the `Ctx`. Has the effect of converting a
`Parsley.Internal.Backend.Machine.Types.Dynamics.DynSubroutine` into a
`Parsley.Internal.Backend.Machine.Types.Dynamics.DynFunc`.

@since 1.2.0.0
-}
-- This needs to return a DynFunc: it is fed back to shared territory
takeFreeRegisters :: Regs rs                              -- ^ The free registers demanded by the binding.
                  -> Ctx s o a                            -- ^ The old context.
                  -> (Ctx s o a -> DynSubroutine s o a x) -- ^ Given the new context, function that produces the subroutine.
                  -> DynFunc rs s o a x                   -- ^ The newly produced dynamic function.
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)}

-- This needs to take a StaFunc, it is fed back via `askSub`
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

-- Debug Level Tracking
{- $debug-doc
The debug combinator generates runtime diagnostic information. To make this more ergonomic,
it would be nice to indent nested debug info. To do this perfectly, a debug level that controls
indentation would need to be added to `Parsley.Internal.Backend.Machine.Types.State.Γ`. This
is problematic since, without a lot of work and complexity, it would introduce a runtime penalty
for not just debug parsers, but all other parsers too. As a compromise, the debug level is stored
purely statically in the `Ctx`: the consequence is that the indentation level resets across a
call-boundary.
-}
{-|
Increase the debug level for the forseeable static future.

@since 1.0.0.0
-}
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}

{-|
Decrease the debug level for the forseeable static future.

@since 1.0.0.0
-}
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}

-- Unique Offsets
{- $offset-doc
The `Parsley.Internal.Backend.Machine.Types.Offset.Offset` type refines dynamic offsets
with statically known properties such as input consumed and the source of the offset.
These sources are unique and must be generated statically, with "local" @Reader@ semantics.
This means that the `Ctx` lends itself nicely to managing the pool of fresh offset names.
-}
{-|
Advances the unique identifier stored in the `Ctx`. This is used to /skip/ a given name.

@since 1.4.0.0
-}
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}

{-|
Generate a fresh name that is valid for the scope of the provided continuation.

@since 1.4.0.0
-}
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)

-- Token Credit System (Piggy-banks)
{- $piggy-doc
Parsley has analysis in place to factor out length checks when it is statically known that
/n/ tokens must be consumed in order for a parser to succeed. Part of this analysis is the
cut analysis performed in the frontend, and then the coins analysis in the backend during
code generation. The meta instructions that reference "coins" interact with a system during
interpretation called the "Piggy-bank" system: this is all stored and accessed via the `Ctx`.

The system works like this:

* The `Ctx` stores two components: some coins and some piggybanks.
* When there are coins present in the `Ctx`, these can be "spent" to read a token without
  emitting a length check for it (the guarantee is that a length check was generated to
  get hold of those coins).
* When the coins run out a piggy-bank can be broken to get more coins: this should generate
  a length check for value of the coins in the bank
* When all the piggy-banks are exhausted, a length check must be generated for each
  token that is consumed.
* When adding coins into the system, if the `Ctx` is bankrupt, then the coins are added
  immediately along with a length check, otherwise a piggy-bank is added.

These are the basic principles behind this system, and it works effectively. There are some
extra edge-case operations that are described in their corresponding documentation. The
reason why piggy-banks are stored in the context and /not/ consumed immediately to add to
the coin count is so that length checks are delayed to the last possible moment: you should
have used all of your current allocation before asking for more!

In addition to this above system, Parsley stores previously read characters in a rewind queue:
this means that when backtracking is performed (i.e. when looking ahead) the characters can be
statically rewound and made available for free.
-}
{-|
Place a piggy-bank into the reserve, delaying the corresponding length check until it is
broken.

@since 1.5.0.0
-}
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)}

{-|
Break the next piggy-bank in the queue, and fill the coins in return.

__Note__: This should generate a length check when used!

@since 1.0.0.0
-}
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'}

{-|
Does the context have coins available?

@since 1.0.0.0
-}
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

{-|
Is it the case that there are no coins /and/ no piggy-banks remaining?

@since 1.0.0.0
-}
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)

{-|
Spend a single coin, used when a token is consumed.

@since 1.0.0.0
-}
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}

{-|
Adds coins into the current supply.

@since 1.5.0.0
-}
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}

{-|
Adds coins into the current supply.

@since 1.5.0.0
-}
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)
                        }

{-|
Removes all coins and piggy-banks, such that @isBankrupt == True@.

@since 1.0.0.0
-}
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}

{-|
Asks if the current coin total can afford a charge of \(n\) characters.

This is used by `Parsley.Internal.Backend.Instructions.DrainCoins`, which will have to emit a full length check
of size \(n\) if this quota cannot be reached.

@since 1.5.0.0
-}
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

{-|
Caches a known character and the next offset into the context so that it
can be retrieved later.

@since 1.5.0.0
-}
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) }

{-|
Reads a character from the context's retrieval queue if one exists.
If not, reads a character from another given source (and adds it to the
rewind buffer).

@since 1.5.0.0
-}
readChar :: Ctx s o a                                     -- ^ The original context.
         -> ((Code Char -> Input o -> Code b) -> Code b)  -- ^ The fallback source of input.
         -> (Code Char -> Input o -> Ctx s o a -> Code b) -- ^ The continuation that needs the read characters and updated context.
         -> 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 })

-- Exceptions
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"