{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE AllowAmbiguousTypes,
             ConstrainedClassMethods,
             ConstraintKinds,
             ImplicitParams,
             MagicHash,
             NamedFieldPuns,
             PatternSynonyms,
             RecordWildCards,
             TypeApplications #-}
{-|
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,
    -- *** 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,
    -- * 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(OFFSET), 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), InputCharacteristic(..))
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.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.Offset as Offset (Offset(..), moveOne, mkOffset, moveN)

{- 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 (OFFSET Offset x
o) Defunc x -> Code r
k = Defunc x -> Code r
k (Offset x -> Defunc x
forall o. Offset o -> Defunc o
OFFSET Offset 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 1.5.0.0
-}
sat :: (Defunc Char -> Defunc Bool)                         -- ^ Predicate to test the character with.
    -> ((Code Char -> Offset o -> aux -> Code b) -> Code b) -- ^ The source of the character
    -> (Defunc Char -> Offset o -> aux -> Code b)           -- ^ Code to execute on success.
    -> Code b                                               -- ^ Code to execute on failure.
    -> Code b
sat :: (Defunc Char -> Defunc Bool)
-> ((Code Char -> Offset o -> aux -> Code b) -> Code b)
-> (Defunc Char -> Offset o -> aux -> Code b)
-> Code b
-> Code b
sat Defunc Char -> Defunc Bool
p (Code Char -> Offset o -> aux -> Code b) -> Code b
src Defunc Char -> Offset o -> aux -> Code b
good Code b
bad = (Code Char -> Offset o -> aux -> Code b) -> Code b
src ((Code Char -> Offset o -> aux -> Code b) -> Code b)
-> (Code Char -> Offset o -> aux -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code Char
c Offset o
input' aux
aux -> 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 -> Offset o -> aux -> Code b
good Defunc Char
v Offset o
input' aux
aux) Code b
bad

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

@since 1.5.0.0
-}
fetch :: (?ops :: InputOps (Rep o))
      => Offset o -> (Code Char -> Offset o -> Code b) -> Code b
fetch :: Offset o -> (Code Char -> Offset o -> Code b) -> Code b
fetch Offset o
input Code Char -> Offset 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 Offset 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 -> Offset o -> Code b
k Code Char
c (Offset o -> Code (Rep o) -> Offset o
forall o. Offset o -> Code (Rep o) -> Offset o
moveOne Offset o
input Code (Rep 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 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 (Offset o) -> StaHandler# s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Offset o) -> StaHandler# s o a -> AugmentedStaHandler s o a
augmentHandlerSta Maybe (Offset 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 -> Offset o -> Code (ST s (Maybe a))
forall s o a.
AugmentedStaHandler s o a -> Offset o -> Code (ST s (Maybe a))
staHandlerEval AugmentedStaHandler s o a
h (Γ s o xs ('Succ n) r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset 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 Offset 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
$ \Code (Rep o)
o# -> Γ 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 (Offset o -> Defunc o
forall o. Offset o -> Defunc o
OFFSET Offset 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 :: Offset o
input = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
o# Word
u})

{-|
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 1.4.0.0
-}
buildYesHandler :: Γ s o xs n r a
                -> (Γ s o xs n r a -> Code (ST s (Maybe a)))
                -> Word
                -> StaHandler s o a
buildYesHandler :: Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandler s o a
buildYesHandler Γ 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# (StaHandler# s o a -> StaHandler s o a)
-> StaHandler# s o a -> StaHandler s o a
forall a b. (a -> b) -> a -> b
$ \Code (Rep o)
o# -> Γ s o xs n r a -> Code (ST s (Maybe a))
h (Γ s o xs n r a
γ {input :: Offset o
input = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
o# 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 -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset 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 (Offset o) -> StaHandler s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Offset o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (Offset o -> Maybe (Offset o)
forall a. a -> Maybe a
Just (Γ s o xs n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset 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 1.4.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?
                -> StaHandler 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
-> StaHandler 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 StaHandler 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 (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 (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset (Γ s o xs n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset 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 -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset 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 Code (Rep o)
o = [||if $$(same (offset (input γ)) o) then $$qyes else $$(staHandler# qno o)||]
      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 (Offset o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
forall o s a.
Offset 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 -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset 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 Code (Rep 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
_ Code (Rep 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) (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset (Γ s o (x : xs) n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset 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.2.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.
                     -> Code (Rep 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
-> Code (Rep 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 Code (Rep 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) Code (Rep o)
input (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)))

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

@since 1.5.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.
        -> (Code (Rep o) -> Offset 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 -> (Code (Rep o) -> Offset 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
γ Code (Rep o) -> Offset 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 Code (Rep 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 :: Offset o
input = Code (Rep o) -> Offset o
off Code (Rep 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
-> Code (Rep 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
-> Code (Rep 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
-> (Code (Rep o) -> Offset 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 -> (Code (Rep o) -> Offset 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 -> Offset o -> Code (Rep o) -> Offset o
chooseOffset (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)) Offset o
o)) (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset Offset o
o) (Γ 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
    o :: Offset o
    o :: Offset o
o = Γ s o xs ('Succ n) r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o xs ('Succ n) r a
γ

    chooseOffset :: InputCharacteristic -> Offset o -> Code (Rep o) -> Offset o
    chooseOffset :: InputCharacteristic -> Offset o -> Code (Rep o) -> Offset o
chooseOffset (AlwaysConsumes Maybe Word
n) Offset o
o Code (Rep o)
qo# = Maybe Word -> Offset o -> Code (Rep o) -> Offset o
forall o. Maybe Word -> Offset o -> Code (Rep o) -> Offset o
moveN Maybe Word
n Offset o
o Code (Rep o)
qo#
    chooseOffset InputCharacteristic
NeverConsumes      Offset o
o Code (Rep o)
qo# = Offset o
o {offset :: Code (Rep o)
offset = Code (Rep o)
qo#}
    chooseOffset InputCharacteristic
MayConsume         Offset o
_ Code (Rep o)
qo# = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
u

{- 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 Code (Rep o)
qo# -> Γ 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 :: Offset o
input = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
u}))
        (\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.4.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)
               -> Offset 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
-> Offset 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 Offset o
o Word
u =
  Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
RecBuilder o =>
Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# @o Bool
needed (\Code (Rep o)
qc# -> 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 (Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qc# Word
u))) (((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
 -> Code (ST s (Maybe a)))
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Rep o) -> StaHandler s o a
qhandler ->
    Code (Rep o)
-> (DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a))
forall o s a.
RecBuilder o =>
Code (Rep o)
-> (DynHandler s o a -> Code (Rep o) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset Offset o
o) ((DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a)))
-> (DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \DynHandler s o a
qloop Code (Rep o)
qo# ->
      let off :: Offset o
off = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
u
      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
-> Offset 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
-> Offset 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 Offset 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 (Maybe (Offset o) -> StaHandler s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Offset o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (Offset o -> Maybe (Offset o)
forall a. a -> Maybe a
Just Offset o
off) (Code (Rep o) -> StaHandler s o a
qhandler Code (Rep o)
qo#)) 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 (Rep o)
o# DynHandler s o a
_ -> [|| $$qloop $$(o#) ||]) Ctx s o a
ctx))

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

@since 1.4.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.
             -> Offset 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
-> Offset 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 Offset o
o 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
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
RecBuilder o =>
Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# Bool
neededNo (\Code (Rep o)
qc# -> 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 (Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qc# Word
u))) (((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
 -> Code (ST s (Maybe a)))
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Rep o) -> StaHandler s o a
qno ->
      let handler :: Code (Rep o) -> StaHandler# s o a
handler Code (Rep o)
qc# Code (Rep o)
o = [||if $$(same qc# o) then $$(staHandler# qyes qc#) else $$(staHandler# (qno qc#) o)||]
      in Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
RecBuilder o =>
Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# @o Bool
True Code (Rep o) -> StaHandler# s o a
handler (((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
 -> Code (ST s (Maybe a)))
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Rep o) -> StaHandler s o a
qhandler ->
        Code (Rep o)
-> (DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a))
forall o s a.
RecBuilder o =>
Code (Rep o)
-> (DynHandler s o a -> Code (Rep o) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset Offset o
o) ((DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a)))
-> (DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \DynHandler s o a
qloop Code (Rep o)
qo# ->
          let off :: Offset o
off = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
u
          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
-> Offset 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
-> Offset 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 Offset 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 (Offset o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
forall o s a.
Offset o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
augmentHandlerFull Offset o
off (Code (Rep o) -> StaHandler s o a
qhandler Code (Rep o)
qo#) (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 Code (Rep o)
qo#) (Code (Rep o) -> StaHandler s o a
qno Code (Rep o)
qo#)) 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 (Rep o)
o# DynHandler s o a
_ -> [|| $$qloop $$(o#) ||]) 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
 -> DynCont s o a x
 -> Code (Rep o)
 -> DynHandler s o a
 -> Code (ST s (Maybe a)))
-> DynSubroutine s o a x
forall o s a x.
RecBuilder o =>
(DynSubroutine s o a x
 -> DynCont s o a x
 -> Code (Rep o)
 -> DynHandler s o a
 -> Code (ST s (Maybe a)))
-> DynSubroutine s o a x
bindRec# @o ((DynSubroutine s o a r
  -> DynCont s o a r
  -> Code (Rep o)
  -> DynHandler s o a
  -> Code (ST s (Maybe a)))
 -> DynSubroutine s o a r)
-> (DynSubroutine s o a r
    -> DynCont s o a r
    -> Code (Rep o)
    -> DynHandler s o a
    -> Code (ST s (Maybe a)))
-> DynSubroutine s o a r
forall a b. (a -> b) -> a -> b
$ \DynSubroutine s o a r
qself DynCont s o a r
qret Code (Rep o)
qo# DynHandler s o a
qh ->
      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
-> Offset 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
-> Offset 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) (Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
0) (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 (Offset o) -> DynHandler s o a -> AugmentedStaHandler s o a
forall s o a.
Maybe (Offset o) -> DynHandler s o a -> AugmentedStaHandler s o a
augmentHandlerDyn Maybe (Offset 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
-> (DynCont s o a r
    -> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a)))
-> StaSubroutine s o a r
forall s o a x.
Metadata -> StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutineMeta Metadata
meta ((DynCont s o a r
  -> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a)))
 -> StaSubroutine s o a r)
-> (DynCont s o a r
    -> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a)))
-> StaSubroutine s o a r
forall a b. (a -> b) -> a -> b
$ \DynCont s o a r
k Code (Rep o)
o# DynHandler s o a
h -> [|| $$qself $$k $$(o#) $$h ||]) (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
                       -> (Code (Rep o) -> StaHandler# s o a)
                       -> ((Code (Rep o) -> StaHandler s o a) -> Code b)
                       -> Code b
bindIterHandlerInline# :: Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# Bool
True  Code (Rep o) -> StaHandler# s o a
h (Code (Rep o) -> StaHandler s o a) -> Code b
k = (Code (Rep o) -> StaHandler# s o a)
-> (Code (Rep o -> Handler# s o a) -> Code b) -> Code b
forall o s a b.
RecBuilder o =>
(Code (Rep o) -> StaHandler# s o a)
-> (Code (Rep o -> Handler# s o a) -> Code b) -> Code b
bindIterHandler# @o Code (Rep o) -> StaHandler# s o a
h ((Code (Rep o -> Handler# s o a) -> Code b) -> Code b)
-> (Code (Rep o -> Handler# s o a) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code (Rep o -> Handler# s o a)
qh -> (Code (Rep o) -> StaHandler s o a) -> Code b
k (\Code (Rep o)
qo -> DynHandler s o a -> StaHandler s o a
forall s o a. DynHandler s o a -> StaHandler s o a
fromDynHandler [||$$qh $$qo||])
bindIterHandlerInline# Bool
False Code (Rep o) -> StaHandler# s o a
h (Code (Rep o) -> StaHandler s o a) -> Code b
k = (Code (Rep 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)
-> (Code (Rep o) -> StaHandler# s o a)
-> Code (Rep o)
-> StaHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code (Rep 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 Offset 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
$ \Code (Rep o)
o# -> let o :: Offset o
o = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
o# Word
u in [||
    trace $$(preludeString name '<' (γ {input = o}) ctx (color Red " Fail")) $$(staHandlerEval h o)
  ||]

{-|
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 (Γ s o xs n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset 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 = Offset o -> StaHandler s o a