{-# 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.STRef                                                 (writeSTRef, readSTRef, newSTRef)
import Data.Void                                                  (Void)
import Debug.Trace                                                (trace)
import GHC.Exts                                                   (Int(..), (-#))
import Language.Haskell.TH.Syntax                                 (liftTyped)
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, next, more)
import Parsley.Internal.Backend.Machine.InputRep                  (Rep)
import Parsley.Internal.Backend.Machine.Instructions              (Access(..))
import Parsley.Internal.Backend.Machine.LetBindings               (Regs(..), Metadata(failureInputCharacteristic, successInputCharacteristic))
import Parsley.Internal.Backend.Machine.THUtils                   (eta)
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, consume, chooseInput)
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 System.Console.Pretty                                      (color, Color(Green, White, Red, Blue))

import Parsley.Internal.Backend.Machine.Types.Input.Offset as Offset (Offset(..))

{- 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 :: Defunc x -> (Defunc x -> Code r) -> Code r
dup :: Defunc x -> (Defunc x -> Code r) -> Code r
dup (FREEVAR Code x
x) Defunc x -> Code r
k = Defunc x -> Code r
k (Code x -> Defunc x
forall a. Code a -> Defunc a
FREEVAR Code x
x)
dup (INPUT Input x
o) Defunc x -> Code r
k = Defunc x -> Code r
k (Input x -> Defunc x
forall o. Input o -> Defunc o
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 :: a -> ST s a
returnST = forall a. Monad (ST s) => a -> ST s a
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 :: (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 :: (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 = Code Char -> Defunc Char
forall a. Code a -> Defunc a
FREEVAR Code Char
c in Defunc Bool -> Code b -> Code b -> Code b
forall a. 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 (Rep o))
      => Input o -> (Code Char -> Input o -> Code b) -> Code b
fetch :: Input o -> (Code Char -> Input o -> Code b) -> Code b
fetch Input o
input Code Char -> Input o -> Code b
k = Code (Rep o) -> (Code Char -> Code (Rep o) -> Code b) -> Code b
forall rep a.
(?ops::InputOps rep) =>
Code rep -> (Code Char -> Code rep -> Code a) -> Code a
next (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset (Input o -> Offset o
forall o. Input o -> Offset o
off Input o
input)) ((Code Char -> Code (Rep o) -> Code b) -> Code b)
-> (Code Char -> Code (Rep o) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code Char
c Code (Rep o)
offset' -> Code Char -> Input o -> Code b
k Code Char
c (Code (Rep o) -> Input o -> Input o
forall o. Code (Rep o) -> Input o -> Input o
consume Code (Rep o)
offset' Input o
input)

{-|
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 1.4.0.0
-}
emitLengthCheck :: (?ops :: InputOps (Rep o), PositionOps (Rep o))
                => Int      -- ^ The number of required characters \(n\).
                -> 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.
                -> Code a
emitLengthCheck :: Int -> Code a -> Code a -> Offset o -> Code a
emitLengthCheck Int
0 Code a
good Code a
_ Offset o
_   = Code a
good
emitLengthCheck Int
1 Code a
good Code a
bad Offset o
input = [|| if $$(more (offset input)) then $$good else $$bad ||]
emitLengthCheck (I# Int#
n) Code a
good Code a
bad Offset o
input = [||
  if $$(more (shiftRight (offset input) (liftTyped (n -# 1#)))) then $$good
  else $$bad ||]

{- 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Σ :: Σ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
-> 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 = Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s r)
k (ΣVar x
-> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a
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))
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 = Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
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Σ :: Σ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
-> 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 = Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s r)
k (ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a
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 = ΣVar x -> Ctx s o a -> Code (STRef s x)
forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar x
σ Ctx s o a
ctx in Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
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Σ :: Σ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
-> (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 (ΣVar x -> Ctx s o a -> Defunc x
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 = ΣVar x -> Ctx s o a -> Code (STRef s x)
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 :: AugmentedStaHandler s o a
fatal = Maybe (Input o) -> StaHandler# s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Input o) -> StaHandler# s o a -> AugmentedStaHandler s o a
augmentHandlerSta Maybe (Input o)
forall a. Maybe a
Nothing (Q (TExp (ST s (Maybe a))) -> StaHandler# s o a
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 :: Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))
raise :: Γ 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 n (AugmentedStaHandler s o a)
_ = Γ s o xs ('Succ n) r a -> Vec ('Succ n) (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 AugmentedStaHandler s o a -> Input o -> Code (ST s (Maybe a))
forall s o a.
AugmentedStaHandler s o a -> Input o -> Code (ST s (Maybe a))
staHandlerEval AugmentedStaHandler s o a
h (Γ s o xs ('Succ n) r a -> Input o
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 :: Γ 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 :: Γ 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 = StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> StaHandler# s o a -> StaHandler s o a
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 = Defunc o -> OpStack xs -> OpStack (o : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op (Input o -> Defunc o
forall o. Input o -> Defunc o
INPUT Input o
c) (Γ s o xs n r a -> OpStack xs
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 = Word -> Input# o -> Input o
forall 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 :: Γ 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 :: Γ 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)))
-> 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 = StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> StaYesHandler s o a
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 StaYesHandler s o a -> (Input# o -> Input o) -> StaHandler# s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Input# o -> Input o
forall 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 :: Γ 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 = Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
needed (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
h (Γ s o xs n r a -> Input o
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 -> Code b) -> Code b)
-> (StaHandler s o a -> Code b) -> Code b
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 = AugmentedStaHandler s o a
-> Vec n (AugmentedStaHandler s o a)
-> Vec ('Succ n) (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (Input o -> Maybe (Input o)
forall a. a -> Maybe a
Just (Γ s o xs n r a -> Input o
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) (Γ s o xs n r a -> Vec n (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 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 (Rep 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 :: Γ 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 =
  Bool
-> Code (ST s (Maybe a))
-> (Code (ST s (Maybe a)) -> Code b)
-> Code b
forall a b. Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# Bool
yesNeeded (StaYesHandler s o a
yes (Γ s o xs n r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ)) ((Code (ST s (Maybe a)) -> Code b) -> Code b)
-> (Code (ST s (Maybe a)) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code (ST s (Maybe a))
qyes ->
    Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
noNeeded (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
no (Γ s o xs n r a -> Input o
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 -> Code b) -> Code b)
-> (StaHandler s o a -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qno ->
      let handler :: StaHandler# s o a
handler Input# o
inp = [||if $$(same (offset (off (input γ))) (off# inp)) then $$qyes else $$(staHandler# qno inp)||]
      in Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# @o Bool
True StaHandler# s o a
handler ((StaHandler s o a -> Code b) -> Code b)
-> (StaHandler s o a -> Code b) -> Code b
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 = AugmentedStaHandler s o a
-> Vec n (AugmentedStaHandler s o a)
-> Vec ('Succ n) (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Input o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
forall o s a.
Input o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
augmentHandlerFull (Γ s o xs n r a -> Input o
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) (Γ s o xs n r a -> Vec n (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 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 :: StaCont s o a a
halt = StaCont# s o a a -> StaCont s o a a
forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont (StaCont# s o a a -> StaCont s o a a)
-> StaCont# s o a a -> StaCont s o a a
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 :: StaCont s o a Void
noreturn = StaCont# s o a Void -> StaCont s o a Void
forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont (StaCont# s o a Void -> StaCont s o a Void)
-> StaCont# s o a Void -> StaCont s o a Void
forall a b. (a -> b) -> a -> b
$ \Code Void
_ Input# o
_ -> [||error "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 :: StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
resume :: 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
x OpStack xs
_ = Γ s o (x : xs) n r a -> OpStack (x : xs)
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 StaCont s o a x -> StaCont# s o a x
forall s o a x. StaCont s o a x -> StaCont# s o a x
staCont# StaCont s o a x
k (Defunc x -> Code x
forall a. Defunc a -> Code a
genDefunc Defunc x
x) (Input o -> Input# o
forall o. Input o -> Input# o
fromInput (Γ s o (x : xs) n r a -> Input o
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
                     => 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 :: 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 n (AugmentedStaHandler s o a)
_) = StaSubroutine s o a x -> StaSubroutine# s o a x
forall s o a x. StaSubroutine s o a x -> StaSubroutine# s o a x
staSubroutine# StaSubroutine s o a x
sub (StaCont s o a x -> DynCont s o a x
forall s o a x. MarshalOps o => StaCont s o a x -> DynCont s o a x
dynCont StaCont s o a x
ret) (AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
forall s o a.
MarshalOps o =>
AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
dynHandler AugmentedStaHandler s o a
h (Metadata -> InputCharacteristic
failureInputCharacteristic (StaSubroutine s o a x -> Metadata
forall s o a x. StaSubroutine s o a x -> Metadata
meta StaSubroutine s o a x
sub))) (Input o -> Input# o
forall 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 :: (Γ 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 :: (Γ 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 = StaCont# s o a x -> StaCont s o a x
forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont (StaCont# s o a x -> StaCont s o a x)
-> StaCont# s o a x -> StaCont s o a x
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 = Defunc x -> OpStack xs -> OpStack (x : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op (Code x -> Defunc x
forall a. Code a -> Defunc a
FREEVAR Code x
x) (Γ s o xs n r a -> OpStack xs
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
       => 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 :: 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
γ = StaSubroutine s o a x
-> StaCont s o a x
-> Input o
-> Vec ('Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
forall o s a x (n :: Nat).
MarshalOps 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 ((Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a)))
-> Γ s o xs ('Succ n) r a
-> (Input# o -> Input o)
-> StaCont s o a x
forall s o x (xs :: [Type]) (n :: Nat) r a.
(Γ 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
γ (InputCharacteristic -> Word -> Input o -> Input# o -> Input o
forall o.
InputCharacteristic -> Word -> Input o -> Input# o -> Input o
chooseInput (Metadata -> InputCharacteristic
successInputCharacteristic (StaSubroutine s o a x -> Metadata
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 (Γ s o xs ('Succ n) r a -> Vec ('Succ n) (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
γ)
  where
    inp :: Input o
    inp :: Input o
inp = Γ s o xs ('Succ n) r a -> Input o
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
               => Φ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 :: Φ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 = (Word -> MachineMonad s o xs n r a) -> MachineMonad s o xs n r a
forall s o a (m :: Type -> Type) b.
MonadReader (Ctx s o a) m =>
(Word -> m b) -> m b
freshUnique ((Word -> MachineMonad s o xs n r a) -> MachineMonad s o xs n r a)
-> (Word -> MachineMonad s o xs n r a) -> MachineMonad s o xs n r a
forall a b. (a -> b) -> a -> b
$ \Word
u ->
    ((Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
 -> Ctx s o a -> Γ s o xs n r a -> Code (ST s (Maybe a)))
-> MachineMonad s o (x : xs) n r a
-> ReaderT (Ctx s o a) Identity (Ctx s o a)
-> MachineMonad s o xs n r a
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
γ ->
      StaCont# s o a x
-> (DynCont s o a x -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe 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 = Defunc x -> OpStack xs -> OpStack (x : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op (Code x -> Defunc x
forall a. Code a -> Defunc a
FREEVAR Code x
qx) (Γ s o xs n r a -> OpStack xs
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 = Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u Input# o
inp}))
        (\DynCont s o a x
qjoin -> Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
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
γ (ΦVar x -> StaCont s o a x -> Ctx s o a -> Ctx s o a
forall x s o a. ΦVar x -> StaCont s o a x -> Ctx s o a -> Ctx s o a
insertΦ ΦVar x
φ (DynCont s o a x -> StaCont s o a x
forall s o a x. DynCont s o a x -> StaCont s o a x
mkStaContDyn DynCont s o a x
qjoin) Ctx s o a
ctx)))
      ((Ctx s o a -> Ctx s o a)
-> MachineMonad s o (x : xs) n r a
-> MachineMonad s o (x : xs) n r a
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
voidCoins MachineMonad s o (x : xs) n r a
k) ReaderT (Ctx s o a) Identity (Ctx s o a)
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
               => 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 :: 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 =
  Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
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 (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandler s o a -> StaHandler# s o a)
-> (Input# o -> StaHandler s o a) -> Input# o -> StaHandler# s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaHandlerBuilder s o a
h StaHandlerBuilder s o a
-> (Input# o -> Input o) -> Input# o -> StaHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u) (((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
 -> Code (ST s (Maybe a)))
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Input# o -> StaHandler s o a
qhandler ->
    Input# o
-> (Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a))
forall o s a.
RecBuilder o =>
Input# o
-> (Code (Pos -> Rep o -> ST s (Maybe a))
    -> Input# o -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (Input o -> Input# o
forall o. Input o -> Input# o
fromInput Input o
inp) ((Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
 -> Code (ST s (Maybe a)))
-> (Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Pos -> Rep o -> ST s (Maybe a))
qloop Input# o
inp# ->
      let inp :: Input o
inp = Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u Input# o
inp#
      in Machine s o '[] One Void a
-> Γ s o '[] One Void a -> Ctx s o a -> Code (ST s (Maybe a))
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 (OpStack '[]
-> StaCont s o a Void
-> Input o
-> Vec One (AugmentedStaHandler s o a)
-> Γ s o '[] One Void a
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 StaCont s o a Void
forall s o a. StaCont s o a Void
noreturn Input o
inp (AugmentedStaHandler s o a
-> Vec 'Zero (AugmentedStaHandler s o a)
-> Vec One (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (Input o -> Maybe (Input o)
forall a. a -> Maybe a
Just Input o
inp) (Input# o -> StaHandler s o a
qhandler Input# o
inp#)) Vec 'Zero (AugmentedStaHandler s o a)
forall a. Vec 'Zero a
VNil))
               (Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
voidCoins (MVar Void -> StaSubroutine s o a Void -> Ctx s o a -> Ctx s o a
forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar Void
μ (StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall s o a x. StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutine (StaSubroutine# s o a Void -> StaSubroutine s o a Void)
-> StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall a b. (a -> b) -> a -> b
$ \DynCont s o a Void
_ Code (Pos -> Rep 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 (Rep 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 :: 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 =
  Bool
-> StaHandler# s o a
-> (StaHandler s o a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# @o Bool
neededYes (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# StaHandler s o a
yes) ((StaHandler s o a -> Code (ST s (Maybe a)))
 -> Code (ST s (Maybe a)))
-> (StaHandler s o a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qyes ->
    Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
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 (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandler s o a -> StaHandler# s o a)
-> (Input# o -> StaHandler s o a) -> Input# o -> StaHandler# s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaHandlerBuilder s o a
no StaHandlerBuilder s o a
-> (Input# o -> Input o) -> Input# o -> StaHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u) (((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
 -> Code (ST s (Maybe a)))
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
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 (off# inpc) (off# inpo)) then $$(staHandler# qyes inpc) else $$(staHandler# (qno inpc) inpo)||]
      in Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
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 (((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
 -> Code (ST s (Maybe a)))
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Input# o -> StaHandler s o a
qhandler ->
        Input# o
-> (Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a))
forall o s a.
RecBuilder o =>
Input# o
-> (Code (Pos -> Rep o -> ST s (Maybe a))
    -> Input# o -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (Input o -> Input# o
forall o. Input o -> Input# o
fromInput Input o
inp) ((Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
 -> Code (ST s (Maybe a)))
-> (Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Pos -> Rep o -> ST s (Maybe a))
qloop Input# o
inp# ->
          let off :: Input o
off = Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u Input# o
inp#
          in Machine s o '[] One Void a
-> Γ s o '[] One Void a -> Ctx s o a -> Code (ST s (Maybe a))
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 (OpStack '[]
-> StaCont s o a Void
-> Input o
-> Vec One (AugmentedStaHandler s o a)
-> Γ s o '[] One Void a
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 StaCont s o a Void
forall s o a. StaCont s o a Void
noreturn Input o
off (AugmentedStaHandler s o a
-> Vec 'Zero (AugmentedStaHandler s o a)
-> Vec One (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Input o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
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#) (StaHandler s o a -> StaHandler# s o a
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#)) Vec 'Zero (AugmentedStaHandler s o a)
forall a. Vec 'Zero a
VNil))
                   (Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
voidCoins (MVar Void -> StaSubroutine s o a Void -> Ctx s o a -> Ctx s o a
forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar Void
μ (StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall s o a x. StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutine (StaSubroutine# s o a Void -> StaSubroutine s o a Void)
-> StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall a b. (a -> b) -> a -> b
$ \DynCont s o a Void
_ Code (Pos -> Rep 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
         => 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 :: 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 =
  Regs rs
-> Ctx s o a
-> (Ctx s o a -> DynSubroutine s o a r)
-> DynFunc rs s o a r
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 ((Ctx s o a -> DynSubroutine s o a r) -> DynFunc rs s o a r)
-> (Ctx s o a -> DynSubroutine s o a r) -> DynFunc rs s o a r
forall a b. (a -> b) -> a -> b
$ \Ctx s o a
ctx ->
    forall s a x.
RecBuilder o =>
(DynSubroutine s o a x -> StaSubroutine# s o a x)
-> DynSubroutine s o a x
forall o s a x.
RecBuilder o =>
(DynSubroutine s o a x -> StaSubroutine# s o a x)
-> DynSubroutine s o a x
bindRec# @o ((DynSubroutine s o a r -> StaSubroutine# s o a r)
 -> DynSubroutine s o a r)
-> (DynSubroutine s o a r -> StaSubroutine# s o a r)
-> DynSubroutine s o a r
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 ->
      Machine s o '[] One r a
-> Γ s o '[] One r a -> Ctx s o a -> Code (ST s (Maybe a))
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 (OpStack '[]
-> StaCont s o a r
-> Input o
-> Vec One (AugmentedStaHandler s o a)
-> Γ s o '[] One r a
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 (DynCont s o a r -> StaCont s o a r
forall s o a x. DynCont s o a x -> StaCont s o a x
mkStaContDyn DynCont s o a r
qret) (Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
0 Input# o
inp) (AugmentedStaHandler s o a
-> Vec 'Zero (AugmentedStaHandler s o a)
-> Vec One (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Maybe (Input o) -> DynHandler s o a -> AugmentedStaHandler s o a
forall s o a.
Maybe (Input o) -> DynHandler s o a -> AugmentedStaHandler s o a
augmentHandlerDyn Maybe (Input o)
forall a. Maybe a
Nothing DynHandler s o a
qh) Vec 'Zero (AugmentedStaHandler s o a)
forall a. Vec 'Zero a
VNil))
            (MVar r -> StaSubroutine s o a r -> Ctx s o a -> Ctx s o a
forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar r
μ (Metadata -> StaSubroutine# s o a r -> StaSubroutine s o a r
forall s o a x.
Metadata -> StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutineMeta Metadata
meta (StaSubroutine# s o a r -> StaSubroutine s o a r)
-> StaSubroutine# s o a r -> StaSubroutine s o a r
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) ||]) (Ctx s o a -> Ctx s o a
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# :: 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 = StaHandler# s o a -> (DynHandler s o a -> Code b) -> Code b
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 (StaHandler s o a -> Code b)
-> (DynHandler s o a -> StaHandler s o a)
-> DynHandler s o a
-> Code b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynHandler s o a -> StaHandler s o a
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 (StaHandler# s o a -> StaHandler s o a
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# :: 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# :: 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 = (Input# o -> StaHandler# s o a)
-> (Code (Pos -> Rep o -> Handler# s o a) -> Code b) -> Code b
forall o s a b.
RecBuilder o =>
(Input# o -> StaHandler# s o a)
-> (Code (Pos -> Rep o -> Handler# s o a) -> Code b) -> Code b
bindIterHandler# @o Input# o -> StaHandler# s o a
h ((Code (Pos -> Rep o -> Handler# s o a) -> Code b) -> Code b)
-> (Code (Pos -> Rep o -> Handler# s o a) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code (Pos -> Rep o -> Handler# s o a)
qh -> (Input# o -> StaHandler s o a) -> Code b
k (\Input# o
inp -> DynHandler s o a -> StaHandler s o a
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 (StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> (Input# o -> StaHandler# s o a) -> Input# o -> StaHandler s o a
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 :: AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
dynHandler AugmentedStaHandler s o a
h = AugmentedStaHandler s o a
-> (StaHandler# s o a -> DynHandler s o a)
-> InputCharacteristic
-> DynHandler s o a
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 (DynHandler s o a -> DynHandler s o a
forall a b. Code (a -> b) -> Code (a -> b)
eta (DynHandler s o a -> DynHandler s o a)
-> (StaHandler# s o a -> DynHandler s o a)
-> StaHandler# s o a
-> DynHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. MarshalOps o => StaHandler# s o a -> DynHandler s o a
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 :: 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)  = DynCont s o a x -> DynCont s o a x
forall a b. Code (a -> b) -> Code (a -> b)
eta (StaCont# s o a x -> DynCont s o a x
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 (Rep o), LogHandler o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Word -> StaHandlerBuilder s o a
logHandler :: String
-> Ctx s o a
-> Γ s o xs ('Succ n) ks a
-> Word
-> StaHandlerBuilder s o a
logHandler String
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 n (AugmentedStaHandler s o a)
_ = Γ s o xs ('Succ n) ks a
-> Vec ('Succ n) (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 StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> StaHandler# s o a -> StaHandler s o a
forall a b. (a -> b) -> a -> b
$ \Input# o
inp# -> let inp :: Input o
inp = Word -> Input# o -> Input o
forall 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 (Rep 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 :: String
-> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String
preludeString String
name Char
dir Γ s o xs n r a
γ Ctx s o a
ctx String
ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]
  where
    offset :: Code (Rep o)
offset          = Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
Offset.offset (Input o -> Offset o
forall o. Input o -> Offset o
off (Γ s o xs n r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ))
    indent :: String
indent          = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (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
2) Char
' '
    start :: Code (Rep o)
start           = Code (Rep o) -> Code Int# -> Code (Rep o)
forall rep. LogOps rep => Code rep -> Code Int# -> Code rep
shiftLeft Code (Rep o)
offset [||5#||]
    end :: Code (Rep o)
end             = Code (Rep o) -> Code Int# -> Code (Rep o)
forall rep. PositionOps rep => Code rep -> Code Int# -> Code rep
shiftRight Code (Rep o)
offset [||5#||]
    inputTrace :: Code String
inputTrace      = [|| let replace '\n' = color Green "↙"
                              replace ' '  = color White "·"
                              replace c    = return c
                              go i#
                                | $$(same [||i#||] end) || not $$(more [||i#||]) = []
                                | otherwise = $$(next [||i#||] (\qc qi' -> [||replace $$qc ++ go $$qi'||]))
                          in go $$start ||]
    eof :: Code String
eof             = [|| if $$(more end) then $$inputTrace else $$inputTrace ++ color Red "•" ||]
    prelude :: Code String
prelude         = [|| concat [indent, dir : name, dir : " (", show $$(offToInt offset), "): "] ||]
    caretSpace :: Code String
caretSpace      = [|| replicate (length $$prelude + $$(offToInt offset) - $$(offToInt start)) ' ' ||]

{- 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 (Rep o)
  , MarshalOps o
  , LogOps (Rep o)
  )

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

@since 1.0.0.0
-}
type LogHandler o = (PositionOps (Rep o), LogOps (Rep 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))