{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-} -- For nextInput
{-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
module Symantic.Parser.Machine.Generate where

import Control.Monad (Monad(..))
import Data.Bool (Bool)
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.List (minimum)
import Data.Map (Map)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Language.Haskell.TH (CodeQ, Code(..))
import Prelude ((+), (-))
import Text.Show (Show(..))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Language.Haskell.TH.Syntax as TH
-- import qualified Control.Monad.Trans.Writer as Writer

import Symantic.Univariant.Trans
import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
import qualified Symantic.Parser.Haskell as H

genCode :: TermInstr a -> CodeQ a
genCode :: forall a. TermInstr a -> CodeQ a
genCode = Term CodeQ a -> Code Q a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans

-- * Type 'Gen'
-- | Generate the 'CodeQ' parsing the input.
data Gen inp vs es a = Gen
  { forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon :: Map TH.Name Horizon -> Horizon
    -- ^ Synthetized (bottom-up) minimal input length
    -- required by the parser to not fail.
    -- This requires a 'minHorizonByName'
    -- containing the minimal 'Horizon's of all the 'TH.Name's
    -- this parser 'call's, 'jump's or 'refJoin's to.
  , forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen ::
      GenCtx inp vs es a ->
      CodeQ (Either (ParsingError inp) a)
  }

-- ** Type 'ParsingError'
data ParsingError inp
  =  ParsingErrorStandard
  {  forall inp. ParsingError inp -> Horizon
parsingErrorOffset :: Offset
    -- | Note that if an 'ErrorItemHorizon' greater than 1
    -- is amongst the 'parsingErrorExpecting'
    -- then this is only the 'InputToken'
    -- at the begining of the expected 'Horizon'.
  ,  forall inp. ParsingError inp -> Maybe (InputToken inp)
parsingErrorUnexpected :: Maybe (InputToken inp)
  ,  forall inp. ParsingError inp -> Set (ErrorItem (InputToken inp))
parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
  }
deriving instance Show (InputToken inp) => Show (ParsingError inp)

-- ** Type 'Offset'
type Offset = Int

-- ** Type 'Horizon'
-- | Synthetized minimal input length
-- required for a successful parsing.
-- Used with 'checkedHorizon' to factorize input length checks,
-- instead of checking the input length
-- one 'InputToken' at a time at each 'read'.
type Horizon = Offset

-- ** Type 'Cont'
type Cont inp v a =
  {-farthestInput-}Cursor inp ->
  {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  v ->
  Cursor inp ->
  Either (ParsingError inp) a

-- ** Type 'FailHandler'
type FailHandler inp a =
  {-failureInput-}Cursor inp ->
  {-farthestInput-}Cursor inp ->
  {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  Either (ParsingError inp) a

{-
-- *** Type 'FarthestError'
data FarthestError inp = FarthestError
  { farthestInput :: Cursor inp
  , farthestExpecting :: [ErrorItem (InputToken inp)]
  }
-}

-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
-- parsing the given 'input' according to the given 'Machine'.
generateCode ::
  forall inp ret.
  Ord (InputToken inp) =>
  Show (InputToken inp) =>
  TH.Lift (InputToken inp) =>
  -- InputToken inp ~ Char =>
  Input inp =>
  CodeQ inp ->
  Show (Cursor inp) =>
  Gen inp '[] ('Succ 'Zero) ret ->
  CodeQ (Either (ParsingError inp) ret)
generateCode :: forall inp ret.
(Ord (InputToken inp), Show (InputToken inp),
 Lift (InputToken inp), Input inp) =>
CodeQ inp
-> Show (Cursor inp) =>
   Gen inp '[] ('Succ 'Zero) ret
   -> CodeQ (Either (ParsingError inp) ret)
generateCode CodeQ inp
input Gen inp '[] ('Succ 'Zero) ret
k = [||
  -- Pattern bindings containing unlifted types
  -- should use an outermost bang pattern.
  let !(# init, readMore, readNext #) = $$(cursorOf input) in
  let finalRet = \_farInp _farExp v _inp -> Right v in
  let finalFail _failInp !farInp !farExp =
        Left ParsingErrorStandard
        { parsingErrorOffset = offset farInp
        , parsingErrorUnexpected =
            if readMore farInp
            then Just (let (# c, _ #) = readNext farInp in c)
            else Nothing
        , parsingErrorExpecting = Set.fromList farExp
        } in
  $$(unGen k GenCtx
    { valueStack = ValueStackEmpty
    , failStack = FailStackCons [||finalFail||] FailStackEmpty
    , retCode = [||finalRet||]
    , input = [||init||]
    , nextInput = [||readNext||]
    , moreInput = [||readMore||]
    -- , farthestError = [||Nothing||]
    , farthestInput = [||init||]
    , farthestExpecting = [|| [] ||]
    , checkedHorizon = 0
    , minHorizonByName = Map.empty
    })
  ||]

-- ** Type 'GenCtx'
-- | This is an inherited (top-down) context
-- only present at compile-time, to build TemplateHaskell splices.
data GenCtx inp vs (es::Peano) a =
  ( TH.Lift (InputToken inp)
  , Cursorable (Cursor inp)
  , Show (InputToken inp)
  -- , InputToken inp ~ Char
  ) => GenCtx
  { forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack :: ValueStack vs
  , forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> FailStack inp a es
failStack :: FailStack inp a es
  --, failStacks :: FailStack inp es a
  , forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> CodeQ (Cont inp a a)
retCode :: CodeQ (Cont inp a a)
  , forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> CodeQ (Cursor inp)
input :: CodeQ (Cursor inp)
  , forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> CodeQ (Cursor inp -> Bool)
moreInput :: CodeQ (Cursor inp -> Bool)
  , forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a
-> CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
  , forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> CodeQ (Cursor inp)
farthestInput :: CodeQ (Cursor inp)
  , forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> CodeQ [ErrorItem (InputToken inp)]
farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
    -- | Remaining horizon already checked.
    -- Updated by 'checkHorizon'
    -- and reset elsewhere when needed.
  , forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> Horizon
checkedHorizon :: Offset
    -- | Minimal horizon for each 'subroutine' or 'defJoin'.
    -- This can be done as an inherited attribute because
    -- 'OverserveSharing' introduces 'def' as an ancestor node
    -- of all the 'ref's pointing to it.
    -- Same for 'defJoin' and its 'refJoin's.
  , forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> Map Name Horizon
minHorizonByName :: Map TH.Name Offset
  }

-- ** Type 'ValueStack'
data ValueStack vs where
  ValueStackEmpty :: ValueStack '[]
  ValueStackCons ::
    { forall es (vs :: [*]). ValueStack (es : vs) -> TermInstr es
valueStackHead :: TermInstr v
    , forall es (vs :: [*]). ValueStack (es : vs) -> ValueStack vs
valueStackTail :: ValueStack vs
    } -> ValueStack (v ': vs)

-- ** Type 'FailStack'
data FailStack inp a es where
  FailStackEmpty :: FailStack inp a 'Zero
  FailStackCons ::
    { forall inp a (es :: Peano).
FailStack inp a ('Succ es) -> CodeQ (FailHandler inp a)
failStackHead :: CodeQ (FailHandler inp a)
    , forall inp a (es :: Peano).
FailStack inp a ('Succ es) -> FailStack inp a es
failStackTail :: FailStack inp a es
    } ->
    FailStack inp a ('Succ es)

instance Stackable Gen where
  push :: forall v inp (vs :: [*]) (es :: Peano) a.
TermInstr v -> Gen inp (v : vs) es a -> Gen inp vs es a
push TermInstr v
x Gen inp (v : vs) es a
k = Gen inp (v : vs) es a
k
    { unGen :: GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp vs es a
ctx -> Gen inp (v : vs) es a
-> GenCtx inp (v : vs) es a -> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp (v : vs) es a
k GenCtx inp vs es a
ctx
      { valueStack :: ValueStack (v : vs)
valueStack = TermInstr v -> ValueStack vs -> ValueStack (v : vs)
forall es (vs :: [*]).
TermInstr es -> ValueStack vs -> ValueStack (es : vs)
ValueStackCons TermInstr v
x (GenCtx inp vs es a -> ValueStack vs
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp vs es a
ctx) }
    }
  pop :: forall inp (vs :: [*]) (es :: Peano) a v.
Gen inp vs es a -> Gen inp (v : vs) es a
pop Gen inp vs es a
k = Gen inp vs es a
k
    { unGen :: GenCtx inp (v : vs) es a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp (v : vs) es a
ctx -> Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp vs es a
k GenCtx inp (v : vs) es a
ctx
      { valueStack :: ValueStack vs
valueStack = ValueStack (v : vs) -> ValueStack vs
forall es (vs :: [*]). ValueStack (es : vs) -> ValueStack vs
valueStackTail (GenCtx inp (v : vs) es a -> ValueStack (v : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (v : vs) es a
ctx) }
    }
  liftI2 :: forall x y z inp (vs :: [*]) (es :: Peano) a.
TermInstr (x -> y -> z)
-> Gen inp (z : vs) es a -> Gen inp (y : x : vs) es a
liftI2 TermInstr (x -> y -> z)
f Gen inp (z : vs) es a
k = Gen inp (z : vs) es a
k
    { unGen :: GenCtx inp (y : x : vs) es a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp (y : x : vs) es a
ctx -> Gen inp (z : vs) es a
-> GenCtx inp (z : vs) es a -> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp (z : vs) es a
k GenCtx inp (y : x : vs) es a
ctx
      { valueStack :: ValueStack (z : vs)
valueStack =
        let ValueStackCons Term CodeQ y
TermInstr v
y (ValueStackCons Term CodeQ x
TermInstr v
x ValueStack vs
ValueStack vs
xs) = GenCtx inp (y : x : vs) es a -> ValueStack (y : x : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (y : x : vs) es a
ctx in
        TermInstr z -> ValueStack vs -> ValueStack (z : vs)
forall es (vs :: [*]).
TermInstr es -> ValueStack vs -> ValueStack (es : vs)
ValueStackCons (TermInstr (x -> y -> z)
f TermInstr (x -> y -> z) -> Term CodeQ x -> Term CodeQ (y -> z)
forall (repr :: * -> *) es b.
Term repr (es -> b) -> Term repr es -> Term repr b
H.:@ Term CodeQ x
x Term CodeQ (y -> z) -> Term CodeQ y -> TermInstr z
forall (repr :: * -> *) es b.
Term repr (es -> b) -> Term repr es -> Term repr b
H.:@ Term CodeQ y
y) ValueStack vs
xs
      }
    }
  swap :: forall inp x y (vs :: [*]) (es :: Peano) a.
Gen inp (x : y : vs) es a -> Gen inp (y : x : vs) es a
swap Gen inp (x : y : vs) es a
k = Gen inp (x : y : vs) es a
k
    { unGen :: GenCtx inp (y : x : vs) es a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp (y : x : vs) es a
ctx -> Gen inp (x : y : vs) es a
-> GenCtx inp (x : y : vs) es a
-> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp (x : y : vs) es a
k GenCtx inp (y : x : vs) es a
ctx
      { valueStack :: ValueStack (x : y : vs)
valueStack =
          let ValueStackCons TermInstr y
TermInstr v
y (ValueStackCons TermInstr x
TermInstr v
x ValueStack vs
ValueStack vs
xs) = GenCtx inp (y : x : vs) es a -> ValueStack (y : x : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (y : x : vs) es a
ctx in
          TermInstr x -> ValueStack (y : vs) -> ValueStack (x : y : vs)
forall es (vs :: [*]).
TermInstr es -> ValueStack vs -> ValueStack (es : vs)
ValueStackCons TermInstr x
x (TermInstr y -> ValueStack vs -> ValueStack (y : vs)
forall es (vs :: [*]).
TermInstr es -> ValueStack vs -> ValueStack (es : vs)
ValueStackCons TermInstr y
y ValueStack vs
xs)
      }
    }
instance Branchable Gen where
  caseI :: forall inp x (vs :: [*]) (es :: Peano) r y.
Gen inp (x : vs) es r
-> Gen inp (y : vs) es r -> Gen inp (Either x y : vs) es r
caseI Gen inp (x : vs) es r
kx Gen inp (y : vs) es r
ky = Gen :: forall inp (vs :: [*]) (es :: Peano) a.
(Map Name Horizon -> Horizon)
-> (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = \Map Name Horizon
ls ->
      Gen inp (x : vs) es r -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp (x : vs) es r
kx Map Name Horizon
ls Horizon -> Horizon -> Horizon
forall a. Ord a => a -> a -> a
`min` Gen inp (y : vs) es r -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp (y : vs) es r
ky Map Name Horizon
ls
    , unGen :: GenCtx inp (Either x y : vs) es r
-> CodeQ (Either (ParsingError inp) r)
unGen = \GenCtx inp (Either x y : vs) es r
ctx ->
      let ValueStackCons TermInstr v
TermInstr (Either x y)
v ValueStack vs
ValueStack vs
vs = GenCtx inp (Either x y : vs) es r -> ValueStack (Either x y : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (Either x y : vs) es r
ctx in
      [||
        case $$(genCode v) of
          Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (H.Term [||x||]) vs })
          Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (H.Term [||y||]) vs })
      ||]
    }
  choices :: forall v inp (vs :: [*]) (es :: Peano) a.
[TermInstr (v -> Bool)]
-> [Gen inp vs es a] -> Gen inp vs es a -> Gen inp (v : vs) es a
choices [TermInstr (v -> Bool)]
fs [Gen inp vs es a]
ks Gen inp vs es a
kd = Gen :: forall inp (vs :: [*]) (es :: Peano) a.
(Map Name Horizon -> Horizon)
-> (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = \Map Name Horizon
hs -> [Horizon] -> Horizon
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Horizon] -> Horizon) -> [Horizon] -> Horizon
forall a b. (a -> b) -> a -> b
$
        Gen inp vs es a -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp vs es a
kd Map Name Horizon
hs Horizon -> [Horizon] -> [Horizon]
forall a. a -> [a] -> [a]
:
        (((Map Name Horizon -> Horizon) -> Map Name Horizon -> Horizon
forall a b. (a -> b) -> a -> b
$ Map Name Horizon
hs) ((Map Name Horizon -> Horizon) -> Horizon)
-> (Gen inp vs es a -> Map Name Horizon -> Horizon)
-> Gen inp vs es a
-> Horizon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen inp vs es a -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon (Gen inp vs es a -> Horizon) -> [Gen inp vs es a] -> [Horizon]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen inp vs es a]
ks)
    , unGen :: GenCtx inp (v : vs) es a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp (v : vs) es a
ctx ->
      let ValueStackCons Term CodeQ v
TermInstr v
v ValueStack vs
ValueStack vs
vs = GenCtx inp (v : vs) es a -> ValueStack (v : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (v : vs) es a
ctx in
      GenCtx inp vs es a
-> Term CodeQ v
-> [TermInstr (v -> Bool)]
-> [Gen inp vs es a]
-> CodeQ (Either (ParsingError inp) a)
go GenCtx inp (v : vs) es a
ctx{valueStack :: ValueStack vs
valueStack = ValueStack vs
vs} Term CodeQ v
v [TermInstr (v -> Bool)]
fs [Gen inp vs es a]
ks
    }
    where
    go :: GenCtx inp vs es a
-> Term CodeQ v
-> [TermInstr (v -> Bool)]
-> [Gen inp vs es a]
-> CodeQ (Either (ParsingError inp) a)
go GenCtx inp vs es a
ctx Term CodeQ v
x (TermInstr (v -> Bool)
f:[TermInstr (v -> Bool)]
fs') (Gen inp vs es a
k:[Gen inp vs es a]
ks') = [||
      if $$(genCode (f H.:@ x))
      then $$(unGen k ctx)
      else $$(go ctx x fs' ks')
      ||]
    go GenCtx inp vs es a
ctx Term CodeQ v
_ [TermInstr (v -> Bool)]
_ [Gen inp vs es a]
_ = Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp vs es a
kd GenCtx inp vs es a
ctx
instance Failable Gen where
  fail :: forall inp (vs :: [*]) (es :: Peano) a.
[ErrorItem (InputToken inp)] -> Gen inp vs ('Succ es) a
fail [ErrorItem (InputToken inp)]
failExp = Gen :: forall inp (vs :: [*]) (es :: Peano) a.
(Map Name Horizon -> Horizon)
-> (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = \Map Name Horizon
_hs -> Horizon
0
    , unGen :: GenCtx inp vs ('Succ es) a -> CodeQ (Either (ParsingError inp) a)
unGen = \ctx :: GenCtx inp vs ('Succ es) a
ctx@GenCtx{} -> [||
      let (# farInp, farExp #) =
            case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
              LT -> (# $$(input ctx), failExp #)
              EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)
              GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
      $$(failStackHead (failStack ctx))
        $$(input ctx) farInp farExp
      ||]
    }
  popFail :: forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Gen inp vs ('Succ es) a
popFail Gen inp vs es a
k = Gen inp vs es a
k
    { unGen :: GenCtx inp vs ('Succ es) a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp vs ('Succ es) a
ctx ->
      Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp vs es a
k GenCtx inp vs ('Succ es) a
ctx{failStack :: FailStack inp a es
failStack = FailStack inp a ('Succ es) -> FailStack inp a es
forall inp a (es :: Peano).
FailStack inp a ('Succ es) -> FailStack inp a es
failStackTail (GenCtx inp vs ('Succ es) a -> FailStack inp a ('Succ es)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> FailStack inp a es
failStack GenCtx inp vs ('Succ es) a
ctx)}
    }
  catchFail :: forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs ('Succ es) a
-> Gen inp (Cursor inp : vs) es a -> Gen inp vs es a
catchFail Gen inp vs ('Succ es) a
ok Gen inp (Cursor inp : vs) es a
ko = Gen :: forall inp (vs :: [*]) (es :: Peano) a.
(Map Name Horizon -> Horizon)
-> (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = \Map Name Horizon
ls -> Gen inp vs ('Succ es) a -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp vs ('Succ es) a
ok Map Name Horizon
ls Horizon -> Horizon -> Horizon
forall a. Ord a => a -> a -> a
`min` Gen inp (Cursor inp : vs) es a -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp (Cursor inp : vs) es a
ko Map Name Horizon
ls
    , unGen :: GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen = \ctx :: GenCtx inp vs es a
ctx@GenCtx{} -> Gen inp vs ('Succ es) a
-> GenCtx inp vs ('Succ es) a
-> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp vs ('Succ es) a
ok GenCtx inp vs es a
ctx
        { failStack :: FailStack inp a ('Succ es)
failStack = CodeQ (FailHandler inp a)
-> FailStack inp a es -> FailStack inp a ('Succ es)
forall inp a (es :: Peano).
CodeQ (FailHandler inp a)
-> FailStack inp a es -> FailStack inp a ('Succ es)
FailStackCons [|| \ !failInp !farInp !farExp ->
            -- trace ("catchFail: " <> "farExp="<>show farExp) $
            $$(unGen ko ctx
              -- Push the input as it was when entering the catchFail.
              { valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)
              -- Move the input to the failing position.
              , input = [||failInp||]
              -- Set the farthestInput to the farthest computed by 'fail'
              , farthestInput = [||farInp||]
              , farthestExpecting = [||farExp||]
              })
          ||] (GenCtx inp vs es a -> FailStack inp a es
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> FailStack inp a es
failStack GenCtx inp vs es a
ctx)
        }
    }
instance Inputable Gen where
  loadInput :: forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Gen inp (Cursor inp : vs) es a
loadInput Gen inp vs es a
k = Gen inp vs es a
k
    { unGen :: GenCtx inp (Cursor inp : vs) es a
-> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp (Cursor inp : vs) es a
ctx ->
      let ValueStackCons TermInstr v
TermInstr (Cursor inp)
input ValueStack vs
ValueStack vs
vs = GenCtx inp (Cursor inp : vs) es a -> ValueStack (Cursor inp : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (Cursor inp : vs) es a
ctx in
      Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp vs es a
k GenCtx inp (Cursor inp : vs) es a
ctx
        { valueStack :: ValueStack vs
valueStack = ValueStack vs
vs
        , input :: CodeQ (Cursor inp)
input = TermInstr (Cursor inp) -> CodeQ (Cursor inp)
forall a. TermInstr a -> CodeQ a
genCode TermInstr (Cursor inp)
input
        , checkedHorizon :: Horizon
checkedHorizon = Horizon
0
        }
    }
  pushInput :: forall inp (vs :: [*]) (es :: Peano) a.
Gen inp (Cursor inp : vs) es a -> Gen inp vs es a
pushInput Gen inp (Cursor inp : vs) es a
k = Gen inp (Cursor inp : vs) es a
k
    { unGen :: GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp vs es a
ctx ->
      Gen inp (Cursor inp : vs) es a
-> GenCtx inp (Cursor inp : vs) es a
-> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp (Cursor inp : vs) es a
k GenCtx inp vs es a
ctx{valueStack :: ValueStack (Cursor inp : vs)
valueStack = TermInstr (Cursor inp)
-> ValueStack vs -> ValueStack (Cursor inp : vs)
forall es (vs :: [*]).
TermInstr es -> ValueStack vs -> ValueStack (es : vs)
ValueStackCons (Code Q (Cursor inp) -> TermInstr (Cursor inp)
forall (repr :: * -> *) a. repr a -> Term repr a
H.Term (GenCtx inp vs es a -> Code Q (Cursor inp)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> CodeQ (Cursor inp)
input GenCtx inp vs es a
ctx)) (GenCtx inp vs es a -> ValueStack vs
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp vs es a
ctx)}
    }
instance Routinable Gen where
  subroutine :: forall v inp (vs :: [*]) (es :: Peano) a.
LetName v
-> Gen inp '[] ('Succ 'Zero) v
-> Gen inp vs ('Succ es) a
-> Gen inp vs ('Succ es) a
subroutine (LetName Name
n) Gen inp '[] ('Succ 'Zero) v
sub Gen inp vs ('Succ es) a
k = Gen :: forall inp (vs :: [*]) (es :: Peano) a.
(Map Name Horizon -> Horizon)
-> (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = Gen inp vs ('Succ es) a -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp vs ('Succ es) a
k
    , unGen :: GenCtx inp vs ('Succ es) a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp vs ('Succ es) a
ctx -> Q (TExp (Either (ParsingError inp) a))
-> CodeQ (Either (ParsingError inp) a)
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (Q (TExp (Either (ParsingError inp) a))
 -> CodeQ (Either (ParsingError inp) a))
-> Q (TExp (Either (ParsingError inp) a))
-> CodeQ (Either (ParsingError inp) a)
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q (TExp (Either (ParsingError inp) a))
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
TH.unsafeTExpCoerce (Q Exp -> Q (TExp (Either (ParsingError inp) a)))
-> Q Exp -> Q (TExp (Either (ParsingError inp) a))
forall a b. (a -> b) -> a -> b
$ do
      -- 'sub' is recursively 'call'able within 'sub',
      -- but its maximal 'minHorizon' is not known yet.
      let minHorizonByNameButSub :: Map Name Horizon
minHorizonByNameButSub = Name -> Horizon -> Map Name Horizon -> Map Name Horizon
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n Horizon
0 (GenCtx inp vs ('Succ es) a -> Map Name Horizon
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> Map Name Horizon
minHorizonByName GenCtx inp vs ('Succ es) a
ctx)
      Exp
body <- Q (TExp
     ((Cursor inp
       -> [ErrorItem (InputToken inp)]
       -> v
       -> Cursor inp
       -> Either (ParsingError inp) v)
      -> Cursor inp
      -> (Cursor inp
          -> Cursor inp
          -> [ErrorItem (InputToken inp)]
          -> Either (ParsingError inp) v)
      -> Either (ParsingError inp) v))
-> Q Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
TH.unTypeQ (Q (TExp
      ((Cursor inp
        -> [ErrorItem (InputToken inp)]
        -> v
        -> Cursor inp
        -> Either (ParsingError inp) v)
       -> Cursor inp
       -> (Cursor inp
           -> Cursor inp
           -> [ErrorItem (InputToken inp)]
           -> Either (ParsingError inp) v)
       -> Either (ParsingError inp) v))
 -> Q Exp)
-> Q (TExp
        ((Cursor inp
          -> [ErrorItem (InputToken inp)]
          -> v
          -> Cursor inp
          -> Either (ParsingError inp) v)
         -> Cursor inp
         -> (Cursor inp
             -> Cursor inp
             -> [ErrorItem (InputToken inp)]
             -> Either (ParsingError inp) v)
         -> Either (ParsingError inp) v))
-> Q Exp
forall a b. (a -> b) -> a -> b
$ Code
  Q
  ((Cursor inp
    -> [ErrorItem (InputToken inp)]
    -> v
    -> Cursor inp
    -> Either (ParsingError inp) v)
   -> Cursor inp
   -> (Cursor inp
       -> Cursor inp
       -> [ErrorItem (InputToken inp)]
       -> Either (ParsingError inp) v)
   -> Either (ParsingError inp) v)
-> Q (TExp
        ((Cursor inp
          -> [ErrorItem (InputToken inp)]
          -> v
          -> Cursor inp
          -> Either (ParsingError inp) v)
         -> Cursor inp
         -> (Cursor inp
             -> Cursor inp
             -> [ErrorItem (InputToken inp)]
             -> Either (ParsingError inp) v)
         -> Either (ParsingError inp) v))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode (Code
   Q
   ((Cursor inp
     -> [ErrorItem (InputToken inp)]
     -> v
     -> Cursor inp
     -> Either (ParsingError inp) v)
    -> Cursor inp
    -> (Cursor inp
        -> Cursor inp
        -> [ErrorItem (InputToken inp)]
        -> Either (ParsingError inp) v)
    -> Either (ParsingError inp) v)
 -> Q (TExp
         ((Cursor inp
           -> [ErrorItem (InputToken inp)]
           -> v
           -> Cursor inp
           -> Either (ParsingError inp) v)
          -> Cursor inp
          -> (Cursor inp
              -> Cursor inp
              -> [ErrorItem (InputToken inp)]
              -> Either (ParsingError inp) v)
          -> Either (ParsingError inp) v)))
-> Code
     Q
     ((Cursor inp
       -> [ErrorItem (InputToken inp)]
       -> v
       -> Cursor inp
       -> Either (ParsingError inp) v)
      -> Cursor inp
      -> (Cursor inp
          -> Cursor inp
          -> [ErrorItem (InputToken inp)]
          -> Either (ParsingError inp) v)
      -> Either (ParsingError inp) v)
-> Q (TExp
        ((Cursor inp
          -> [ErrorItem (InputToken inp)]
          -> v
          -> Cursor inp
          -> Either (ParsingError inp) v)
         -> Cursor inp
         -> (Cursor inp
             -> Cursor inp
             -> [ErrorItem (InputToken inp)]
             -> Either (ParsingError inp) v)
         -> Either (ParsingError inp) v))
forall a b. (a -> b) -> a -> b
$ [|| -- buildRec in Parsley
        -- subroutine called by 'call' or 'jump'
        \ !ok{-from generateSuspend or retCode-}
          !inp
          !ko{-from failStackHead-} ->
          $$(unGen sub ctx
            { valueStack = ValueStackEmpty
            , failStack = FailStackCons [||ko||] FailStackEmpty
            , input = [||inp||]
            , retCode = [||ok||]

            -- These are passed by the caller via 'ok' or 'ko'
            -- , farthestInput = 
            -- , farthestExpecting = 

            -- Some callers can call this subroutine
            -- with zero checkedHorizon, hence use this minimum.
            -- TODO: maybe it could be improved a bit
            -- by taking the minimum of the checked horizons
            -- before all the 'call's and 'jump's to this subroutine.
            , checkedHorizon = 0
            , minHorizonByName = minHorizonByNameButSub
            })
        ||]
      let decl :: Dec
decl = Name -> [Clause] -> Dec
TH.FunD Name
n [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [] (Exp -> Body
TH.NormalB Exp
body) []]
      Exp
expr <- Q (TExp (Either (ParsingError inp) a)) -> Q Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
TH.unTypeQ (CodeQ (Either (ParsingError inp) a)
-> Q (TExp (Either (ParsingError inp) a))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode (Gen inp vs ('Succ es) a
-> GenCtx inp vs ('Succ es) a
-> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp vs ('Succ es) a
k GenCtx inp vs ('Succ es) a
ctx
        { minHorizonByName :: Map Name Horizon
minHorizonByName =
            -- 'sub' is 'call'able within 'k'.
            Name -> Horizon -> Map Name Horizon -> Map Name Horizon
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n
              (Gen inp '[] ('Succ 'Zero) v -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp '[] ('Succ 'Zero) v
sub Map Name Horizon
minHorizonByNameButSub)
              (GenCtx inp vs ('Succ es) a -> Map Name Horizon
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> Map Name Horizon
minHorizonByName GenCtx inp vs ('Succ es) a
ctx)
        }))
      Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Exp -> Exp
TH.LetE [Dec
decl] Exp
expr)
    }
  jump :: forall a inp (es :: Peano). LetName a -> Gen inp '[] ('Succ es) a
jump (LetName Name
n) = Gen :: forall inp (vs :: [*]) (es :: Peano) a.
(Map Name Horizon -> Horizon)
-> (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = (Map Name Horizon -> Name -> Horizon
forall k a. Ord k => Map k a -> k -> a
Map.! Name
n)
    , unGen :: GenCtx inp '[] ('Succ es) a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp '[] ('Succ es) a
ctx -> [||
      let _ = "jump" in
      $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
        {-ok-}$$(retCode ctx)
        $$(input ctx)
        $$(failStackHead (failStack ctx))
      ||]
    }
  call :: forall v inp (vs :: [*]) (es :: Peano) a.
LetName v
-> Gen inp (v : vs) ('Succ es) a -> Gen inp vs ('Succ es) a
call (LetName Name
n) Gen inp (v : vs) ('Succ es) a
k = Gen inp (v : vs) ('Succ es) a
k
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = (Map Name Horizon -> Name -> Horizon
forall k a. Ord k => Map k a -> k -> a
Map.! Name
n)
    , unGen :: GenCtx inp vs ('Succ es) a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp vs ('Succ es) a
ctx -> [||
      let _ = "call" in
      $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
        {-ok-}$$(generateSuspend k ctx)
        $$(input ctx)
        $$(failStackHead (failStack ctx))
      ||]
    }
  ret :: forall inp a (es :: Peano). Gen inp '[a] es a
ret = Gen :: forall inp (vs :: [*]) (es :: Peano) a.
(Map Name Horizon -> Horizon)
-> (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = \Map Name Horizon
_hs -> Horizon
0
    , unGen :: GenCtx inp '[a] es a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp '[a] es a
ctx -> Gen inp '[a] es a
-> GenCtx inp '[a] es a -> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen (CodeQ (Cont inp a a) -> Gen inp '[a] es a
forall inp v a (vs :: [*]) (es :: Peano).
CodeQ (Cont inp v a) -> Gen inp (v : vs) es a
generateResume (GenCtx inp '[a] es a -> CodeQ (Cont inp a a)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> CodeQ (Cont inp a a)
retCode GenCtx inp '[a] es a
ctx)) GenCtx inp '[a] es a
ctx
    }

-- | Generate a continuation to be called with 'generateResume',
-- used when 'call' 'ret'urns.
-- The return 'v'alue is 'push'ed on the 'valueStack'.
generateSuspend ::
  {-k-}Gen inp (v ': vs) es a ->
  GenCtx inp vs es a ->
  CodeQ (Cont inp v a)
generateSuspend :: forall inp v (vs :: [*]) (es :: Peano) a.
Gen inp (v : vs) es a -> GenCtx inp vs es a -> CodeQ (Cont inp v a)
generateSuspend Gen inp (v : vs) es a
k GenCtx inp vs es a
ctx = [||
  let _ = "suspend" in
  \farInp farExp v !inp ->
    $$(unGen k ctx
      { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
      , input = [||inp||]
      , farthestInput = [||farInp||]
      , farthestExpecting = [||farExp||]
      , checkedHorizon = 0
      }
    )
  ||]

-- | Generate a call to the 'generateSuspend' continuation.
-- Used when 'call' 'ret'urns.
generateResume ::
  CodeQ (Cont inp v a) ->
  Gen inp (v ': vs) es a
generateResume :: forall inp v a (vs :: [*]) (es :: Peano).
CodeQ (Cont inp v a) -> Gen inp (v : vs) es a
generateResume CodeQ (Cont inp v a)
k = Gen :: forall inp (vs :: [*]) (es :: Peano) a.
(Map Name Horizon -> Horizon)
-> (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen
  { minHorizon :: Map Name Horizon -> Horizon
minHorizon = \Map Name Horizon
_hs -> Horizon
0
  , unGen :: GenCtx inp (v : vs) es a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp (v : vs) es a
ctx -> [||
    let _ = "resume" in
    $$k
      $$(farthestInput ctx)
      $$(farthestExpecting ctx)
      (let _ = "resume.genCode" in $$(genCode (valueStackHead (valueStack ctx))))
      $$(input ctx)
    ||]
  }

instance Joinable Gen where
  defJoin :: forall v inp (vs :: [*]) (es :: Peano) a.
LetName v
-> Gen inp (v : vs) es a -> Gen inp vs es a -> Gen inp vs es a
defJoin (LetName Name
n) Gen inp (v : vs) es a
joined Gen inp vs es a
k = Gen inp vs es a
k
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = Gen inp vs es a -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp vs es a
k
    , unGen :: GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp vs es a
ctx -> Q (TExp (Either (ParsingError inp) a))
-> CodeQ (Either (ParsingError inp) a)
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (Q (TExp (Either (ParsingError inp) a))
 -> CodeQ (Either (ParsingError inp) a))
-> Q (TExp (Either (ParsingError inp) a))
-> CodeQ (Either (ParsingError inp) a)
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q (TExp (Either (ParsingError inp) a))
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
TH.unsafeTExpCoerce (Q Exp -> Q (TExp (Either (ParsingError inp) a)))
-> Q Exp -> Q (TExp (Either (ParsingError inp) a))
forall a b. (a -> b) -> a -> b
$ do
      Exp
body <- Q (TExp
     (Cursor inp
      -> [ErrorItem (InputToken inp)]
      -> v
      -> Cursor inp
      -> Either (ParsingError inp) a))
-> Q Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
TH.unTypeQ (Q (TExp
      (Cursor inp
       -> [ErrorItem (InputToken inp)]
       -> v
       -> Cursor inp
       -> Either (ParsingError inp) a))
 -> Q Exp)
-> Q (TExp
        (Cursor inp
         -> [ErrorItem (InputToken inp)]
         -> v
         -> Cursor inp
         -> Either (ParsingError inp) a))
-> Q Exp
forall a b. (a -> b) -> a -> b
$ Code
  Q
  (Cursor inp
   -> [ErrorItem (InputToken inp)]
   -> v
   -> Cursor inp
   -> Either (ParsingError inp) a)
-> Q (TExp
        (Cursor inp
         -> [ErrorItem (InputToken inp)]
         -> v
         -> Cursor inp
         -> Either (ParsingError inp) a))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode (Code
   Q
   (Cursor inp
    -> [ErrorItem (InputToken inp)]
    -> v
    -> Cursor inp
    -> Either (ParsingError inp) a)
 -> Q (TExp
         (Cursor inp
          -> [ErrorItem (InputToken inp)]
          -> v
          -> Cursor inp
          -> Either (ParsingError inp) a)))
-> Code
     Q
     (Cursor inp
      -> [ErrorItem (InputToken inp)]
      -> v
      -> Cursor inp
      -> Either (ParsingError inp) a)
-> Q (TExp
        (Cursor inp
         -> [ErrorItem (InputToken inp)]
         -> v
         -> Cursor inp
         -> Either (ParsingError inp) a))
forall a b. (a -> b) -> a -> b
$ [||
        \farInp farExp v !inp ->
          $$(unGen joined ctx
            { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
            , input = [||inp||]
            , farthestInput = [||farInp||]
            , farthestExpecting = [||farExp||]
            , checkedHorizon = 0
            })
        ||]
      let decl :: Dec
decl = Name -> [Clause] -> Dec
TH.FunD Name
n [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [] (Exp -> Body
TH.NormalB Exp
body) []]
      Exp
expr <- Q (TExp (Either (ParsingError inp) a)) -> Q Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
TH.unTypeQ (CodeQ (Either (ParsingError inp) a)
-> Q (TExp (Either (ParsingError inp) a))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode (Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a
-> GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a)
unGen Gen inp vs es a
k GenCtx inp vs es a
ctx
        { minHorizonByName :: Map Name Horizon
minHorizonByName =
            -- 'joined' is 'refJoin'able within 'k'.
            Name -> Horizon -> Map Name Horizon -> Map Name Horizon
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n
              -- By definition (in 'joinNext')
              -- 'joined' is not recursively 'refJoin'able within 'joined',
              -- hence no need to prevent against recursivity
              -- as has to be done in 'subroutine'.
              (Gen inp (v : vs) es a -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp (v : vs) es a
joined (GenCtx inp vs es a -> Map Name Horizon
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> Map Name Horizon
minHorizonByName GenCtx inp vs es a
ctx))
              (GenCtx inp vs es a -> Map Name Horizon
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> Map Name Horizon
minHorizonByName GenCtx inp vs es a
ctx)
        }))
      Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Exp -> Exp
TH.LetE [Dec
decl] Exp
expr)
    }
  refJoin :: forall v inp (vs :: [*]) (es :: Peano) a.
LetName v -> Gen inp (v : vs) es a
refJoin (LetName Name
n) = (CodeQ (Cont inp v a) -> Gen inp (v : vs) es a
forall inp v a (vs :: [*]) (es :: Peano).
CodeQ (Cont inp v a) -> Gen inp (v : vs) es a
generateResume (Q (TExp (Cont inp v a)) -> CodeQ (Cont inp v a)
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (Q Exp -> Q (TExp (Cont inp v a))
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
TH.unsafeTExpCoerce (Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
TH.VarE Name
n)))))
    { minHorizon :: Map Name Horizon -> Horizon
minHorizon = (Map Name Horizon -> Name -> Horizon
forall k a. Ord k => Map k a -> k -> a
Map.! Name
n)
    }
instance Readable Char Gen where
  read :: forall inp (vs :: [*]) (es :: Peano) a.
(Char ~ InputToken inp) =>
[ErrorItem Char]
-> TermInstr (Char -> Bool)
-> Gen inp (Char : vs) ('Succ es) a
-> Gen inp vs ('Succ es) a
read [ErrorItem Char]
farExp TermInstr (Char -> Bool)
p = Gen inp vs ('Succ es) a -> Gen inp vs ('Succ es) a
forall inp (vs :: [*]) (es :: Peano) a.
Lift (InputToken inp) =>
Gen inp vs ('Succ es) a -> Gen inp vs ('Succ es) a
checkHorizon (Gen inp vs ('Succ es) a -> Gen inp vs ('Succ es) a)
-> (Gen inp (Char : vs) ('Succ es) a -> Gen inp vs ('Succ es) a)
-> Gen inp (Char : vs) ('Succ es) a
-> Gen inp vs ('Succ es) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrorItem (InputToken inp)]
-> TermInstr (InputToken inp -> Bool)
-> Gen inp (InputToken inp : vs) ('Succ es) a
-> Gen inp vs ('Succ es) a
forall inp (vs :: [*]) (es :: Peano) a.
(Ord (InputToken inp), Lift (InputToken inp)) =>
[ErrorItem (InputToken inp)]
-> TermInstr (InputToken inp -> Bool)
-> Gen inp (InputToken inp : vs) ('Succ es) a
-> Gen inp vs ('Succ es) a
checkToken [ErrorItem Char]
[ErrorItem (InputToken inp)]
farExp TermInstr (Char -> Bool)
TermInstr (InputToken inp -> Bool)
p

checkHorizon ::
  TH.Lift (InputToken inp) =>
  {-ok-}Gen inp vs ('Succ es) a ->
  Gen inp vs ('Succ es) a
checkHorizon :: forall inp (vs :: [*]) (es :: Peano) a.
Lift (InputToken inp) =>
Gen inp vs ('Succ es) a -> Gen inp vs ('Succ es) a
checkHorizon Gen inp vs ('Succ es) a
ok = Gen inp vs ('Succ es) a
ok
  { minHorizon :: Map Name Horizon -> Horizon
minHorizon = \Map Name Horizon
hs -> Horizon
1 Horizon -> Horizon -> Horizon
forall a. Num a => a -> a -> a
+ Gen inp vs ('Succ es) a -> Map Name Horizon -> Horizon
forall inp (vs :: [*]) (es :: Peano) a.
Gen inp vs es a -> Map Name Horizon -> Horizon
minHorizon Gen inp vs ('Succ es) a
ok Map Name Horizon
hs
  , unGen :: GenCtx inp vs ('Succ es) a -> CodeQ (Either (ParsingError inp) a)
unGen = \ctx0 :: GenCtx inp vs ('Succ es) a
ctx0@GenCtx{failStack :: forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> FailStack inp a es
failStack = FailStackCons CodeQ (FailHandler inp a)
e FailStack inp a es
es} -> [||
      -- Factorize failure code
      let readFail = $$(e) in
      $$(
        let ctx = ctx0{ failStack = FailStackCons [||readFail||] es } in
        if checkedHorizon ctx >= 1
        then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
        else let minHoriz = minHorizon ok (minHorizonByName ctx) in
          [||
          if $$(moreInput ctx)
               $$(if minHoriz > 0
                 then [||$$shiftRight minHoriz $$(input ctx)||]
                 else input ctx)
          then $$(unGen ok ctx{checkedHorizon = minHoriz})
          else let _ = "checkHorizon.else" in
            $$(unGen (fail [ErrorItemHorizon (minHoriz + 1)]) ctx)
          ||]
      )
    ||]
  }

checkToken ::
  forall inp vs es a.
  Ord (InputToken inp) =>
  TH.Lift (InputToken inp) =>
  [ErrorItem (InputToken inp)] ->
  {-predicate-}TermInstr (InputToken inp -> Bool) ->
  {-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->
  Gen inp vs ('Succ es) a
checkToken :: forall inp (vs :: [*]) (es :: Peano) a.
(Ord (InputToken inp), Lift (InputToken inp)) =>
[ErrorItem (InputToken inp)]
-> TermInstr (InputToken inp -> Bool)
-> Gen inp (InputToken inp : vs) ('Succ es) a
-> Gen inp vs ('Succ es) a
checkToken [ErrorItem (InputToken inp)]
farExp TermInstr (InputToken inp -> Bool)
p Gen inp (InputToken inp : vs) ('Succ es) a
ok = Gen inp (InputToken inp : vs) ('Succ es) a
ok
  { unGen :: GenCtx inp vs ('Succ es) a -> CodeQ (Either (ParsingError inp) a)
unGen = \GenCtx inp vs ('Succ es) a
ctx -> [||
    let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
    if $$(genCode p) c
    then $$(unGen ok ctx
      { valueStack = ValueStackCons (H.Term [||c||]) (valueStack ctx)
      , input = [||cs||]
      })
    else let _ = "checkToken.else" in $$(unGen (fail farExp) ctx)
    ||]
  }