{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE AllowAmbiguousTypes,
             ConstrainedClassMethods,
             ConstraintKinds,
             ImplicitParams,
             MagicHash,
             NamedFieldPuns,
             PatternSynonyms,
             RecordWildCards,
             TypeApplications,
             UnboxedTuples #-}
{-|
Module      : Parsley.Internal.Backend.Machine.Ops
Description : Higher-level operations used by evaluation.
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

This module contains all the relevant operations for the evaluation
of a machine. These are used by "Parsley.Internal.Backend.Machine.Eval"
to provide the various instruction interpretations.

@since 1.0.0.0
-}
module Parsley.Internal.Backend.Machine.Ops (
    -- * Core Machine Operations
    dup, returnST,
    -- ** Abstracted Input Operations
    sat, emitLengthCheck, fetch,
    -- ** Register Operations
    newΣ, writeΣ, readΣ,
    -- ** Handler Operations
    -- *** Basic handlers and operations
    fatal, raise,
    -- *** Handler preparation
    buildHandler, buildYesHandler, buildIterYesHandler,
    -- *** Handler binding
    bindAlwaysHandler, bindSameHandler,
    -- ** Continuation Operations
    -- *** Basic continuations and operations
    halt, noreturn,
    resume, callWithContinuation, callCC,
    -- *** Continuation preparation
    suspend,
    -- ** Join Point Operations
    setupJoinPoint,
    -- ** Iteration Operations
    bindIterAlways,
    bindIterSame,
    -- ** Recursion Operations
    buildRec,
    -- ** Marshalling Operations
    dynHandler, dynCont,
    -- ** Log Operations
    logHandler, preludeString,
    -- ** Convenience Types
    Ops, LogHandler, StaHandlerBuilder, StaYesHandler,
    -- * Re-exports from "Parsley.Internal.Backend.Machine.InputOps"
    HandlerOps, JoinBuilder, RecBuilder, PositionOps, MarshalOps, LogOps
  ) where

import Control.Monad                                              (liftM2)
import Control.Monad.Reader                                       (ask, local)
import Control.Monad.ST                                           (ST)
import Data.List                                                  (mapAccumL)
import Data.STRef                                                 (writeSTRef, readSTRef, newSTRef)
import Data.Void                                                  (Void)
import Debug.Trace                                                (trace)
import Parsley.Internal.Backend.Machine.BindingOps
import Parsley.Internal.Backend.Machine.Defunc                    (Defunc(INPUT), genDefunc, _if, pattern FREEVAR)
import Parsley.Internal.Backend.Machine.Identifiers               (MVar, ΦVar, ΣVar)
import Parsley.Internal.Backend.Machine.InputOps                  (PositionOps(..), LogOps(..), InputOps, DynOps, next, uncons, check, asDyn, asSta)
import Parsley.Internal.Backend.Machine.InputRep                  (StaRep)
import Parsley.Internal.Backend.Machine.Instructions              (Access(..))
import Parsley.Internal.Backend.Machine.LetBindings               (Regs(..), Metadata(failureInputCharacteristic, successInputCharacteristic))
import Parsley.Internal.Backend.Machine.Types                     (MachineMonad, Machine(..), run)
import Parsley.Internal.Backend.Machine.Types.Context
import Parsley.Internal.Backend.Machine.Types.Dynamics            (DynFunc, DynCont, DynHandler)
import Parsley.Internal.Backend.Machine.Types.Input               (Input(..), Input#(..), toInput, fromInput, chooseInput)
import Parsley.Internal.Backend.Machine.Types.Input.Offset        (moveOne)
import Parsley.Internal.Backend.Machine.Types.InputCharacteristic (InputCharacteristic)
import Parsley.Internal.Backend.Machine.Types.State               (Γ(..), OpStack(..))
import Parsley.Internal.Backend.Machine.Types.Statics
import Parsley.Internal.Common                                    (One, Code, Vec(..), Nat(..))
import Parsley.Internal.Common.THUtils                            (eta)
import System.Console.Pretty                                      (color, Color(Green, White, Red, Blue))

import Parsley.Internal.Backend.Machine.Types.Input.Offset as Offset (Offset(..), updateDeepestKnown)
import qualified Parsley.Internal.Opt   as Opt

{- General Operations -}
{-|
Creates a let-binding that allows the same value to be
used multiple times without re-computation.

@since 1.0.0.0
-}
dup :: (?flags :: Opt.Flags) => Defunc x -> (Defunc x -> Code r) -> Code r
dup :: forall x r.
(?flags::Flags) =>
Defunc x -> (Defunc x -> Code r) -> Code r
dup (FREEVAR Code x
x) Defunc x -> Code r
k = Defunc x -> Code r
k (forall a. (?flags::Flags) => Code a -> Defunc a
FREEVAR Code x
x)
dup (INPUT Input x
o) Defunc x -> Code r
k = Defunc x -> Code r
k (forall a. Input a -> Defunc a
INPUT Input x
o)
dup Defunc x
x Defunc x -> Code r
k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]

{-|
This is just plain ol' `return`. It is given a concrete
type here so that "Ambiuous Type Error" is avoided in the
generated code.

@since 1.0.0.0
-}
{-# INLINE returnST #-}
returnST :: forall s a. a -> ST s a
returnST :: forall s a. a -> ST s a
returnST = forall (m :: Type -> Type) a. Monad m => a -> m a
return @(ST s)

{- Abstracted Input Operations -}
{-|
Given a predicate, a continuation that accepts an updated state `Γ`,
code to execute on failure, and a state @γ@, tries to read a character
from the input within @γ@, executing the failure code if it does not
exist or does not match.

@since 2.1.0.0
-}
sat :: (?flags :: Opt.Flags)
    => (Defunc Char -> Defunc Bool)                        -- ^ Predicate to test the character with.
    -> Code Char                                           -- ^ The character to test against.
    -> (Defunc Char -> Code b)                             -- ^ Code to execute on success.
    -> Code b                                              -- ^ Code to execute on failure.
    -> Code b
sat :: forall b.
(?flags::Flags) =>
(Defunc Char -> Defunc Bool)
-> Code Char -> (Defunc Char -> Code b) -> Code b -> Code b
sat Defunc Char -> Defunc Bool
p Code Char
c Defunc Char -> Code b
good Code b
bad = let v :: Defunc Char
v = forall a. (?flags::Flags) => Code a -> Defunc a
FREEVAR Code Char
c in forall a.
(?flags::Flags) =>
Defunc Bool -> Code a -> Code a -> Code a
_if (Defunc Char -> Defunc Bool
p Defunc Char
v) (Defunc Char -> Code b
good Defunc Char
v) Code b
bad

{-|
Consumes the next character and adjusts the offset to match.

@since 1.8.0.0
-}
fetch :: (?ops :: InputOps (StaRep o))
      => Offset o -> (Code Char -> Offset o -> Code b) -> Code b
fetch :: forall o b.
(?ops::InputOps (StaRep o)) =>
Offset o -> (Code Char -> Offset o -> Code b) -> Code b
fetch Offset o
input Code Char -> Offset o -> Code b
k = forall rep a.
(?ops::InputOps rep) =>
rep -> (Code Char -> rep -> Code a) -> Code a
next (forall o. Offset o -> StaRep o
offset Offset o
input) forall a b. (a -> b) -> a -> b
$ \Code Char
c StaRep o
offset' -> Code Char -> Offset o -> Code b
k Code Char
c (forall o. Offset o -> StaRep o -> Offset o
moveOne Offset o
input StaRep o
offset')

{-|
Emits a length check for a number of characters \(n\) in the most efficient
way it can. It takes two continuations a @good@ and a @bad@: the @good@ is used
when the \(n\) characters are available and the @bad@ when they are not.

@since 2.3.0.0
-}
emitLengthCheck :: (?ops :: InputOps (StaRep o))
                => Int                                             -- ^ The number of required characters \(n\).
                -> Int                                             -- ^ The number of characters to prefetch \(m\).
                -> Maybe (Code Char -> Code a -> Code a)           -- ^ An optional check for the head character.
                -> (Offset o -> [(Code Char, Offset o)] -> Code a) -- ^ The good continuation if \(n\) characters are available.
                -> Code a                                          -- ^ The bad continuation if the characters are unavailable.
                -> Offset o                                        -- ^ The input to test on.
                -> (Offset o -> StaRep o)
                -> Code a
emitLengthCheck :: forall o a.
(?ops::InputOps (StaRep o)) =>
Int
-> Int
-> Maybe (Code Char -> Code a -> Code a)
-> (Offset o -> [(Code Char, Offset o)] -> Code a)
-> Code a
-> Offset o
-> (Offset o -> StaRep o)
-> Code a
emitLengthCheck Int
n Int
m Maybe (Code Char -> Code a -> Code a)
headCheck Offset o -> [(Code Char, Offset o)] -> Code a
good Code a
bad Offset o
input Offset o -> StaRep o
sel = forall rep a.
(?ops::InputOps rep) =>
Int
-> Int
-> rep
-> Maybe (Code Char -> Code a -> Code a)
-> (rep -> [(Code Char, rep)] -> Code a)
-> Code a
-> Code a
check Int
n Int
m (Offset o -> StaRep o
sel Offset o
input) Maybe (Code Char -> Code a -> Code a)
headCheck StaRep o -> [(Code Char, StaRep o)] -> Code a
good' Code a
bad
  where good' :: StaRep o -> [(Code Char, StaRep o)] -> Code a
good' StaRep o
deepestKnown = let input' :: Offset o
input' = forall o. StaRep o -> Offset o -> Offset o
updateDeepestKnown StaRep o
deepestKnown Offset o
input in Offset o -> [(Code Char, Offset o)] -> Code a
good Offset o
input' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: Type -> Type} {o} {a}.
Traversable t =>
Offset o -> t (a, StaRep o) -> t (a, Offset o)
feed Offset o
input'
        feed :: Offset o -> t (a, StaRep o) -> t (a, Offset o)
feed Offset o
input' = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\Offset o
off (a
c, StaRep o
rep) -> let off' :: Offset o
off' = forall o. Offset o -> StaRep o -> Offset o
moveOne Offset o
off StaRep o
rep in (Offset o
off', (a
c, Offset o
off'))) Offset o
input'

{- Register Operations -}
{-|
Depending on the access type either generates the code for a new register and
registers it with the `Ctx`, or generates a binding with `dup` and registers
that in the `Ctx` cache.

@since 1.0.0.0
-}
newΣ :: (?flags :: Opt.Flags) => ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r)
newΣ :: forall x s o a r.
(?flags::Flags) =>
ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s r))
-> Ctx s o a
-> Code (ST s r)
newΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = forall x r.
(?flags::Flags) =>
Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s r)
k (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
σ forall a. Maybe a
Nothing Defunc x
dupx Ctx s o a
ctx)
newΣ ΣVar x
σ Access
Hard Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = forall x r.
(?flags::Flags) =>
Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> [||
    do ref <- newSTRef $$(genDefunc dupx)
       $$(k (insertNewΣ σ (Just [||ref||]) dupx ctx))
  ||]

{-|
Depending on the access type, either generates the code for a write to a register
(and caching that result) or updates the cache with the register's new value.

@since 1.0.0.0
-}
writeΣ :: (?flags :: Opt.Flags) => ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r)
writeΣ :: forall x s o a r.
(?flags::Flags) =>
ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s r))
-> Ctx s o a
-> Code (ST s r)
writeΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = forall x r.
(?flags::Flags) =>
Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s r)
k (forall x s o a. ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a
cacheΣ ΣVar x
σ Defunc x
dupx Ctx s o a
ctx)
writeΣ ΣVar x
σ Access
Hard Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = let ref :: Code (STRef s x)
ref = forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar x
σ Ctx s o a
ctx in forall x r.
(?flags::Flags) =>
Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> [||
    do writeSTRef $$ref $$(genDefunc dupx)
       $$(k (cacheΣ σ dupx ctx))
  ||]

{-|
Depending on the access type, either generates a read from a register or fetches
the value from the cache and feeds it to a continuation.

@since 1.0.0.0
-}
readΣ :: (?flags :: Opt.Flags) => ΣVar x -> Access -> (Defunc x -> Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r)
readΣ :: forall x s o a r.
(?flags::Flags) =>
ΣVar x
-> Access
-> (Defunc x -> Ctx s o a -> Code (ST s r))
-> Ctx s o a
-> Code (ST s r)
readΣ ΣVar x
σ Access
Soft Defunc x -> Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = Defunc x -> Ctx s o a -> Code (ST s r)
k (forall x s o a. ΣVar x -> Ctx s o a -> Defunc x
cachedΣ ΣVar x
σ Ctx s o a
ctx) Ctx s o a
ctx
readΣ ΣVar x
σ Access
Hard Defunc x -> Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = let ref :: Code (STRef s x)
ref = forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar x
σ Ctx s o a
ctx in [||
    do x <- readSTRef $$ref
       $$(let fv = FREEVAR [||x||] in k fv (cacheΣ σ fv ctx))
  ||]

{- Handler Operations -}
-- Basic handlers and operations
{-|
This is the root-most handler, when it is executed the parser fails immediately
by returning @Nothing@.

@since 1.2.0.0
-}
fatal :: AugmentedStaHandler s o a
fatal :: forall s o a. AugmentedStaHandler s o a
fatal = forall o s a.
Maybe (Input o) -> StaHandler# s o a -> AugmentedStaHandler s o a
augmentHandlerSta forall a. Maybe a
Nothing (forall a b. a -> b -> a
const [|| returnST Nothing ||])

{-|
Fails by evaluating the next handler with the current input. Makes
use of `staHandlerEval` to make use of static information available
about the state of the input (since 1.4.0.0).

@since 1.0.0.0
-}
raise :: (DynOps o, ?flags :: Opt.Flags) => Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))
raise :: forall o s (xs :: [Type]) (n :: Nat) r a.
(DynOps o, ?flags::Flags) =>
Γ s o xs ('Succ n) r a -> Code (ST s (Maybe a))
raise Γ s o xs ('Succ n) r a
γ = let VCons AugmentedStaHandler s o a
h Vec n1 (AugmentedStaHandler s o a)
_ = forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs ('Succ n) r a
γ in forall o s a.
(DynOps o, ?flags::Flags) =>
AugmentedStaHandler s o a -> Input o -> Code (ST s (Maybe a))
staHandlerEval AugmentedStaHandler s o a
h (forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs ('Succ n) r a
γ)

-- Handler preparation
{-|
Converts a partially evaluated parser into a handler: this is done by
completing the evaluation in the context of a future offset, and taking
a captured offset and pushing it to the stack. Returns a `StaHandlerBuilder`,
which takes the captured offset as the first argument.

@since 1.2.0.0
-}
buildHandler :: DynOps o
             => Γ s o xs n r a                                  -- ^ State to execute the handler with.
             -> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a))) -- ^ Partial parser accepting the modified state.
             -> Word                                            -- ^ The unique identifier for the offset on failure.
             -> StaHandlerBuilder s o a
buildHandler :: forall o s (xs :: [Type]) (n :: Nat) r a.
DynOps o =>
Γ s o xs n r a
-> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandlerBuilder s o a
buildHandler Γ s o xs n r a
γ Γ s o (o : xs) n r a -> Code (ST s (Maybe a))
h Word
u Input o
c = forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# forall a b. (a -> b) -> a -> b
$ \Input# o
inp -> Γ s o (o : xs) n r a -> Code (ST s (Maybe a))
h (Γ s o xs n r a
γ {operands :: OpStack (o : xs)
operands = forall x (xs1 :: [Type]).
Defunc x -> OpStack xs1 -> OpStack (x : xs1)
Op (forall a. Input a -> Defunc a
INPUT Input o
c) (forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o xs n r a
γ), input :: Input o
input = forall o. DynOps o => Word -> Input# o -> Input o
toInput Word
u Input# o
inp})

{-|
Converts a partially evaluated parser into a "yes" handler: this means that
the handler /always/ knows that the inputs are equal, so does not require
both a captured and a current offset. Otherwise, is similar to `buildHandler`.

@since 2.1.0.0
-}
buildYesHandler :: Γ s o xs n r a
                -> (Γ s o xs n r a -> Code (ST s (Maybe a)))
                -> StaYesHandler s o a
buildYesHandler :: forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> StaYesHandler s o a
buildYesHandler Γ s o xs n r a
γ Γ s o xs n r a -> Code (ST s (Maybe a))
h Input o
inp = Γ s o xs n r a -> Code (ST s (Maybe a))
h (Γ s o xs n r a
γ {input :: Input o
input = Input o
inp})

{-|
Converts a partially evaluated parser into a "yes" handler: this means that
the handler /always/ knows that the inputs are equal, so does not require
both a captured and a current offset. Otherwise, is similar to `buildHandler`.

@since 2.1.0.0
-}
buildIterYesHandler :: DynOps o
                    => Γ s o xs n r a
                    -> (Γ s o xs n r a -> Code (ST s (Maybe a)))
                    -> Word
                    -> StaHandler s o a
buildIterYesHandler :: forall o s (xs :: [Type]) (n :: Nat) r a.
DynOps o =>
Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandler s o a
buildIterYesHandler Γ s o xs n r a
γ Γ s o xs n r a -> Code (ST s (Maybe a))
h Word
u = forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> StaYesHandler s o a
buildYesHandler Γ s o xs n r a
γ Γ s o xs n r a -> Code (ST s (Maybe a))
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o. DynOps o => Word -> Input# o -> Input o
toInput Word
u)

-- Handler binding
{-|
Wraps around `bindHandler#` to create a binding for "always" handlers, which always
perform the same action regardless of if the captured and current offsets match or
not.

@since 1.4.0.0
-}
bindAlwaysHandler :: forall s o xs n r a b. HandlerOps o
                  => Γ s o xs n r a                    -- ^ The state from which to capture the offset.
                  -> Bool                              -- ^ Whether or not a binding is required
                  -> StaHandlerBuilder s o a           -- ^ The handler waiting to receive the captured offset and be bound.
                  -> (Γ s o xs (Succ n) r a -> Code b) -- ^ The parser to receive the binding.
                  -> Code b
bindAlwaysHandler :: forall s o (xs :: [Type]) (n :: Nat) r a b.
HandlerOps o =>
Γ s o xs n r a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs ('Succ n) r a -> Code b)
-> Code b
bindAlwaysHandler Γ s o xs n r a
γ Bool
needed StaHandlerBuilder s o a
h Γ s o xs ('Succ n) r a -> Code b
k = forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
needed (forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
h (forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ))) forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qh ->
  Γ s o xs ('Succ n) r a -> Code b
k (Γ s o xs n r a
γ {handlers :: Vec ('Succ n) (AugmentedStaHandler s o a)
handlers = forall a (n1 :: Nat). a -> Vec n1 a -> Vec ('Succ n1) a
VCons (forall o s a.
Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (forall a. a -> Maybe a
Just (forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ)) StaHandler s o a
qh) (forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs n r a
γ)})

{-|
Wraps around `bindHandler#` to create /three/ bindings for a handler that acts
differently depending on whether inputs match or not. The three bindings are
for the case where they are the same, the case where they differ, and the case
where they are unknown (which is defined in terms of the previous two).

@since 2.1.0.0
-}
bindSameHandler :: forall s o xs n r a b. (HandlerOps o, PositionOps (StaRep o), DynOps o)
                => Γ s o xs n r a                    -- ^ The state from which to capture the offset.
                -> Bool                              -- ^ Is a binding required for the matching handler?
                -> StaYesHandler s o a               -- ^ The handler that handles matching input.
                -> Bool                              -- ^ Is a binding required for the mismatched handler?
                -> StaHandlerBuilder s o a           -- ^ The handler that handles mismatched input.
                -> (Γ s o xs (Succ n) r a -> Code b) -- ^ The parser to receive the composite handler.
                -> Code b
bindSameHandler :: forall s o (xs :: [Type]) (n :: Nat) r a b.
(HandlerOps o, PositionOps (StaRep o), DynOps o) =>
Γ s o xs n r a
-> Bool
-> StaYesHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs ('Succ n) r a -> Code b)
-> Code b
bindSameHandler Γ s o xs n r a
γ Bool
yesNeeded StaYesHandler s o a
yes Bool
noNeeded StaHandlerBuilder s o a
no Γ s o xs ('Succ n) r a -> Code b
k =
  forall a b. Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# Bool
yesNeeded (StaYesHandler s o a
yes (forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ)) forall a b. (a -> b) -> a -> b
$ \Code (ST s (Maybe a))
qyes ->
    forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
noNeeded (forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
no (forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ))) forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qno ->
      let handler :: Input# o -> Code (ST s (Maybe a))
handler Input# o
inp = [||if $$(same (offset (off (input γ))) (asSta @o (off# inp))) then $$qyes else $$(staHandler# qno inp)||]
      in forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# @o Bool
True Input# o -> Code (ST s (Maybe a))
handler forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qhandler ->
          Γ s o xs ('Succ n) r a -> Code b
k (Γ s o xs n r a
γ {handlers :: Vec ('Succ n) (AugmentedStaHandler s o a)
handlers = forall a (n1 :: Nat). a -> Vec n1 a -> Vec ('Succ n1) a
VCons (forall o s a.
Input o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
augmentHandlerFull (forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ) StaHandler s o a
qhandler Code (ST s (Maybe a))
qyes StaHandler s o a
qno) (forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs n r a
γ)})

{- Continuation Operations -}
-- Basic continuations and operations
{-|
The root-most return continuation, this is used when the top-level
parser returns: it returns the result with @Just@ and terminates
the entire parser.

@since 1.2.0.0
-}
halt :: StaCont s o a a
halt :: forall s o a. StaCont s o a a
halt = forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont forall a b. (a -> b) -> a -> b
$ \Code a
x Input# o
_ -> [||returnST (Just $$x)||]

{-|
This continuation is used for binding that never return, which is
enforced by the `Void` in the type. This signifies that a binding
may only exit on failure, which is the case with iterating parsers.

@since 1.2.0.0
-}
noreturn :: StaCont s o a Void
noreturn :: forall s o a. StaCont s o a Void
noreturn = forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"Return is not permitted here"

{-|
Executes a given continuation (which may be a return continuation or a
join point) taking the required components from the state `Γ`.

@since 1.2.0.0
-}
resume :: (DynOps o, ?flags :: Opt.Flags) => StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
resume :: forall o s a x (xs :: [Type]) (n :: Nat) r.
(DynOps o, ?flags::Flags) =>
StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
resume StaCont s o a x
k Γ s o (x : xs) n r a
γ = let Op Defunc x
Defunc x
x OpStack xs1
_ = forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o (x : xs) n r a
γ in forall s o a x. StaCont s o a x -> StaCont# s o a x
staCont# StaCont s o a x
k (forall a. (?flags::Flags) => Defunc a -> Code a
genDefunc Defunc x
x) (forall o. DynOps o => Input o -> Input# o
fromInput (forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o (x : xs) n r a
γ))

{-|
A form of @callCC@, this calls a subroutine with a given return continuation
passed to it. This may be the current continuation, but also may just be a
previous return continuation in the case of a tail call.

@since 1.8.0.0
-}
callWithContinuation :: (MarshalOps o, DynOps o)
                     => StaSubroutine s o a x           -- ^ The subroutine @sub@ that will be called.
                     -> StaCont s o a x                 -- ^ The return continuation for the subroutine.
                     -> Input o                         -- ^ The input to feed to @sub@.
                     -> Vec (Succ n) (AugmentedStaHandler s o a) -- ^ The stack from which to obtain the handler to pass to @sub@.
                     -> Code (ST s (Maybe a))
callWithContinuation :: forall o s a x (n :: Nat).
(MarshalOps o, DynOps o) =>
StaSubroutine s o a x
-> StaCont s o a x
-> Input o
-> Vec ('Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
callWithContinuation StaSubroutine s o a x
sub StaCont s o a x
ret Input o
input (VCons AugmentedStaHandler s o a
h Vec n1 (AugmentedStaHandler s o a)
_) = forall s o a x. StaSubroutine s o a x -> StaSubroutine# s o a x
staSubroutine# StaSubroutine s o a x
sub (forall s o a x. MarshalOps o => StaCont s o a x -> DynCont s o a x
dynCont StaCont s o a x
ret) (forall s o a.
MarshalOps o =>
AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
dynHandler AugmentedStaHandler s o a
h (Metadata -> InputCharacteristic
failureInputCharacteristic (forall s o a x. StaSubroutine s o a x -> Metadata
meta StaSubroutine s o a x
sub))) (forall o. DynOps o => Input o -> Input# o
fromInput Input o
input)

-- Continuation preparation
{-|
Converts a partial parser into a return continuation in a manner similar
to `buildHandler`.

@since 1.8.0.0
-}
suspend :: (?flags :: Opt.Flags)
        => (Γ s o (x : xs) n r a -> Code (ST s (Maybe a))) -- ^ The partial parser to turn into a return continuation.
        -> Γ s o xs n r a                                  -- ^ The state to execute the continuation with.
        -> (Input# o -> Input o)                           -- ^ Function used to generate the offset
        -> StaCont s o a x
suspend :: forall s o x (xs :: [Type]) (n :: Nat) r a.
(?flags::Flags) =>
(Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a -> (Input# o -> Input o) -> StaCont s o a x
suspend Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
m Γ s o xs n r a
γ Input# o -> Input o
off = forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont forall a b. (a -> b) -> a -> b
$ \Code x
x Input# o
o# -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
m (Γ s o xs n r a
γ {operands :: OpStack (x : xs)
operands = forall x (xs1 :: [Type]).
Defunc x -> OpStack xs1 -> OpStack (x : xs1)
Op (forall a. (?flags::Flags) => Code a -> Defunc a
FREEVAR Code x
x) (forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o xs n r a
γ), input :: Input o
input = Input# o -> Input o
off Input# o
o#})

{-|
Combines `suspend` and `callWithContinuation`, simultaneously performing
an optimisation on the offset if the subroutine has known input characteristics.

@since 1.5.0.0
-}
callCC :: forall s o xs n r a x. (MarshalOps o, DynOps o, ?flags :: Opt.Flags)
       => Word                                                   --
       -> StaSubroutine s o a x                                  -- ^ The subroutine @sub@ that will be called.
       -> (Γ s o (x : xs) (Succ n) r a -> Code (ST s (Maybe a))) -- ^ The return continuation to generate
       -> Γ s o xs (Succ n) r a                                  --
       -> Code (ST s (Maybe a))
callCC :: forall s o (xs :: [Type]) (n :: Nat) r a x.
(MarshalOps o, DynOps o, ?flags::Flags) =>
Word
-> StaSubroutine s o a x
-> (Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a)))
-> Γ s o xs ('Succ n) r a
-> Code (ST s (Maybe a))
callCC Word
u StaSubroutine s o a x
sub Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a))
k Γ s o xs ('Succ n) r a
γ = forall o s a x (n :: Nat).
(MarshalOps o, DynOps o) =>
StaSubroutine s o a x
-> StaCont s o a x
-> Input o
-> Vec ('Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
callWithContinuation StaSubroutine s o a x
sub (forall s o x (xs :: [Type]) (n :: Nat) r a.
(?flags::Flags) =>
(Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a -> (Input# o -> Input o) -> StaCont s o a x
suspend Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a))
k Γ s o xs ('Succ n) r a
γ (forall o.
DynOps o =>
InputCharacteristic -> Word -> Input o -> Input# o -> Input o
chooseInput (Metadata -> InputCharacteristic
successInputCharacteristic (forall s o a x. StaSubroutine s o a x -> Metadata
meta StaSubroutine s o a x
sub)) Word
u Input o
inp)) Input o
inp (forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs ('Succ n) r a
γ)
  where
    inp :: Input o
    inp :: Input o
inp = forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs ('Succ n) r a
γ

{- Join Point Operations -}
{-|
Wraps around `setupJoinPoint#` to make a join point and register it
into the `Ctx`.

@since 1.4.0.0
-}
setupJoinPoint :: forall s o xs n r a x. (JoinBuilder o, DynOps o, ?flags :: Opt.Flags)
               => ΦVar x                     -- ^ The name of the binding.
               -> Machine s o (x : xs) n r a -- ^ The definition of the binding.
               -> Machine s o xs n r a       -- ^ The scope within which the binding is valid.
               -> MachineMonad s o xs n r a
setupJoinPoint :: forall s o (xs :: [Type]) (n :: Nat) r a x.
(JoinBuilder o, DynOps o, ?flags::Flags) =>
ΦVar x
-> Machine s o (x : xs) n r a
-> Machine s o xs n r a
-> MachineMonad s o xs n r a
setupJoinPoint ΦVar x
φ (Machine MachineMonad s o (x : xs) n r a
k) Machine s o xs n r a
mx = forall s o a (m :: Type -> Type) b.
MonadReader (Ctx s o a) m =>
(Word -> m b) -> m b
freshUnique forall a b. (a -> b) -> a -> b
$ \Word
u ->
    forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (\Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
mk Ctx s o a
ctx Γ s o xs n r a
γ ->
      forall o s a x b.
JoinBuilder o =>
StaCont# s o a x -> (DynCont s o a x -> Code b) -> Code b
setupJoinPoint# @o
        (\Code x
qx Input# o
inp -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
mk (Γ s o xs n r a
γ {operands :: OpStack (x : xs)
operands = forall x (xs1 :: [Type]).
Defunc x -> OpStack xs1 -> OpStack (x : xs1)
Op (forall a. (?flags::Flags) => Code a -> Defunc a
FREEVAR Code x
qx) (forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o xs n r a
γ), input :: Input o
input = forall o. DynOps o => Word -> Input# o -> Input o
toInput Word
u Input# o
inp}))
        (\DynCont s o a x
qjoin -> forall s o (xs :: [Type]) (n :: Nat) r a.
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
mx Γ s o xs n r a
γ (forall x s o a. ΦVar x -> StaCont s o a x -> Ctx s o a -> Ctx s o a
insertΦ ΦVar x
φ (forall o s a x. DynCont s o a x -> StaCont s o a x
mkStaContDyn DynCont s o a x
qjoin) Ctx s o a
ctx)))
      (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
voidCoins MachineMonad s o (x : xs) n r a
k) forall r (m :: Type -> Type). MonadReader r m => m r
ask

{- Iteration Operations -}
{-|
Uses `bindIterHandler#` and `bindIter#` to create an iterated parser
from its loop body and return continuation. The exit of a loop is done
using failure, and this failure does not discriminate whether or not
the loop consumed input in its final iteration.

@since 1.8.0.0
-}
bindIterAlways :: forall s o a. (RecBuilder o, DynOps o)
               => Ctx s o a                  -- ^ The context to keep the binding
               -> MVar Void                  -- ^ The name of the binding.
               -> Machine s o '[] One Void a -- ^ The body of the loop.
               -> Bool                       -- ^ Does loop exit require a binding?
               -> StaHandlerBuilder s o a    -- ^ What to do after the loop exits (by failing)
               -> Input o                    -- ^ The initial offset to provide to the loop
               -> Word                       -- ^ The unique name for captured offset /and/ iteration offset
               -> Code (ST s (Maybe a))
bindIterAlways :: forall s o a.
(RecBuilder o, DynOps o) =>
Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandlerBuilder s o a
-> Input o
-> Word
-> Code (ST s (Maybe a))
bindIterAlways Ctx s o a
ctx MVar Void
μ Machine s o '[] One Void a
l Bool
needed StaHandlerBuilder s o a
h Input o
inp Word
u =
  forall o s a b.
RecBuilder o =>
Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# @o Bool
needed (forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaHandlerBuilder s o a
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o. DynOps o => Word -> Input# o -> Input o
toInput Word
u) forall a b. (a -> b) -> a -> b
$ \Input# o -> StaHandler s o a
qhandler ->
    forall o s a.
RecBuilder o =>
Input# o
-> (Code (Pos -> DynRep o -> ST s (Maybe a))
    -> Input# o -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (forall o. DynOps o => Input o -> Input# o
fromInput Input o
inp) forall a b. (a -> b) -> a -> b
$ \Code (Pos -> DynRep o -> ST s (Maybe a))
qloop Input# o
inp# ->
      let inp :: Input o
inp = forall o. DynOps o => Word -> Input# o -> Input o
toInput Word
u Input# o
inp#
      in forall s o (xs :: [Type]) (n :: Nat) r a.
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 '[] One Void a
l (forall s o (xs :: [Type]) (n :: Nat) r a.
OpStack xs
-> StaCont s o a r
-> Input o
-> Vec n (AugmentedStaHandler s o a)
-> Γ s o xs n r a
Γ OpStack '[]
Empty forall s o a. StaCont s o a Void
noreturn Input o
inp (forall a (n1 :: Nat). a -> Vec n1 a -> Vec ('Succ n1) a
VCons (forall o s a.
Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (forall a. a -> Maybe a
Just Input o
inp) (Input# o -> StaHandler s o a
qhandler Input# o
inp#)) forall a. Vec 'Zero a
VNil))
               (forall s o a. Ctx s o a -> Ctx s o a
voidCoins (forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar Void
μ (forall s o a x. StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutine forall a b. (a -> b) -> a -> b
$ \DynCont s o a Void
_ Code (Pos -> DynRep o -> ST s (Maybe a))
_ Input# o
inp -> [|| $$qloop $$(pos# inp) $$(off# inp) ||]) Ctx s o a
ctx))

{-|
Similar to `bindIterAlways`, but builds a handler that performs in
the same way as `bindSameHandler`.

@since 2.1.0.0
-}
bindIterSame :: forall s o a. (RecBuilder o, HandlerOps o, PositionOps (StaRep o), DynOps o)
             => Ctx s o a                  -- ^ The context to store the binding in.
             -> MVar Void                  -- ^ The name of the binding.
             -> Machine s o '[] One Void a -- ^ The loop body.
             -> Bool                       -- ^ Is a binding required for the matching handler?
             -> StaHandler s o a           -- ^ The handler when input is the same.
             -> Bool                       -- ^ Is a binding required for the differing handler?
             -> StaHandlerBuilder s o a    -- ^ The handler when input differs.
             -> Input o                    -- ^ The initial offset of the loop.
             -> Word                       -- ^ The unique name of the captured offsets /and/ the iteration offset.
             -> Code (ST s (Maybe a))
bindIterSame :: forall s o a.
(RecBuilder o, HandlerOps o, PositionOps (StaRep o), DynOps o) =>
Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> Input o
-> Word
-> Code (ST s (Maybe a))
bindIterSame Ctx s o a
ctx MVar Void
μ Machine s o '[] One Void a
l Bool
neededYes StaHandler s o a
yes Bool
neededNo StaHandlerBuilder s o a
no Input o
inp Word
u =
  forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# @o Bool
neededYes (forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# StaHandler s o a
yes) forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qyes ->
    forall o s a b.
RecBuilder o =>
Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# Bool
neededNo (forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaHandlerBuilder s o a
no forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o. DynOps o => Word -> Input# o -> Input o
toInput Word
u) forall a b. (a -> b) -> a -> b
$ \Input# o -> StaHandler s o a
qno ->
      let handler :: Input# o -> StaHandler# s o a
handler Input# o
inpc Input# o
inpo = [||if $$(same (asSta @o (off# inpc)) (asSta @o (off# inpo))) then $$(staHandler# qyes inpc) else $$(staHandler# (qno inpc) inpo)||]
      in forall o s a b.
RecBuilder o =>
Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# @o Bool
True Input# o -> StaHandler# s o a
handler forall a b. (a -> b) -> a -> b
$ \Input# o -> StaHandler s o a
qhandler ->
        forall o s a.
RecBuilder o =>
Input# o
-> (Code (Pos -> DynRep o -> ST s (Maybe a))
    -> Input# o -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (forall o. DynOps o => Input o -> Input# o
fromInput Input o
inp) forall a b. (a -> b) -> a -> b
$ \Code (Pos -> DynRep o -> ST s (Maybe a))
qloop Input# o
inp# ->
          let off :: Input o
off = forall o. DynOps o => Word -> Input# o -> Input o
toInput Word
u Input# o
inp#
          in forall s o (xs :: [Type]) (n :: Nat) r a.
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 '[] One Void a
l (forall s o (xs :: [Type]) (n :: Nat) r a.
OpStack xs
-> StaCont s o a r
-> Input o
-> Vec n (AugmentedStaHandler s o a)
-> Γ s o xs n r a
Γ OpStack '[]
Empty forall s o a. StaCont s o a Void
noreturn Input o
off (forall a (n1 :: Nat). a -> Vec n1 a -> Vec ('Succ n1) a
VCons (forall o s a.
Input o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
augmentHandlerFull Input o
off (Input# o -> StaHandler s o a
qhandler Input# o
inp#) (forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# StaHandler s o a
qyes Input# o
inp#) (Input# o -> StaHandler s o a
qno Input# o
inp#)) forall a. Vec 'Zero a
VNil))
                   (forall s o a. Ctx s o a -> Ctx s o a
voidCoins (forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar Void
μ (forall s o a x. StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutine forall a b. (a -> b) -> a -> b
$ \DynCont s o a Void
_ Code (Pos -> DynRep o -> ST s (Maybe a))
_ Input# o
inp -> [|| $$qloop $$(pos# inp) $$(off# inp) ||]) Ctx s o a
ctx))

{- Recursion Operations -}
{-|
Wraps around `bindRec#` to produce a recursive parser binding. This function
also provides all the free-registers which are closed over by the binding.
This eliminates recursive calls from having to pass all of the same registers
each time round.

@since 1.5.0.0
-}
buildRec :: forall rs s o a r. (RecBuilder o, DynOps o)
         => MVar r                  -- ^ The name of the binding.
         -> Regs rs                 -- ^ The registered required by the binding.
         -> Ctx s o a               -- ^ The context to re-insert the register-less binding
         -> Machine s o '[] One r a -- ^ The body of the binding.
         -> Metadata                -- ^ The metadata associated with the binding
         -> DynFunc rs s o a r
buildRec :: forall (rs :: [Type]) s o a r.
(RecBuilder o, DynOps o) =>
MVar r
-> Regs rs
-> Ctx s o a
-> Machine s o '[] One r a
-> Metadata
-> DynFunc rs s o a r
buildRec MVar r
μ Regs rs
rs Ctx s o a
ctx Machine s o '[] One r a
k Metadata
meta =
  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
rs Ctx s o a
ctx forall a b. (a -> b) -> a -> b
$ \Ctx s o a
ctx ->
    forall o s a x.
RecBuilder o =>
(DynSubroutine s o a x -> StaSubroutine# s o a x)
-> DynSubroutine s o a x
bindRec# @o forall a b. (a -> b) -> a -> b
$ \DynSubroutine s o a r
qself DynCont s o a r
qret DynHandler s o a
qh Input# o
inp ->
      forall s o (xs :: [Type]) (n :: Nat) r a.
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 '[] One r a
k (forall s o (xs :: [Type]) (n :: Nat) r a.
OpStack xs
-> StaCont s o a r
-> Input o
-> Vec n (AugmentedStaHandler s o a)
-> Γ s o xs n r a
Γ OpStack '[]
Empty (forall o s a x. DynCont s o a x -> StaCont s o a x
mkStaContDyn DynCont s o a r
qret) (forall o. DynOps o => Word -> Input# o -> Input o
toInput Word
0 Input# o
inp) (forall a (n1 :: Nat). a -> Vec n1 a -> Vec ('Succ n1) a
VCons (forall s o a.
Maybe (Input o) -> DynHandler s o a -> AugmentedStaHandler s o a
augmentHandlerDyn forall a. Maybe a
Nothing DynHandler s o a
qh) forall a. Vec 'Zero a
VNil))
            (forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar r
μ (forall s o a x.
Metadata -> StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutineMeta Metadata
meta forall a b. (a -> b) -> a -> b
$ \DynCont s o a r
k DynHandler s o a
h Input# o
inp -> [|| $$qself $$k $$h $$(pos# inp) $$(off# inp) ||]) (forall s o a. Ctx s o a -> Ctx s o a
nextUnique Ctx s o a
ctx))

{- Binding Operations -}
bindHandlerInline# :: forall o s a b. HandlerOps o
                   => Bool
                   -> StaHandler# s o a
                   -> (StaHandler s o a -> Code b)
                   -> Code b
bindHandlerInline# :: forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
True  StaHandler# s o a
h StaHandler s o a -> Code b
k = forall o s a b.
HandlerOps o =>
StaHandler# s o a -> (DynHandler s o a -> Code b) -> Code b
bindHandler# @o StaHandler# s o a
h (StaHandler s o a -> Code b
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s o a. DynHandler s o a -> StaHandler s o a
fromDynHandler)
bindHandlerInline# Bool
False StaHandler# s o a
h StaHandler s o a -> Code b
k = StaHandler s o a -> Code b
k (forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# StaHandler# s o a
h)

bindYesInline# :: Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# :: forall a b. Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# Bool
True  Code a
v Code a -> Code b
k = [|| let yesSame = $$v in $$(k [||yesSame||]) ||]
bindYesInline# Bool
False Code a
v Code a -> Code b
k = Code a -> Code b
k Code a
v

bindIterHandlerInline# :: forall o s a b. RecBuilder o
                       => Bool
                       -> (Input# o -> StaHandler# s o a)
                       -> ((Input# o -> StaHandler s o a) -> Code b)
                       -> Code b
bindIterHandlerInline# :: forall o s a b.
RecBuilder o =>
Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# Bool
True  Input# o -> StaHandler# s o a
h (Input# o -> StaHandler s o a) -> Code b
k = forall o s a b.
RecBuilder o =>
(Input# o -> StaHandler# s o a)
-> (Code (Pos -> DynRep o -> Handler# s o a) -> Code b) -> Code b
bindIterHandler# @o Input# o -> StaHandler# s o a
h forall a b. (a -> b) -> a -> b
$ \Code (Pos -> DynRep o -> Handler# s o a)
qh -> (Input# o -> StaHandler s o a) -> Code b
k (\Input# o
inp -> forall s o a. DynHandler s o a -> StaHandler s o a
fromDynHandler [||$$qh $$(pos# inp) $$(off# inp)||])
bindIterHandlerInline# Bool
False Input# o -> StaHandler# s o a
h (Input# o -> StaHandler s o a) -> Code b
k = (Input# o -> StaHandler s o a) -> Code b
k (forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input# o -> StaHandler# s o a
h)

{- Marshalling Operations -}
{-|
Wraps around `dynHandler#`, but ensures that if the `StaHandler`
originated from a `DynHandler` itself, that no work is performed.

Takes in an `InputCharacteristic`, which is used to refine the
handler given knowledge about how it might be used.

@since 1.5.0.0
-}
dynHandler :: forall s o a. MarshalOps o => AugmentedStaHandler s o a -> InputCharacteristic -> DynHandler s o a
dynHandler :: forall s o a.
MarshalOps o =>
AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
dynHandler AugmentedStaHandler s o a
h = forall s o a.
AugmentedStaHandler s o a
-> (StaHandler# s o a -> DynHandler s o a)
-> InputCharacteristic
-> DynHandler s o a
staHandlerCharacteristicDyn AugmentedStaHandler s o a
h (forall a. Code a -> Code a
eta forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o s a. MarshalOps o => StaHandler# s o a -> DynHandler s o a
dynHandler# @o)

{-|
Wraps around `dynCont#`, but ensures that if the `StaCont`
originated from a `DynCont` itself, that no work is performed.

@since 1.4.0.0
-}
dynCont :: forall s o a x. MarshalOps o => StaCont s o a x -> DynCont s o a x
dynCont :: forall s o a x. MarshalOps o => StaCont s o a x -> DynCont s o a x
dynCont (StaCont StaCont# s o a x
sk Maybe (DynCont s o a x)
Nothing)  = forall a. Code a -> Code a
eta (forall o s a x. MarshalOps o => StaCont# s o a x -> DynCont s o a x
dynCont# @o StaCont# s o a x
sk)
dynCont (StaCont StaCont# s o a x
_ (Just DynCont s o a x
dk)) = DynCont s o a x
dk

{- Log Operations =-}
{-|
The specialised handler for the @debug@ combinator. It will fail again after
having printed the debug information.

@since 1.2.0.0
-}
logHandler :: (?ops :: InputOps (StaRep o), LogHandler o, ?flags :: Opt.Flags) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Word -> StaHandlerBuilder s o a
logHandler :: forall o s a (xs :: [Type]) (n :: Nat) ks.
(?ops::InputOps (StaRep o), LogHandler o, ?flags::Flags) =>
[Char]
-> Ctx s o a
-> Γ s o xs ('Succ n) ks a
-> Word
-> StaHandlerBuilder s o a
logHandler [Char]
name Ctx s o a
ctx Γ s o xs ('Succ n) ks a
γ Word
u Input o
_ = let VCons AugmentedStaHandler s o a
h Vec n1 (AugmentedStaHandler s o a)
_ = forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs ('Succ n) ks a
γ in forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# forall a b. (a -> b) -> a -> b
$ \Input# o
inp# -> let inp :: Input o
inp = forall o. DynOps o => Word -> Input# o -> Input o
toInput Word
u Input# o
inp# in [||
    trace $$(preludeString name '<' (γ {input = inp}) ctx (color Red " Fail")) $$(staHandlerEval h inp)
  ||]

{-|
Used for the debug instructions and handler, produces the debugging information
string.

@since 1.2.0.0
-}
preludeString :: forall s o xs n r a. (?ops :: InputOps (StaRep o), LogHandler o)
              => String         -- ^ The name as per the debug combinator
              -> Char           -- ^ Either @<@ or @>@ depending on whether we are entering or leaving.
              -> Γ s o xs n r a
              -> Ctx s o a
              -> String         -- ^ String that represents the current status
              -> Code String
preludeString :: forall s o (xs :: [Type]) (n :: Nat) r a.
(?ops::InputOps (StaRep o), LogHandler o) =>
[Char]
-> Char -> Γ s o xs n r a -> Ctx s o a -> [Char] -> Code [Char]
preludeString [Char]
name Char
dir Γ s o xs n r a
γ Ctx s o a
ctx [Char]
ends =
  forall rep a. LogOps rep => rep -> Int -> (rep -> Code a) -> Code a
shiftLeft StaRep o
offset Int
5 forall a b. (a -> b) -> a -> b
$ \StaRep o
start ->
    forall rep a. LogOps rep => rep -> Int -> (rep -> Code a) -> Code a
shiftRight StaRep o
offset Int
5 forall a b. (a -> b) -> a -> b
$ \StaRep o
end ->
      let indent :: [Char]
indent          = forall a. Int -> a -> [a]
replicate (forall s o a. Ctx s o a -> Int
debugLevel Ctx s o a
ctx forall a. Num a => a -> a -> a
* Int
2) Char
' '
          inputTrace :: Code [Char]
inputTrace      = [|| let replace '\n' = color Green "↙"
                                    replace ' '  = color White "·"
                                    replace c    = return c
                                    go i# = $$(uncons (asSta @o [||i#||]) (\qc qi' -> [||
                                        if $$(same (asSta @o [||i#||]) end) then []
                                        else replace $$qc ++ go $$(asDyn @o qi') ||])
                                      [||color Red "•"||])
                                in go $$(asDyn @o start) ||]
          prelude :: Code [Char]
prelude         = [|| concat [indent, dir : name, dir : " (", show $$(offToInt offset), "): "] ||]
          caretSpace :: Code [Char]
caretSpace      = [|| replicate (length $$prelude + $$(offToInt offset) - $$(offToInt start)) ' ' ||]
      in [|| concat [$$prelude, $$inputTrace, ends, '\n' : $$caretSpace, color Blue "^"] ||]
  where
    offset :: StaRep o
offset = forall o. Offset o -> StaRep o
Offset.offset (forall o. Input o -> Offset o
off (forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ))


{- Convenience Types -}
{-|
A convience bundle of all of the type class constraints.

@since 1.0.0.0
-}
type Ops o =
  ( HandlerOps o
  , JoinBuilder o
  , RecBuilder o
  , PositionOps (StaRep o)
  , MarshalOps o
  , LogOps (StaRep o)
  , DynOps o
  )

{-|
The constraints needed to build a `logHandler`.

@since 1.0.0.0
-}
type LogHandler o = (PositionOps (StaRep o), LogOps (StaRep o), DynOps o)

{-|
A `StaHandler` that has not yet captured its offset.

@since 1.2.0.0
-}
type StaHandlerBuilder s o a = Input o -> StaHandler s o a

{-|
A "yes-handler" that has not yet captured its offset

@since 2.1.0.0
-}
type StaYesHandler s o a = Input o -> Code (ST s (Maybe a))