{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}
{-# LANGUAGE AllowAmbiguousTypes,
             ConstrainedClassMethods,
             ConstraintKinds,
             CPP,
             ImplicitParams,
             MagicHash,
             PatternSynonyms,
             RecordWildCards,
             TypeApplications #-}
module Parsley.Internal.Backend.Machine.Ops (module Parsley.Internal.Backend.Machine.Ops) where

import Control.Monad                                 (liftM2)
import Control.Monad.Reader                          (ask, local)
import Control.Monad.ST                              (ST)
import Data.Array.Unboxed                            (UArray)
import Data.ByteString.Internal                      (ByteString)
import Data.STRef                                    (writeSTRef, readSTRef, newSTRef)
import Data.Proxy                                    (Proxy(Proxy))
import Data.Text                                     (Text)
import Data.Void                                     (Void)
import Debug.Trace                                   (trace)
import GHC.Exts                                      (Int(..), (-#))
import Language.Haskell.TH.Syntax                    (liftTyped)
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{-, representationTypes-})
import Parsley.Internal.Backend.Machine.Instructions (Access(..))
import Parsley.Internal.Backend.Machine.LetBindings  (Regs(..))
import Parsley.Internal.Backend.Machine.State        (Γ(..), Ctx, Machine(..), MachineMonad, StaSubRoutine, OpStack(..), DynFunc,
                                                      StaHandler(..), StaCont(..), DynHandler, DynCont, staHandler#, mkStaHandler, staCont#, mkStaCont,
                                                      run, voidCoins, insertSub, insertΦ, insertNewΣ, cacheΣ, cachedΣ, concreteΣ, debugLevel,
                                                      takeFreeRegisters)
import Parsley.Internal.Common                       (One, Code, Vec(..), Nat(..))
import Parsley.Internal.Core.InputTypes              (Text16, CharList, Stream)
import System.Console.Pretty                         (color, Color(Green, White, Red, Blue))

import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString)

#define inputInstances(derivation) \
derivation([Char])                 \
derivation((UArray Int Char))      \
derivation(Text16)                 \
derivation(ByteString)             \
derivation(CharList)               \
derivation(Stream)                 \
derivation(Lazy.ByteString)        \
derivation(Text)

type Ops o = (HandlerOps o, JoinBuilder o, RecBuilder o, PositionOps o, MarshalOps o, LogOps (Rep o))

{- Input Operations -}
sat :: (?ops :: InputOps (Rep o)) => (Defunc Char -> Defunc Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
sat :: (Defunc Char -> Defunc Bool)
-> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
-> Γ s o xs n r a
-> Code (ST s (Maybe a))
sat Defunc Char -> Defunc Bool
p Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))
k Code (ST s (Maybe a))
bad γ :: Γ s o xs n r a
γ@Γ{Code (Rep o)
Vec n (StaHandler s o a)
OpStack xs
StaCont s o a r
handlers :: forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (StaHandler s o a)
input :: forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Code (Rep o)
retCont :: forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> StaCont s o a r
operands :: forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
handlers :: Vec n (StaHandler s o a)
input :: Code (Rep o)
retCont :: StaCont s o a r
operands :: OpStack xs
..} = Code (Rep o)
-> (Code Char -> Code (Rep o) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall rep a.
(?ops::InputOps rep) =>
Code rep -> (Code Char -> Code rep -> Code a) -> Code a
next Code (Rep o)
input ((Code Char -> Code (Rep o) -> Code (ST s (Maybe a)))
 -> Code (ST s (Maybe a)))
-> (Code Char -> Code (Rep o) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code Char
c Code (Rep o)
input' -> let v :: Defunc Char
v = Code Char -> Defunc Char
forall a. Code a -> Defunc a
FREEVAR Code Char
c in Defunc Bool
-> Code (ST s (Maybe a))
-> Code (ST s (Maybe a))
-> Code (ST s (Maybe a))
forall a. Defunc Bool -> Code a -> Code a -> Code a
_if (Defunc Char -> Defunc Bool
p Defunc Char
v) (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))
k (Γ s o xs n r a
γ {operands :: OpStack (Char : xs)
operands = Defunc Char -> OpStack xs -> OpStack (Char : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op Defunc Char
v OpStack xs
operands, input :: Code (Rep o)
input = Code (Rep o)
input'})) Code (ST s (Maybe a))
bad

emitLengthCheck :: forall s o xs n r a. (?ops :: InputOps (Rep o), PositionOps o) => Int -> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
emitLengthCheck :: Int
-> (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
-> Γ s o xs n r a
-> Code (ST s (Maybe a))
emitLengthCheck Int
0 Γ s o xs n r a -> Code (ST s (Maybe a))
good Code (ST s (Maybe a))
_ Γ s o xs n r a
γ   = Γ s o xs n r a -> Code (ST s (Maybe a))
good Γ s o xs n r a
γ
emitLengthCheck Int
1 Γ s o xs n r a -> Code (ST s (Maybe a))
good Code (ST s (Maybe a))
bad Γ s o xs n r a
γ = [|| if $$more $$(input γ) then $$(good γ) else $$bad ||]
emitLengthCheck (I# Int#
n) Γ s o xs n r a -> Code (ST s (Maybe a))
good Code (ST s (Maybe a))
bad Γ s o xs n r a
γ = [||
  if $$more $$(shiftRight (Proxy @o) (input γ) (liftTyped (n -# 1#))) then $$(good γ)
  else $$bad ||]

{- General Operations -}
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 Defunc x
x Defunc x -> Code r
k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]

{-# 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)

{- Register Operations -}
newΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))
newΣ :: ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a
-> Code (ST s (Maybe a))
newΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s (Maybe a))
k Ctx s o a
ctx = Defunc x
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)))
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s (Maybe a))
k (Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$! Σ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 (Maybe a))
k Ctx s o a
ctx = Defunc x
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)))
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> [||
    do ref <- newSTRef $$(genDefunc dupx)
       $$(k $! insertNewΣ σ (Just [||ref||]) dupx ctx)
  ||]

writeΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))
writeΣ :: ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a
-> Code (ST s (Maybe a))
writeΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s (Maybe a))
k Ctx s o a
ctx = Defunc x
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)))
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s (Maybe a))
k (Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$! Σ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 (Maybe a))
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 (Maybe a))) -> Code (ST s (Maybe a))
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)))
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> [||
    do writeSTRef $$ref $$(genDefunc dupx)
       $$(k $! cacheΣ σ dupx ctx)
  ||]

readΣ :: ΣVar x -> Access -> (Defunc x -> Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))
readΣ :: ΣVar x
-> Access
-> (Defunc x -> Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a
-> Code (ST s (Maybe a))
readΣ ΣVar x
σ Access
Soft Defunc x -> Ctx s o a -> Code (ST s (Maybe a))
k Ctx s o a
ctx = (Defunc x -> Ctx s o a -> Code (ST s (Maybe a))
k (Defunc x -> Ctx s o a -> Code (ST s (Maybe a)))
-> Defunc x -> Ctx s o a -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$! Σ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 -> Code (ST s (Maybe a)))
-> Ctx s o a -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$! Ctx s o a
ctx
readΣ ΣVar x
σ Access
Hard Defunc x -> Ctx s o a -> Code (ST s (Maybe a))
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 -}
buildHandler :: Γ s o xs n r a
             -> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))
             -> Code (Rep o) -> StaHandler s o a
buildHandler :: Γ s o xs n r a
-> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))
-> Code (Rep o)
-> StaHandler s o a
buildHandler Γ s o xs n r a
γ Γ s o (o : xs) n r a -> Code (ST s (Maybe a))
h Code (Rep o)
c = StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
mkStaHandler (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 (Code (Rep o) -> Defunc o
forall o. Code (Rep o) -> Defunc o
OFFSET Code (Rep 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 :: Code (Rep o)
input = Code (Rep o)
o#})

fatal :: forall o s a. StaHandler s o a
fatal :: StaHandler s o a
fatal = StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
mkStaHandler (StaHandler# s o a -> StaHandler s o a)
-> StaHandler# s o a -> StaHandler s o a
forall a b. (a -> b) -> a -> b
$ Q (TExp (ST s (Maybe a))) -> StaHandler# s o a
forall a b. a -> b -> a
const [|| returnST Nothing ||]

class HandlerOps o where
  bindHandler :: Γ s o xs n r a
              -> (Code (Rep o) -> StaHandler s o a)
              -> (Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))

#define deriveHandlerOps(_o)                                                    \
instance HandlerOps _o where                                                    \
{                                                                               \
  bindHandler γ h k = [||                                                       \
    let handler (o# :: Rep _o) = $$(staHandler# (h (input γ)) [||o#||])         \
    in $$(k (γ {handlers = VCons (staHandler @_o [||handler||]) (handlers γ)})) \
  ||]                                                                           \
};
inputInstances(deriveHandlerOps)

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 StaHandler s o a
h Vec n (StaHandler s o a)
_ = Γ s o xs ('Succ n) r a -> Vec ('Succ n) (StaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (StaHandler s o a)
handlers Γ s o xs ('Succ n) r a
γ in 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
h (Γ s o xs ('Succ n) r a -> Code (Rep o)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Code (Rep o)
input Γ s o xs ('Succ n) r a
γ)

{- Control Flow Operations -}
suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a))) -> Γ s o xs n r a -> StaCont s o a x
suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a -> 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
γ = 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 :: Code (Rep o)
input = Code (Rep o)
o#})

halt :: forall o s a. 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||]

noreturn :: forall o s a. 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"||]

callWithContinuation :: forall o s a x n. MarshalOps o => StaSubRoutine s o a x -> StaCont s o a x -> Code (Rep o) -> Vec (Succ n) (StaHandler s o a) -> Code (ST s (Maybe a))
callWithContinuation :: StaSubRoutine s o a x
-> StaCont s o a x
-> Code (Rep o)
-> Vec ('Succ n) (StaHandler 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 StaHandler s o a
h Vec n (StaHandler s o a)
_) = StaSubRoutine s o a x
sub (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
ret) Code (Rep o)
input (StaHandler s o a -> DynHandler s o a
forall o s a. MarshalOps o => StaHandler s o a -> DynHandler s o a
dynHandler @o StaHandler s o a
h)

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) (Γ s o (x : xs) n r a -> Code (Rep o)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Code (Rep o)
input Γ s o (x : xs) n r a
γ)

{- Builder Operations -}
class JoinBuilder o where
  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

class RecBuilder o where
  buildIter :: Ctx s o a -> MVar Void -> Machine s o '[] One Void a
            -> (Code (Rep o) -> StaHandler s o a) -> Code (Rep o) -> Code (ST s (Maybe a))
  buildRec  :: MVar r
            -> Regs rs
            -> Ctx s o a
            -> Machine s o '[] One r a
            -> DynFunc rs s o a r

#define deriveJoinBuilder(_o)                                                       \
instance JoinBuilder _o where                                                       \
{                                                                                   \
  setupJoinPoint φ (Machine k) mx =                                                 \
    liftM2 (\mk ctx γ -> [||                                                        \
      let join x !(o# :: Rep _o) =                                                  \
        $$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||o#||]})) \
      in $$(run mx γ (insertΦ φ (staCont @_o [||join||]) ctx))                      \
    ||]) (local voidCoins k) ask;                                                   \
};
inputInstances(deriveJoinBuilder)

#define deriveRecBuilder(_o)                                                                               \
instance RecBuilder _o where                                                                               \
{                                                                                                          \
  buildIter ctx μ l h o = [||                                                                              \
      let handler (c# :: Rep _o) !(o# :: Rep _o) = $$(staHandler# (h [||c#||]) [||o#||]);                  \
          loop !(o# :: Rep _o) =                                                                           \
        $$(run l                                                                                           \
            (Γ Empty (noreturn @_o) [||o#||] (VCons (staHandler @_o [||handler o#||]) VNil))               \
            (voidCoins (insertSub μ (\_ o# _ -> [|| loop $$(o#) ||]) ctx)))                                \
      in loop $$o                                                                                          \
    ||];                                                                                                   \
  buildRec μ rs ctx k = takeFreeRegisters rs ctx (\ctx ->                                                  \
    {- The idea here is to try and reduce the number of times registers have to be passed around -}        \
    {-[|| \ ret !(o# :: Rep _o) h ->                                                                       \
      $$(run k (Γ Empty (staCont @_o [||ret||]) [||o#||] (VCons (staHandler @_o [||h||]) VNil)) ctx) ||]-} \
    [|| let self ret !(o# :: Rep _o) h =                                                                   \
          $$(run k                                                                                         \
              (Γ Empty (staCont @_o [||ret||]) [||o#||] (VCons (staHandler @_o [||h||]) VNil))             \
              (insertSub μ (\k o# h -> [|| self $$k $$(o#) $$h ||]) ctx)) in self ||]  );                  \
};
inputInstances(deriveRecBuilder)

{- Marshalling Operations -}
class MarshalOps o where
  dynHandler :: StaHandler s o a -> DynHandler s o a
  dynCont :: StaCont s o a x -> DynCont s o a x

staHandler :: forall o s a. DynHandler s o a -> StaHandler s o a
staHandler :: DynHandler s o a -> StaHandler s o a
staHandler DynHandler s o a
dh = StaHandler# s o a -> Maybe (DynHandler s o a) -> StaHandler s o a
forall s o a.
StaHandler# s o a -> Maybe (DynHandler s o a) -> StaHandler s o a
StaHandler (\Code (Rep o)
o# -> [|| $$dh $$(o#) ||]) (DynHandler s o a -> Maybe (DynHandler s o a)
forall a. a -> Maybe a
Just DynHandler s o a
dh)

staCont :: forall o s a x. DynCont s o a x -> StaCont s o a x
staCont :: DynCont s o a x -> StaCont s o a x
staCont DynCont s o a x
dk = StaCont# s o a x -> Maybe (DynCont s o a x) -> StaCont s o a x
forall s o a x.
StaCont# s o a x -> Maybe (DynCont s o a x) -> StaCont s o a x
StaCont (\Code x
x Code (Rep o)
o# -> [|| $$dk $$x $$(o#) ||]) (DynCont s o a x -> Maybe (DynCont s o a x)
forall a. a -> Maybe a
Just DynCont s o a x
dk)

#define deriveMarshalOps(_o)                                                            \
instance MarshalOps _o where                                                            \
{                                                                                       \
  dynHandler (StaHandler sh Nothing) = [||\ !(o# :: Rep _o) -> $$(sh [||o#||]) ||];     \
  dynHandler (StaHandler _ (Just dh)) = dh;                                             \
  dynCont (StaCont sk Nothing) = [||\ x (o# :: Rep _o) -> $$(sk [||x||] [||o#||]) ||]; \
  dynCont (StaCont _ (Just dk)) = dk;                                                   \
};
inputInstances(deriveMarshalOps)

{- Debugger Operations -}
type LogHandler o = (PositionOps o, LogOps (Rep o))

logHandler :: (?ops :: InputOps (Rep o), LogHandler o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Code (Rep o) -> StaHandler s o a
logHandler :: [Char]
-> Ctx s o a
-> Γ s o xs ('Succ n) ks a
-> Code (Rep o)
-> StaHandler s o a
logHandler [Char]
name Ctx s o a
ctx Γ s o xs ('Succ n) ks a
γ Code (Rep o)
_ = let VCons StaHandler s o a
h Vec n (StaHandler s o a)
_ = Γ s o xs ('Succ n) ks a -> Vec ('Succ n) (StaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (StaHandler 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
mkStaHandler (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# -> [||
    trace $$(preludeString name '<' (γ {input = o#}) ctx (color Red " Fail")) $$(staHandler# h o#)
  ||]

preludeString :: forall s o xs n r a. (?ops :: InputOps (Rep o), LogHandler o) => String -> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String
preludeString :: [Char]
-> Char -> Γ s o xs n r a -> Ctx s o a -> [Char] -> Code [Char]
preludeString [Char]
name Char
dir Γ s o xs n r a
γ Ctx s o a
ctx [Char]
ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]
  where
    offset :: Code (Rep o)
offset     = Γ s o xs n r a -> Code (Rep o)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Code (Rep o)
input Γ s o xs n r a
γ
    proxy :: Proxy o
proxy      = Proxy o
forall k (t :: k). Proxy t
Proxy @o
    indent :: [Char]
indent     = Int -> Char -> [Char]
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        = Proxy o -> Code (Rep o) -> Code Int# -> Code (Rep o)
forall input (rep :: TYPE (RepKind input)).
(PositionOps input, rep ~ Rep input) =>
Proxy input -> Code rep -> Code Int# -> Code rep
shiftRight Proxy o
proxy Code (Rep o)
offset [||5#||]
    inputTrace :: Code [Char]
inputTrace = [|| let replace '\n' = color Green "↙"
                         replace ' '  = color White "·"
                         replace c    = return c
                         go i#
                           | $$(same proxy [||i#||] end) || not ($$more i#) = []
                           | otherwise = $$(next [||i#||] (\qc qi' -> [||replace $$qc ++ go $$qi'||]))
                     in go $$start ||]
    eof :: Code [Char]
eof        = [|| if $$more $$end then $$inputTrace else $$inputTrace ++ color Red "•" ||]
    prelude :: Code [Char]
prelude    = [|| concat [indent, dir : name, dir : " (", show ($$(offToInt offset)), "): "] ||]
    caretSpace :: Code [Char]
caretSpace = [|| replicate (length $$prelude + $$(offToInt offset) - $$(offToInt start)) ' ' ||]

-- RIP Dream :(
{-$(let derive _o = [d|
        instance HandlerOps _o where
          fatal = [||\(!o#) -> return Nothing :: ST s (Maybe a)||]
        |] in traverse derive representationTypes)-}