{-# 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.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.Eq as Eq
import qualified Data.Set as Set
import qualified Language.Haskell.TH.Syntax as TH

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

-- * Type 'Gen'
-- | Generate the 'CodeQ' parsing the input.
newtype Gen inp vs es a = Gen { 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 -> Offset
parsingErrorOffset :: Offset
  ,  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 'Cont'
type Cont inp v a =
  {-farthestInput-}Cursor inp ->
  {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  v ->
  Cursor inp ->
  Either (ParsingError inp) a

-- ** Type 'SubRoutine'
type SubRoutine inp v a =
  {-ok-}Cont inp v a ->
  Cursor inp ->
  {-ko-}FailHandler inp a ->
  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)]
  }
-}

-- | @('generate' input mach)@ generates @TemplateHaskell@ code
-- parsing given 'input' according to given 'mach'ine.
generate ::
  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)
generate :: 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)
generate CodeQ inp
input (Gen GenCtx inp '[] ('Succ 'Zero) ret
-> CodeQ (Either (ParsingError inp) 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
  $$(k GenCtx
    { valueStack = ValueStackEmpty
    , failStack = FailStackCons [||finalFail||] FailStackEmpty
    , retCode = [||finalRet||]
    , input = [||init||]
    , nextInput = [||readNext||]
    , moreInput = [||readMore||]
    -- , farthestError = [||Nothing||]
    , farthestInput = [||init||]
    , farthestExpecting = [|| [] ||]
    })
  ||]

-- ** Type 'GenCtx'
-- | This is a context only present at compile-time.
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 es a
failStack :: 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)]
  }

-- ** Type 'ValueStack'
data ValueStack vs where
  ValueStackEmpty :: ValueStack '[]
  ValueStackCons ::
    -- TODO: maybe use H.Haskell instead of CodeQ ?
    -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
    { forall v (vs :: [*]). ValueStack (v : vs) -> CodeQ v
valueStackHead :: CodeQ v
    , forall v (vs :: [*]). ValueStack (v : vs) -> ValueStack vs
valueStackTail :: ValueStack vs
    } -> ValueStack (v ': vs)

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

instance Stackable Gen where
  push :: forall v inp (vs :: [*]) (n :: Peano) ret.
InstrPure v -> Gen inp (v : vs) n ret -> Gen inp vs n ret
push InstrPure v
x Gen inp (v : vs) n ret
k = (GenCtx inp vs n ret -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs n ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs n ret -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp vs n ret)
-> (GenCtx inp vs n ret -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs n ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp vs n ret
ctx -> Gen inp (v : vs) n ret
-> GenCtx inp (v : vs) n ret
-> CodeQ (Either (ParsingError inp) ret)
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) n ret
k GenCtx inp vs n ret
ctx
    { valueStack :: ValueStack (v : vs)
valueStack = CodeQ v -> ValueStack vs -> ValueStack (v : vs)
forall v (vs :: [*]).
CodeQ v -> ValueStack vs -> ValueStack (v : vs)
ValueStackCons (InstrPure v -> CodeQ v
forall a. InstrPure a -> CodeQ a
liftCode InstrPure v
x) (GenCtx inp vs n ret -> ValueStack vs
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp vs n ret
ctx) }
  pop :: forall inp (vs :: [*]) (n :: Peano) ret v.
Gen inp vs n ret -> Gen inp (v : vs) n ret
pop Gen inp vs n ret
k = (GenCtx inp (v : vs) n ret
 -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp (v : vs) n ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp (v : vs) n ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp (v : vs) n ret)
-> (GenCtx inp (v : vs) n ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp (v : vs) n ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp (v : vs) n ret
ctx -> Gen inp vs n ret
-> GenCtx inp vs n ret -> CodeQ (Either (ParsingError inp) ret)
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 n ret
k GenCtx inp (v : vs) n ret
ctx
    { valueStack :: ValueStack vs
valueStack = ValueStack (v : vs) -> ValueStack vs
forall v (vs :: [*]). ValueStack (v : vs) -> ValueStack vs
valueStackTail (GenCtx inp (v : vs) n ret -> ValueStack (v : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (v : vs) n ret
ctx) }
  liftI2 :: forall x y z inp (vs :: [*]) (es :: Peano) ret.
InstrPure (x -> y -> z)
-> Gen inp (z : vs) es ret -> Gen inp (y : x : vs) es ret
liftI2 InstrPure (x -> y -> z)
f Gen inp (z : vs) es ret
k = (GenCtx inp (y : x : vs) es ret
 -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp (y : x : vs) es ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp (y : x : vs) es ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp (y : x : vs) es ret)
-> (GenCtx inp (y : x : vs) es ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp (y : x : vs) es ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp (y : x : vs) es ret
ctx -> Gen inp (z : vs) es ret
-> GenCtx inp (z : vs) es ret
-> CodeQ (Either (ParsingError inp) ret)
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 ret
k GenCtx inp (y : x : vs) es ret
ctx
    { valueStack :: ValueStack (z : vs)
valueStack =
      let ValueStackCons CodeQ y
CodeQ v
y (ValueStackCons CodeQ x
CodeQ v
x ValueStack vs
ValueStack vs
xs) = GenCtx inp (y : x : vs) es ret -> ValueStack (y : x : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (y : x : vs) es ret
ctx in
      CodeQ z -> ValueStack vs -> ValueStack (z : vs)
forall v (vs :: [*]).
CodeQ v -> ValueStack vs -> ValueStack (v : vs)
ValueStackCons (InstrPure (x -> y -> z) -> CodeQ x -> CodeQ y -> CodeQ z
forall a b c.
InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
liftCode2 InstrPure (x -> y -> z)
f CodeQ x
x CodeQ y
y) ValueStack vs
xs
    }
  swap :: forall inp x y (vs :: [*]) (n :: Peano) r.
Gen inp (x : y : vs) n r -> Gen inp (y : x : vs) n r
swap Gen inp (x : y : vs) n r
k = (GenCtx inp (y : x : vs) n r
 -> CodeQ (Either (ParsingError inp) r))
-> Gen inp (y : x : vs) n r
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp (y : x : vs) n r
  -> CodeQ (Either (ParsingError inp) r))
 -> Gen inp (y : x : vs) n r)
-> (GenCtx inp (y : x : vs) n r
    -> CodeQ (Either (ParsingError inp) r))
-> Gen inp (y : x : vs) n r
forall a b. (a -> b) -> a -> b
$ \GenCtx inp (y : x : vs) n r
ctx -> Gen inp (x : y : vs) n r
-> GenCtx inp (x : y : vs) n r
-> CodeQ (Either (ParsingError inp) r)
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) n r
k GenCtx inp (y : x : vs) n r
ctx
    { valueStack :: ValueStack (x : y : vs)
valueStack =
        let ValueStackCons CodeQ y
CodeQ v
y (ValueStackCons CodeQ x
CodeQ v
x ValueStack vs
ValueStack vs
xs) = GenCtx inp (y : x : vs) n r -> ValueStack (y : x : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (y : x : vs) n r
ctx in
        CodeQ x -> ValueStack (y : vs) -> ValueStack (x : y : vs)
forall v (vs :: [*]).
CodeQ v -> ValueStack vs -> ValueStack (v : vs)
ValueStackCons CodeQ x
x (CodeQ y -> ValueStack vs -> ValueStack (y : vs)
forall v (vs :: [*]).
CodeQ v -> ValueStack vs -> ValueStack (v : vs)
ValueStackCons CodeQ y
y ValueStack vs
xs)
    }
instance Branchable Gen where
  case_ :: forall inp x (vs :: [*]) (n :: Peano) r y.
Gen inp (x : vs) n r
-> Gen inp (y : vs) n r -> Gen inp (Either x y : vs) n r
case_ Gen inp (x : vs) n r
kx Gen inp (y : vs) n r
ky = (GenCtx inp (Either x y : vs) n r
 -> CodeQ (Either (ParsingError inp) r))
-> Gen inp (Either x y : vs) n r
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp (Either x y : vs) n r
  -> CodeQ (Either (ParsingError inp) r))
 -> Gen inp (Either x y : vs) n r)
-> (GenCtx inp (Either x y : vs) n r
    -> CodeQ (Either (ParsingError inp) r))
-> Gen inp (Either x y : vs) n r
forall a b. (a -> b) -> a -> b
$ \GenCtx inp (Either x y : vs) n r
ctx ->
    let ValueStackCons CodeQ v
Code Q (Either x y)
v ValueStack vs
ValueStack vs
vs = GenCtx inp (Either x y : vs) n 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) n r
ctx in
    [||
      case $$v of
        Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons [||x||] vs })
        Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons [||y||] vs })
    ||]
  choices :: forall v inp (vs :: [*]) (es :: Peano) ret.
[InstrPure (v -> Bool)]
-> [Gen inp vs es ret]
-> Gen inp vs es ret
-> Gen inp (v : vs) es ret
choices [InstrPure (v -> Bool)]
fs [Gen inp vs es ret]
ks Gen inp vs es ret
kd = (GenCtx inp (v : vs) es ret
 -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp (v : vs) es ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp (v : vs) es ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp (v : vs) es ret)
-> (GenCtx inp (v : vs) es ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp (v : vs) es ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp (v : vs) es ret
ctx ->
    let ValueStackCons CodeQ v
CodeQ v
v ValueStack vs
ValueStack vs
vs = GenCtx inp (v : vs) es ret -> ValueStack (v : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (v : vs) es ret
ctx in
    GenCtx inp vs es ret
-> CodeQ v
-> [InstrPure (v -> Bool)]
-> [Gen inp vs es ret]
-> CodeQ (Either (ParsingError inp) ret)
go GenCtx inp (v : vs) es ret
ctx{valueStack :: ValueStack vs
valueStack = ValueStack vs
vs} CodeQ v
v [InstrPure (v -> Bool)]
fs [Gen inp vs es ret]
ks
    where
    go :: GenCtx inp vs es ret
-> CodeQ v
-> [InstrPure (v -> Bool)]
-> [Gen inp vs es ret]
-> CodeQ (Either (ParsingError inp) ret)
go GenCtx inp vs es ret
ctx CodeQ v
x (InstrPure (v -> Bool)
f:[InstrPure (v -> Bool)]
fs') (Gen GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret)
k:[Gen inp vs es ret]
ks') = [||
      if $$(liftCode1 f x) then $$(k ctx)
      else $$(go ctx x fs' ks')
      ||]
    go GenCtx inp vs es ret
ctx CodeQ v
_ [InstrPure (v -> Bool)]
_ [Gen inp vs es ret]
_ = Gen inp vs es ret
-> GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret)
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 ret
kd GenCtx inp vs es ret
ctx
instance Failable Gen where
  fail :: forall inp (vs :: [*]) (es :: Peano) ret.
[ErrorItem (InputToken inp)] -> Gen inp vs ('Succ es) ret
fail [ErrorItem (InputToken inp)]
failExp = (GenCtx inp vs ('Succ es) ret
 -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs ('Succ es) ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp vs ('Succ es) ret)
-> (GenCtx inp vs ('Succ es) ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall a b. (a -> b) -> a -> b
$ \ctx :: GenCtx inp vs ('Succ es) ret
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
    {-
    trace ("fail: "
      <>" failExp="<>show @[ErrorItem Char] failExp
      <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting ctx))
      <>" farExp="<>show @[ErrorItem Char] farExp) $
    -}
    $$(failStackHead (failStack ctx))
      $$(input ctx) farInp farExp
    ||]
  popFail :: forall inp (vs :: [*]) (es :: Peano) ret.
Gen inp vs es ret -> Gen inp vs ('Succ es) ret
popFail Gen inp vs es ret
k = (GenCtx inp vs ('Succ es) ret
 -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs ('Succ es) ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp vs ('Succ es) ret)
-> (GenCtx inp vs ('Succ es) ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp vs ('Succ es) ret
ctx ->
    let FailStackCons CodeQ
  (Cursor inp
   -> Cursor inp
   -> [ErrorItem (InputToken inp)]
   -> Either (ParsingError inp) ret)
_e FailStack inp es ret
FailStack inp es ret
es = GenCtx inp vs ('Succ es) ret -> FailStack inp ('Succ es) ret
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> FailStack inp es a
failStack GenCtx inp vs ('Succ es) ret
ctx in
    Gen inp vs es ret
-> GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret)
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 ret
k GenCtx inp vs ('Succ es) ret
ctx{failStack :: FailStack inp es ret
failStack = FailStack inp es ret
es}
  catchFail :: forall inp (vs :: [*]) (es :: Peano) ret.
Gen inp vs ('Succ es) ret
-> Gen inp (Cursor inp : vs) es ret -> Gen inp vs es ret
catchFail Gen inp vs ('Succ es) ret
ok Gen inp (Cursor inp : vs) es ret
ko = (GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs es ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp vs es ret)
-> (GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs es ret
forall a b. (a -> b) -> a -> b
$ \ctx :: GenCtx inp vs es ret
ctx@GenCtx{} -> [||
    let _ = "catchFail" in $$(unGen ok ctx
      { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
          -- trace ("catchFail: " <> "farExp="<>show farExp) $
          $$(unGen ko ctx
            -- Push the input as it was when entering the catchFail.
            { valueStack = ValueStackCons (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||]
            })
        ||] (failStack ctx)
      })
    ||]
instance Inputable Gen where
  loadInput :: forall inp (vs :: [*]) (es :: Peano) r.
Gen inp vs es r -> Gen inp (Cursor inp : vs) es r
loadInput Gen inp vs es r
k = (GenCtx inp (Cursor inp : vs) es r
 -> CodeQ (Either (ParsingError inp) r))
-> Gen inp (Cursor inp : vs) es r
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp (Cursor inp : vs) es r
  -> CodeQ (Either (ParsingError inp) r))
 -> Gen inp (Cursor inp : vs) es r)
-> (GenCtx inp (Cursor inp : vs) es r
    -> CodeQ (Either (ParsingError inp) r))
-> Gen inp (Cursor inp : vs) es r
forall a b. (a -> b) -> a -> b
$ \GenCtx inp (Cursor inp : vs) es r
ctx ->
    let ValueStackCons CodeQ v
CodeQ (Cursor inp)
input ValueStack vs
ValueStack vs
vs = GenCtx inp (Cursor inp : vs) es r -> ValueStack (Cursor inp : vs)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp (Cursor inp : vs) es r
ctx in
    Gen inp vs es r
-> GenCtx inp vs es r -> CodeQ (Either (ParsingError inp) r)
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 r
k GenCtx inp (Cursor inp : vs) es r
ctx{valueStack :: ValueStack vs
valueStack = ValueStack vs
vs, CodeQ (Cursor inp)
input :: CodeQ (Cursor inp)
input :: CodeQ (Cursor inp)
input}
  pushInput :: forall inp (vs :: [*]) (es :: Peano) ret.
Gen inp (Cursor inp : vs) es ret -> Gen inp vs es ret
pushInput Gen inp (Cursor inp : vs) es ret
k = (GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs es ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp vs es ret)
-> (GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs es ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp vs es ret
ctx ->
    Gen inp (Cursor inp : vs) es ret
-> GenCtx inp (Cursor inp : vs) es ret
-> CodeQ (Either (ParsingError inp) ret)
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 ret
k GenCtx inp vs es ret
ctx{valueStack :: ValueStack (Cursor inp : vs)
valueStack = CodeQ (Cursor inp) -> ValueStack vs -> ValueStack (Cursor inp : vs)
forall v (vs :: [*]).
CodeQ v -> ValueStack vs -> ValueStack (v : vs)
ValueStackCons (GenCtx inp vs es ret -> CodeQ (Cursor inp)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> CodeQ (Cursor inp)
input GenCtx inp vs es ret
ctx) (GenCtx inp vs es ret -> ValueStack vs
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> ValueStack vs
valueStack GenCtx inp vs es ret
ctx)}
instance Routinable Gen where
  call :: forall v inp (vs :: [*]) (es :: Peano) ret.
LetName v
-> Gen inp (v : vs) ('Succ es) ret -> Gen inp vs ('Succ es) ret
call (LetName Name
n) Gen inp (v : vs) ('Succ es) ret
k = (GenCtx inp vs ('Succ es) ret
 -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs ('Succ es) ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp vs ('Succ es) ret)
-> (GenCtx inp vs ('Succ es) ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp vs ('Succ es) ret
ctx -> [||
    let _ = "call" in
    $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
      $$(suspend k ctx)
      $$(input ctx)
      $! $$(failStackHead (failStack ctx))
    ||]
  jump :: forall ret inp (es :: Peano).
LetName ret -> Gen inp '[] ('Succ es) ret
jump (LetName Name
n) = (GenCtx inp '[] ('Succ es) ret
 -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp '[] ('Succ es) ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp '[] ('Succ es) ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp '[] ('Succ es) ret)
-> (GenCtx inp '[] ('Succ es) ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp '[] ('Succ es) ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp '[] ('Succ es) ret
ctx -> [||
    let _ = "jump" in
    $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
      $$(retCode ctx)
      $$(input ctx)
      $! $$(failStackHead (failStack ctx))
    ||]
  ret :: forall inp ret (es :: Peano). Gen inp '[ret] es ret
ret = (GenCtx inp '[ret] es ret -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp '[ret] es ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp '[ret] es ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp '[ret] es ret)
-> (GenCtx inp '[ret] es ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp '[ret] es ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp '[ret] es ret
ctx -> Gen inp '[ret] es ret
-> GenCtx inp '[ret] es ret
-> CodeQ (Either (ParsingError inp) ret)
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 ret ret) -> Gen inp '[ret] es ret
forall inp v a (vs :: [*]) (es :: Peano).
CodeQ (Cont inp v a) -> Gen inp (v : vs) es a
resume (GenCtx inp '[ret] es ret -> CodeQ (Cont inp ret ret)
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> CodeQ (Cont inp a a)
retCode GenCtx inp '[ret] es ret
ctx)) GenCtx inp '[ret] es ret
ctx
  subroutine :: forall v inp (vs :: [*]) (es :: Peano) ret.
LetName v
-> Gen inp '[] ('Succ 'Zero) v
-> Gen inp vs ('Succ es) ret
-> Gen inp vs ('Succ es) ret
subroutine (LetName Name
n) Gen inp '[] ('Succ 'Zero) v
sub Gen inp vs ('Succ es) ret
k = (GenCtx inp vs ('Succ es) ret
 -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs ('Succ es) ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp vs ('Succ es) ret)
-> (GenCtx inp vs ('Succ es) ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp vs ('Succ es) ret
ctx -> Q (TExp (Either (ParsingError inp) ret))
-> CodeQ (Either (ParsingError inp) ret)
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (Q (TExp (Either (ParsingError inp) ret))
 -> CodeQ (Either (ParsingError inp) ret))
-> Q (TExp (Either (ParsingError inp) ret))
-> CodeQ (Either (ParsingError inp) ret)
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q (TExp (Either (ParsingError inp) ret))
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
TH.unsafeTExpCoerce (Q Exp -> Q (TExp (Either (ParsingError inp) ret)))
-> Q Exp -> Q (TExp (Either (ParsingError inp) ret))
forall a b. (a -> b) -> a -> b
$ do
    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
      -- Why using $! at call site and not ! here on ko?
      \ !ok !inp ko ->
        $$(unGen sub ctx
          { valueStack = ValueStackEmpty
          , failStack = FailStackCons [||ko||] FailStackEmpty
          , input = [||inp||]
          , retCode = [||ok||]
          -- , farthestInput = [|inp|]
          -- , farthestExpecting = [|| [] ||]
          })
      ||]
    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) ret)) -> Q Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
TH.unTypeQ (CodeQ (Either (ParsingError inp) ret)
-> Q (TExp (Either (ParsingError inp) ret))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode (Gen inp vs ('Succ es) ret
-> GenCtx inp vs ('Succ es) ret
-> CodeQ (Either (ParsingError inp) ret)
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) ret
k GenCtx inp vs ('Succ es) ret
ctx))
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Exp -> Exp
TH.LetE [Dec
decl] Exp
expr)

suspend ::
  {-k-}Gen inp (v ': vs) es a ->
  GenCtx inp vs es a ->
  CodeQ (Cont inp v a)
suspend :: forall inp v (vs :: [*]) (es :: Peano) a.
Gen inp (v : vs) es a -> GenCtx inp vs es a -> CodeQ (Cont inp v a)
suspend 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 [||v||] (valueStack ctx)
      , input = [||inp||]
      , farthestInput = [||farInp||]
      , farthestExpecting = [||farExp||]
      }
    )
  ||]

resume :: CodeQ (Cont inp v a) -> Gen inp (v ': vs) es a
resume :: forall inp v a (vs :: [*]) (es :: Peano).
CodeQ (Cont inp v a) -> Gen inp (v : vs) es a
resume CodeQ (Cont inp v a)
k = (GenCtx inp (v : vs) es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp (v : vs) es a
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp (v : vs) es a -> CodeQ (Either (ParsingError inp) a))
 -> Gen inp (v : vs) es a)
-> (GenCtx inp (v : vs) es a
    -> CodeQ (Either (ParsingError inp) a))
-> Gen inp (v : vs) es a
forall a b. (a -> b) -> a -> b
$ \GenCtx inp (v : vs) es a
ctx -> [||
  let _ = "resume" in
  $$k
    $$(farthestInput ctx)
    $$(farthestExpecting ctx)
    $$(valueStackHead (valueStack ctx))
    $$(input ctx)
  ||]

instance Joinable Gen where
  defJoin :: forall v inp (vs :: [*]) (es :: Peano) ret.
LetName v
-> Gen inp (v : vs) es ret
-> Gen inp vs es ret
-> Gen inp vs es ret
defJoin (LetName Name
n) Gen inp (v : vs) es ret
sub Gen inp vs es ret
k = (GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs es ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp vs es ret)
-> (GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs es ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp vs es ret
ctx -> Q (TExp (Either (ParsingError inp) ret))
-> CodeQ (Either (ParsingError inp) ret)
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (Q (TExp (Either (ParsingError inp) ret))
 -> CodeQ (Either (ParsingError inp) ret))
-> Q (TExp (Either (ParsingError inp) ret))
-> CodeQ (Either (ParsingError inp) ret)
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q (TExp (Either (ParsingError inp) ret))
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
TH.unsafeTExpCoerce (Q Exp -> Q (TExp (Either (ParsingError inp) ret)))
-> Q Exp -> Q (TExp (Either (ParsingError inp) ret))
forall a b. (a -> b) -> a -> b
$ do
    Exp
body <- Q (TExp
     (Cursor inp
      -> [ErrorItem (InputToken inp)]
      -> v
      -> Cursor inp
      -> Either (ParsingError inp) ret))
-> 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) ret))
 -> Q Exp)
-> Q (TExp
        (Cursor inp
         -> [ErrorItem (InputToken inp)]
         -> v
         -> Cursor inp
         -> Either (ParsingError inp) ret))
-> Q Exp
forall a b. (a -> b) -> a -> b
$ Code
  Q
  (Cursor inp
   -> [ErrorItem (InputToken inp)]
   -> v
   -> Cursor inp
   -> Either (ParsingError inp) ret)
-> Q (TExp
        (Cursor inp
         -> [ErrorItem (InputToken inp)]
         -> v
         -> Cursor inp
         -> Either (ParsingError inp) ret))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode (Code
   Q
   (Cursor inp
    -> [ErrorItem (InputToken inp)]
    -> v
    -> Cursor inp
    -> Either (ParsingError inp) ret)
 -> Q (TExp
         (Cursor inp
          -> [ErrorItem (InputToken inp)]
          -> v
          -> Cursor inp
          -> Either (ParsingError inp) ret)))
-> Code
     Q
     (Cursor inp
      -> [ErrorItem (InputToken inp)]
      -> v
      -> Cursor inp
      -> Either (ParsingError inp) ret)
-> Q (TExp
        (Cursor inp
         -> [ErrorItem (InputToken inp)]
         -> v
         -> Cursor inp
         -> Either (ParsingError inp) ret))
forall a b. (a -> b) -> a -> b
$ [||
      \farInp farExp v !inp ->
        $$(unGen sub ctx
          { valueStack = ValueStackCons [||v||] (valueStack ctx)
          , input = [||inp||]
          , farthestInput = [||farInp||]
          , farthestExpecting = [||farExp||]
          })
      ||]
    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) ret)) -> Q Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
TH.unTypeQ (CodeQ (Either (ParsingError inp) ret)
-> Q (TExp (Either (ParsingError inp) ret))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode (Gen inp vs es ret
-> GenCtx inp vs es ret -> CodeQ (Either (ParsingError inp) ret)
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 ret
k GenCtx inp vs es ret
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) ret.
LetName v -> Gen inp (v : vs) es ret
refJoin (LetName Name
n) =
    CodeQ (Cont inp v ret) -> Gen inp (v : vs) es ret
forall inp v a (vs :: [*]) (es :: Peano).
CodeQ (Cont inp v a) -> Gen inp (v : vs) es a
resume (Q (TExp (Cont inp v ret)) -> CodeQ (Cont inp v ret)
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (Q Exp -> Q (TExp (Cont inp v ret))
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))))
instance Readable Gen Char where
  read :: forall inp (vs :: [*]) (es :: Peano) ret.
(Char ~ InputToken inp) =>
[ErrorItem Char]
-> InstrPure (Char -> Bool)
-> Gen inp (Char : vs) ('Succ es) ret
-> Gen inp vs ('Succ es) ret
read [ErrorItem Char]
farExp InstrPure (Char -> Bool)
p Gen inp (Char : vs) ('Succ es) ret
k =
    -- TODO: piggy bank
    Maybe Offset
-> Gen inp (Char : vs) ('Succ es) ret -> Gen inp vs ('Succ es) ret
maybeEmitCheck (Offset -> Maybe Offset
forall a. a -> Maybe a
Just Offset
1) Gen inp (Char : vs) ('Succ es) ret
k
    where
    maybeEmitCheck :: Maybe Offset
-> Gen inp (Char : vs) ('Succ es) ret -> Gen inp vs ('Succ es) ret
maybeEmitCheck Maybe Offset
Nothing Gen inp (Char : vs) ('Succ es) ret
ok = CodeQ (InputToken inp -> Bool)
-> Gen inp (InputToken inp : vs) ('Succ es) ret
-> Gen inp vs ('Succ es) ret
-> Gen inp vs ('Succ es) ret
forall inp (vs :: [*]) (es :: Peano) a.
(Ord (InputToken inp), Lift (InputToken inp)) =>
CodeQ (InputToken inp -> Bool)
-> Gen inp (InputToken inp : vs) ('Succ es) a
-> Gen inp vs ('Succ es) a
-> Gen inp vs ('Succ es) a
sat (InstrPure (Char -> Bool) -> CodeQ (Char -> Bool)
forall a. InstrPure a -> CodeQ a
liftCode InstrPure (Char -> Bool)
p) Gen inp (Char : vs) ('Succ es) ret
Gen inp (InputToken inp : vs) ('Succ es) ret
ok ([ErrorItem (InputToken inp)] -> Gen inp vs ('Succ es) ret
forall (repr :: * -> [*] -> Peano -> * -> *) inp (vs :: [*])
       (es :: Peano) ret.
Failable repr =>
[ErrorItem (InputToken inp)] -> repr inp vs ('Succ es) ret
fail [ErrorItem Char]
[ErrorItem (InputToken inp)]
farExp)
    maybeEmitCheck (Just Offset
n) Gen inp (Char : vs) ('Succ es) ret
ok = (GenCtx inp vs ('Succ es) ret
 -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs ('Succ es) ret
  -> CodeQ (Either (ParsingError inp) ret))
 -> Gen inp vs ('Succ es) ret)
-> (GenCtx inp vs ('Succ es) ret
    -> CodeQ (Either (ParsingError inp) ret))
-> Gen inp vs ('Succ es) ret
forall a b. (a -> b) -> a -> b
$ \GenCtx inp vs ('Succ es) ret
ctx ->
      let FailStackCons Code
  Q
  (Cursor inp
   -> Cursor inp -> [ErrorItem Char] -> Either (ParsingError inp) ret)
CodeQ (FailHandler inp ret)
e FailStack inp es ret
FailStack inp es ret
es = GenCtx inp vs ('Succ es) ret -> FailStack inp ('Succ es) ret
forall inp (vs :: [*]) (es :: Peano) a.
GenCtx inp vs es a -> FailStack inp es a
failStack GenCtx inp vs ('Succ es) ret
ctx in
      [||
      let readFail = $$(e) in -- Factorize failure code
      $$((`unGen` ctx{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
        {-ok-}(sat (liftCode p) ok
          {-ko-}(fail farExp))
        {-ko-}(fail farExp))
      ||]

sat ::
  forall inp vs es a.
  -- Cursorable (Cursor inp) =>
  -- InputToken inp ~ Char =>
  Ord (InputToken inp) =>
  TH.Lift (InputToken inp) =>
  {-predicate-}CodeQ (InputToken inp -> Bool) ->
  {-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->
  {-ko-}Gen inp vs ('Succ es) a ->
  Gen inp vs ('Succ es) a
sat :: forall inp (vs :: [*]) (es :: Peano) a.
(Ord (InputToken inp), Lift (InputToken inp)) =>
CodeQ (InputToken inp -> Bool)
-> Gen inp (InputToken inp : vs) ('Succ es) a
-> Gen inp vs ('Succ es) a
-> Gen inp vs ('Succ es) a
sat CodeQ (InputToken inp -> Bool)
p Gen inp (InputToken inp : vs) ('Succ es) a
ok Gen inp vs ('Succ es) a
ko = (GenCtx inp vs ('Succ es) a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs ('Succ es) a
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs ('Succ es) a
  -> CodeQ (Either (ParsingError inp) a))
 -> Gen inp vs ('Succ es) a)
-> (GenCtx inp vs ('Succ es) a
    -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs ('Succ es) a
forall a b. (a -> b) -> a -> b
$ \GenCtx inp vs ('Succ es) a
ctx -> [||
  let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
  if $$p c
  then $$(unGen ok ctx
    { valueStack = ValueStackCons [||c||] (valueStack ctx)
    , input = [||cs||]
    })
  else let _ = "sat.else" in $$(unGen ko ctx)
  ||]

{-
evalSat ::
  -- Cursorable inp =>
  -- HandlerOps inp =>
  InstrPure (Char -> Bool) ->
  Gen inp (Char ': vs) ('Succ es) a ->
  Gen inp vs ('Succ es) a
evalSat p k = do
  bankrupt <- asks isBankrupt
  hasChange <- asks hasCoin
  if | bankrupt -> maybeEmitCheck (Just 1) <$> k
     | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
     | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
  where
  maybeEmitCheck Nothing mk ctx = sat (genDefunc p) mk (raise ctx) ctx
  maybeEmitCheck (Just n) mk ctx =
    [|| let bad = $$(raise ctx) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] ctx)||]
-}

emitLengthCheck ::
  TH.Lift (InputToken inp) =>
  Int -> Gen inp vs es a -> Gen inp vs es a -> Gen inp vs es a
emitLengthCheck :: forall inp (vs :: [*]) (es :: Peano) a.
Lift (InputToken inp) =>
Offset -> Gen inp vs es a -> Gen inp vs es a -> Gen inp vs es a
emitLengthCheck Offset
0 Gen inp vs es a
ok Gen inp vs es a
_ko = Gen inp vs es a
ok
emitLengthCheck Offset
1 Gen inp vs es a
ok Gen inp vs es a
ko = (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
forall inp (vs :: [*]) (es :: Peano) a.
(GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
Gen ((GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
 -> Gen inp vs es a)
-> (GenCtx inp vs es a -> CodeQ (Either (ParsingError inp) a))
-> Gen inp vs es a
forall a b. (a -> b) -> a -> b
$ \GenCtx inp vs es a
ctx -> [||
  if $$(moreInput ctx) $$(input ctx)
  then $$(unGen ok ctx)
  else let _ = "sat.length-check.else" in $$(unGen ko ctx)
  ||]
{-
emitLengthCheck n ok ko ctx = Gen $ \ctx -> [||
  if $$moreInput ($$shiftRight $$(input ctx) (n - 1))
  then $$(unGen ok ctx)
  else $$(unGen ko ctx {farthestExpecting = [||farExp||]})
  ||]
-}


liftCode :: InstrPure a -> CodeQ a
liftCode :: forall a. InstrPure a -> CodeQ a
liftCode = InstrPure a -> Code Q a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans
{-# INLINE liftCode #-}

liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
liftCode1 :: forall a b. InstrPure (a -> b) -> CodeQ a -> CodeQ b
liftCode1 InstrPure (a -> b)
p CodeQ a
a = case InstrPure (a -> b)
p of
  InstrPure (a -> b)
InstrPureSameOffset -> [|| $$sameOffset $$a ||]
  InstrPureHaskell Haskell (a -> b)
h -> CodeQ a -> Haskell (a -> b) -> CodeQ b
forall a b. CodeQ a -> Haskell (a -> b) -> CodeQ b
go CodeQ a
a Haskell (a -> b)
h
  where
  go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
  go :: forall a b. CodeQ a -> Haskell (a -> b) -> CodeQ b
go CodeQ a
qa = \case
    Haskell (a -> b)
(H.:$) -> [|| \x -> $$qa x ||]
    Haskell (a -> b)
(H.:.) -> [|| \g x -> $$qa (g x) ||]
    Haskell (a -> b)
H.Flip -> [|| \x y -> $$qa y x ||]
    Haskell (a -> a -> a -> b)
(H.:.) H.:@ Haskell a
f H.:@ Haskell a
g -> [|| $$(go (go qa g) f) ||]
    Haskell (a -> b)
H.Const -> [|| \_ -> $$qa ||]
    Haskell (a -> a -> b)
H.Flip H.:@ Haskell a
H.Const -> CodeQ b
forall (repr :: * -> *) a. Haskellable repr => repr (a -> a)
H.id
    h :: Haskell (a -> b)
h@(Haskell (a -> a -> b)
H.Flip H.:@ Haskell a
_f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
    H.Eq Haskell a
x -> [|| $$(trans x) Eq.== $$qa ||]
    Haskell (a -> b)
H.Id -> CodeQ a
CodeQ b
qa
    Haskell (a -> b)
h -> [|| $$(trans h) $$qa ||]

liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
liftCode2 :: forall a b c.
InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
liftCode2 InstrPure (a -> b -> c)
p CodeQ a
a CodeQ b
b = case InstrPure (a -> b -> c)
p of
  InstrPure (a -> b -> c)
InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
  InstrPureHaskell Haskell (a -> b -> c)
h -> CodeQ a -> CodeQ b -> Haskell (a -> b -> c) -> CodeQ c
forall a b c.
CodeQ a -> CodeQ b -> Haskell (a -> b -> c) -> CodeQ c
go CodeQ a
a CodeQ b
b Haskell (a -> b -> c)
h
  where
  go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
  go :: forall a b c.
CodeQ a -> CodeQ b -> Haskell (a -> b -> c) -> CodeQ c
go CodeQ a
qa CodeQ b
qb = \case
    Haskell (a -> b -> c)
(H.:$) -> [|| $$qa $$qb ||]
    Haskell (a -> b -> c)
(H.:.) -> [|| \x -> $$qa ($$qb x) ||]
    Haskell (a -> b -> c)
H.Flip -> [|| \x -> $$qa x $$qb ||]
    Haskell (a -> a -> b -> c)
H.Flip H.:@ Haskell a
H.Const -> [|| $$qb ||]
    Haskell (a -> a -> b -> c)
H.Flip H.:@ Haskell a
f -> CodeQ b -> CodeQ a -> Haskell (b -> a -> c) -> CodeQ c
forall a b c.
CodeQ a -> CodeQ b -> Haskell (a -> b -> c) -> CodeQ c
go CodeQ b
qb CodeQ a
qa Haskell a
Haskell (b -> a -> c)
f
    Haskell (a -> b -> c)
H.Const -> [|| $$qa ||]
    Haskell (a -> b -> c)
H.Cons -> [|| $$qa : $$qb ||]
    Haskell (a -> b -> c)
h -> [|| $$(trans h) $$qa $$qb ||]