{-# LANGUAGE TemplateHaskell #-}

module Language.Parser.Ptera.TH.Pipeline.SRB2ParserDec where

import           Language.Parser.Ptera.Prelude

import qualified Data.Bits                                  as Bits
import qualified Data.EnumMap.Strict                        as EnumMap
import qualified Data.HashMap.Strict                        as HashMap
import qualified Language.Haskell.TH                        as TH
import qualified Language.Haskell.TH.Syntax                 as TH
import qualified Language.Parser.Ptera.Data.Alignable.Array as AlignableArray
import qualified Language.Parser.Ptera.Data.Symbolic.IntMap as SymbolicIntMap
import qualified Language.Parser.Ptera.Machine.LAPEG        as LAPEG
import qualified Language.Parser.Ptera.Machine.PEG          as PEG
import qualified Language.Parser.Ptera.Machine.SRB          as SRB
import qualified Language.Parser.Ptera.Syntax.Grammar       as Grammar
import qualified Language.Parser.Ptera.TH.Data.Bits.MaxBit  as Bits
import           Language.Parser.Ptera.TH.ParserLib
import qualified Language.Parser.Ptera.TH.Syntax            as Syntax

type SemanticAction ctx = Grammar.Action (Syntax.SemActM ctx)

data PipelineParam = PipelineParam
    {
        PipelineParam -> Q Type
startsTy    :: TH.Q TH.Type,
        PipelineParam -> Q Type
rulesTy     :: TH.Q TH.Type,
        PipelineParam -> Q Type
tokensTy    :: TH.Q TH.Type,
        PipelineParam -> Q Type
tokenTy     :: TH.Q TH.Type,
        PipelineParam -> Q Type
customCtxTy :: TH.Q TH.Type,
        PipelineParam -> (Int, Int)
tokenBounds :: (Int, Int)
    }

srb2QParser
    :: PipelineParam
    -> SRB.T Int StringLit (Maybe altDoc) (SemanticAction ctx)
    -> TH.Q [TH.Dec]
srb2QParser :: forall altDoc ctx.
PipelineParam
-> T Int StringLit (Maybe altDoc) (SemanticAction ctx) -> Q [Dec]
srb2QParser PipelineParam
param T Int StringLit (Maybe altDoc) (SemanticAction ctx)
srb = do
    let runnerFnName :: Name
runnerFnName = StringLit -> Name
TH.mkName StringLit
"pteraTHRunner"
    let parserInitialFnName :: Name
parserInitialFnName = StringLit -> Name
TH.mkName StringLit
"pteraTHParserInitial"
    let parserGetTokenNumFnName :: Name
parserGetTokenNumFnName = StringLit -> Name
TH.mkName StringLit
"pteraTHParserGetTokenNum"
    let parserTransFnName :: Name
parserTransFnName = StringLit -> Name
TH.mkName StringLit
"pteraTHParserTrans"
    let parserAltKindFnName :: Name
parserAltKindFnName = StringLit -> Name
TH.mkName StringLit
"pteraTHParserAltKind"
    let parserStateHelpFnName :: Name
parserStateHelpFnName = StringLit -> Name
TH.mkName StringLit
"pteraTHParserStateHelp"
    let parserAltHelpFnName :: Name
parserAltHelpFnName = StringLit -> Name
TH.mkName StringLit
"pteraTHParserAltHelp"
    let parserActionFnName :: Name
parserActionFnName = StringLit -> Name
TH.mkName StringLit
"pteraTHParserAction"

    forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ Name -> Type -> Dec
TH.SigD Name
parserInitialFnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> Maybe Int|]
        , Name -> EnumMap Int StateNum -> Q Dec
outputParserInitialFn Name
parserInitialFnName do forall start varDoc altDoc a.
SRB start varDoc altDoc a -> EnumMap start StateNum
SRB.initials T Int StringLit (Maybe altDoc) (SemanticAction ctx)
srb

        , Name -> Type -> Dec
TH.SigD Name
parserGetTokenNumFnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|$(tokenTy param) -> Int|]
        , Pat -> Body -> [Dec] -> Dec
TH.ValD do Name -> Pat
TH.VarP Name
parserGetTokenNumFnName
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
TH.NormalB [e|\t ->
                pteraTHTokenToTerminal (Proxy :: Proxy $(tokensTy param)) t
            |]
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []

        , Name -> Type -> Dec
TH.SigD Name
parserTransFnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> Int -> Trans|]
        , Name -> (Int, Int) -> T StateNum MState -> Q Dec
outputParserTransFn Name
parserTransFnName
            do PipelineParam -> (Int, Int)
tokenBounds PipelineParam
param
            do forall start varDoc altDoc a.
SRB start varDoc altDoc a -> T StateNum MState
SRB.states T Int StringLit (Maybe altDoc) (SemanticAction ctx)
srb

        , Name -> Type -> Dec
TH.SigD Name
parserAltKindFnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> AltKind|]
        , forall altDoc a. Name -> T AltNum (Alt altDoc a) -> Q Dec
outputParserAltKindFn Name
parserAltKindFnName do forall start varDoc altDoc a.
SRB start varDoc altDoc a -> T AltNum (Alt altDoc a)
SRB.alts T Int StringLit (Maybe altDoc) (SemanticAction ctx)
srb

        , Name -> Type -> Dec
TH.SigD Name
parserStateHelpFnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> [(Int, Int)]|]
        , Name -> T StateNum MState -> Q Dec
outputParserStateHelpFn Name
parserStateHelpFnName
            do forall start varDoc altDoc a.
SRB start varDoc altDoc a -> T StateNum MState
SRB.states T Int StringLit (Maybe altDoc) (SemanticAction ctx)
srb

        , Name -> Type -> Dec
TH.SigD Name
parserAltHelpFnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> (StringLit, Maybe ())|]
        , forall altDoc a.
Name
-> T AltNum (Alt altDoc a) -> T VarNum (Var StringLit) -> Q Dec
outputParserAltHelpFn Name
parserAltHelpFnName
            do forall start varDoc altDoc a.
SRB start varDoc altDoc a -> T AltNum (Alt altDoc a)
SRB.alts T Int StringLit (Maybe altDoc) (SemanticAction ctx)
srb
            do forall start varDoc altDoc a.
SRB start varDoc altDoc a -> T VarNum (Var varDoc)
SRB.vars T Int StringLit (Maybe altDoc) (SemanticAction ctx)
srb

        , Name -> Type -> Dec
TH.SigD Name
parserActionFnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> ActionM $(customCtxTy param)|]
        , forall altHelp ctx.
Name -> T AltNum (Alt altHelp (SemanticAction ctx)) -> Q Dec
outputParserActionFn Name
parserActionFnName do forall start varDoc altDoc a.
SRB start varDoc altDoc a -> T AltNum (Alt altDoc a)
SRB.alts T Int StringLit (Maybe altDoc) (SemanticAction ctx)
srb

        , Name -> Type -> Dec
TH.SigD Name
runnerFnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Parser
                $(customCtxTy param)
                $(rulesTy param)
                $(tokenTy param)
                $(startsTy param)
            |]
        , Name
-> Name -> Name -> Name -> Name -> Name -> Name -> Name -> Q Dec
outputRunnerFn Name
runnerFnName
            Name
parserInitialFnName
            Name
parserGetTokenNumFnName
            Name
parserTransFnName
            Name
parserAltKindFnName
            Name
parserStateHelpFnName
            Name
parserAltHelpFnName
            Name
parserActionFnName
        ]

outputParserInitialFn :: TH.Name -> EnumMap.EnumMap Int SRB.StateNum -> TH.Q TH.Dec
outputParserInitialFn :: Name -> EnumMap Int StateNum -> Q Dec
outputParserInitialFn Name
parserInitialFnName EnumMap Int StateNum
initials =
        Pat -> Body -> [Dec] -> Dec
TH.ValD do Name -> Pat
TH.VarP Name
parserInitialFnName
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
TH.NormalB [e|\s ->
                if s <= $(TH.lift ub)
                    then pteraTHArrayIndex table s
                    else Nothing
            |]
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
                table :: PteraTHArray Int (Maybe Int)
                table = pteraTHArrayFromList $(TH.lift ub) $(TH.ListE <$> qes)
            |]
    where
        ub :: Int
ub = if forall k a. EnumMap k a -> Bool
EnumMap.null EnumMap Int StateNum
initials
            then Int
-1
            else let (Int
i, StateNum
_) = forall k a. Enum k => EnumMap k a -> (k, a)
EnumMap.findMax EnumMap Int StateNum
initials in Int
i

        qes :: Q [Exp]
qes = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
            do \Int
i -> case forall k a. Enum k => k -> EnumMap k a -> Maybe a
EnumMap.lookup Int
i EnumMap Int StateNum
initials of
                Maybe StateNum
Nothing ->
                    [e|Nothing|]
                Just (SRB.StateNum Int
s) ->
                    [e|Just $(TH.lift s) :: Maybe Int|]
            [Int
0..Int
ub]

outputParserTransFn :: TH.Name
    -> (Int, Int)
    -> AlignableArray.T SRB.StateNum SRB.MState
    -> TH.Q TH.Dec
outputParserTransFn :: Name -> (Int, Int) -> T StateNum MState -> Q Dec
outputParserTransFn Name
parserTransFnName (Int
minTokBound, Int
maxTokBound) T StateNum MState
states = if
    | Int
tokBitSize forall a. Num a => a -> a -> a
+ Int
stateBitSize forall a. Ord a => a -> a -> Bool
> Int
29 ->
        forall a. HasCallStack => StringLit -> a
error StringLit
"exceed over bit size limited"
    | Bool
otherwise ->
        Pat -> Body -> [Dec] -> Dec
TH.ValD do Name -> Pat
TH.VarP Name
parserTransFnName
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
TH.NormalB [e|\s0 c0 ->
                let c1 = if c0 >= 0
                        then c0 - $(TH.lift minTokBound)
                        else $(TH.lift maxTokBound) + 1
                    s1 = $(stateTableLookupFn)
                        $(TH.lift tokBitSize)
                        stateTable
                        s0 c1
                    opsNum = $(opsNumTableLookupFn)
                        $(TH.lift tokBitSize)
                        opsNumTable
                        s0 c1
                    ops = pteraTHArrayIndex opsArr opsNum
                in Trans s1 ops
            |]
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
                stateTable = $(tableAddrExp stateByteSize
                    do reverse do outTransReprStates outTrans)
                opsNumTable = $(tableAddrExp opsNumByteSize
                    do reverse do outTransReprOpsNums outTrans)
                opsArr = pteraTHArrayFromList $(TH.lift opsNumMax)
                    $(TH.ListE <$>
                        do sequence do reverse do outTransReprTransOps outTrans)
            |]
    where
        tokBitSize :: Int
tokBitSize = forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize
            -- input tokens + special tokens (-1)
            do Int
maxTokBound forall a. Num a => a -> a -> a
- Int
minTokBound forall a. Num a => a -> a -> a
+ Int
1
        tokMax :: Int
tokMax = (Int
1 forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
tokBitSize) forall a. Num a => a -> a -> a
- Int
1
        stateBitSize :: Int
stateBitSize = forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize do forall (t :: * -> *) a. Foldable t => t a -> Int
length T StateNum MState
states forall a. Num a => a -> a -> a
- Int
1
        stateByteSize :: Int
stateByteSize = if
            | Int
stateBitSize forall a. Ord a => a -> a -> Bool
<= Int
8  -> Int
1
            | Int
stateBitSize forall a. Ord a => a -> a -> Bool
<= Int
16 -> Int
2
            | Bool
otherwise          -> Int
4
        stateTableLookupFn :: Q Exp
stateTableLookupFn = if
            | Int
stateBitSize forall a. Ord a => a -> a -> Bool
<= Int
8  -> [e|pteraTHLookupTable8|]
            | Int
stateBitSize forall a. Ord a => a -> a -> Bool
<= Int
16 -> [e|pteraTHLookupTable16|]
            | Bool
otherwise          -> [e|pteraTHLookupTable32|]

        outTrans :: OutTransRepr
outTrans = Int -> T StateNum MState -> OutTransRepr
genOutTransRepr Int
tokMax T StateNum MState
states
        opsNumMax :: Int
opsNumMax = OutTransRepr -> Int
outTransReprNextOpsNum OutTransRepr
outTrans forall a. Num a => a -> a -> a
- Int
1
        opsNumBitSize :: Int
opsNumBitSize = forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize Int
opsNumMax
        opsNumByteSize :: Int
opsNumByteSize = if
            | Int
opsNumBitSize forall a. Ord a => a -> a -> Bool
<= Int
8  -> Int
1
            | Int
opsNumBitSize forall a. Ord a => a -> a -> Bool
<= Int
16 -> Int
2
            | Bool
otherwise           -> Int
4
        opsNumTableLookupFn :: Q Exp
opsNumTableLookupFn = if
            | Int
opsNumBitSize forall a. Ord a => a -> a -> Bool
<= Int
8  -> [e|pteraTHLookupTable8|]
            | Int
opsNumBitSize forall a. Ord a => a -> a -> Bool
<= Int
16 -> [e|pteraTHLookupTable16|]
            | Bool
otherwise           -> [e|pteraTHLookupTable32|]

genOutTransRepr :: Int -> AlignableArray.T SRB.StateNum SRB.MState -> OutTransRepr
genOutTransRepr :: Int -> T StateNum MState -> OutTransRepr
genOutTransRepr Int
tokMax T StateNum MState
states = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    do \OutTransRepr
acc0 MState
srbState -> do
        let srbTrans :: T Trans
srbTrans = MState -> T Trans
SRB.stateTrans MState
srbState
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
            do \OutTransRepr
acc1 Int
i -> do
                let (Int
toSn, OutTransOpsRepr
opsRepr) = case forall a. Int -> IntMap a -> Maybe a
SymbolicIntMap.lookup Int
i T Trans
srbTrans of
                        Just (SRB.TransWithOps [TransOp]
ops (SRB.StateNum Int
x)) -> do
                            (Int
x, [TransOp] -> OutTransOpsRepr
OutTransWithOpsRepr [TransOp]
ops)
                        Just (SRB.TransReduce AltNum
alt) ->
                            (Int
-1, AltNum -> OutTransOpsRepr
OutTransReduce AltNum
alt)
                        Maybe Trans
Nothing ->
                            (Int
-1, [TransOp] -> OutTransOpsRepr
OutTransWithOpsRepr [])
                let opsMap0 :: HashMap OutTransOpsRepr Int
opsMap0 = OutTransRepr -> HashMap OutTransOpsRepr Int
outTransReprOpsMap OutTransRepr
acc1
                let nextOpsNum0 :: Int
nextOpsNum0 = OutTransRepr -> Int
outTransReprNextOpsNum OutTransRepr
acc1
                let transOps0 :: [Q Exp]
transOps0 = OutTransRepr -> [Q Exp]
outTransReprTransOps OutTransRepr
acc1
                let (Int
opsNum, HashMap OutTransOpsRepr Int
opsMap1, Int
nextOpsNum1, [Q Exp]
transOps1) =
                        case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup OutTransOpsRepr
opsRepr HashMap OutTransOpsRepr Int
opsMap0 of
                            Just Int
x ->
                                ( Int
x
                                , HashMap OutTransOpsRepr Int
opsMap0
                                , Int
nextOpsNum0
                                , [Q Exp]
transOps0
                                )
                            Maybe Int
Nothing ->
                                ( Int
nextOpsNum0
                                , forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert OutTransOpsRepr
opsRepr Int
nextOpsNum0 HashMap OutTransOpsRepr Int
opsMap0
                                , Int
nextOpsNum0 forall a. Num a => a -> a -> a
+ Int
1
                                , OutTransOpsRepr -> Q Exp
toTransOpsExp OutTransOpsRepr
opsReprforall a. a -> [a] -> [a]
:[Q Exp]
transOps0
                                )
                OutTransRepr
                    { $sel:outTransReprStates:OutTransRepr :: [Int]
outTransReprStates = Int
toSnforall a. a -> [a] -> [a]
:OutTransRepr -> [Int]
outTransReprStates OutTransRepr
acc1
                    , $sel:outTransReprOpsNums:OutTransRepr :: [Int]
outTransReprOpsNums = Int
opsNumforall a. a -> [a] -> [a]
:OutTransRepr -> [Int]
outTransReprOpsNums OutTransRepr
acc1
                    , $sel:outTransReprTransOps:OutTransRepr :: [Q Exp]
outTransReprTransOps = [Q Exp]
transOps1
                    , $sel:outTransReprNextOpsNum:OutTransRepr :: Int
outTransReprNextOpsNum = Int
nextOpsNum1
                    , $sel:outTransReprOpsMap:OutTransRepr :: HashMap OutTransOpsRepr Int
outTransReprOpsMap = HashMap OutTransOpsRepr Int
opsMap1
                    }
            do OutTransRepr
acc0
            do [Int
0..Int
tokMax]
    do OutTransRepr
        {
            $sel:outTransReprStates:OutTransRepr :: [Int]
outTransReprStates = [],
            $sel:outTransReprOpsNums:OutTransRepr :: [Int]
outTransReprOpsNums = [],
            $sel:outTransReprTransOps:OutTransRepr :: [Q Exp]
outTransReprTransOps = [],
            $sel:outTransReprNextOpsNum:OutTransRepr :: Int
outTransReprNextOpsNum = Int
0,
            $sel:outTransReprOpsMap:OutTransRepr :: HashMap OutTransOpsRepr Int
outTransReprOpsMap = forall k v. HashMap k v
HashMap.empty
        }
    do forall (t :: * -> *) a. Foldable t => t a -> [a]
toList T StateNum MState
states

tableAddrExp :: Int -> [Int] -> TH.Q TH.Exp
tableAddrExp :: Int -> [Int] -> Q Exp
tableAddrExp Int
unitSize [Int]
ns = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    do Lit -> Exp
TH.LitE
        do [Word8] -> Lit
TH.StringPrimL
            do forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                do \Int
sn -> Int -> Int -> [Word8]
addrCodeUnitsLE Int
unitSize
                    do forall a. Enum a => a -> Int
fromEnum Int
sn
                do [Int]
ns

-- | Should correspond @pteraTHLookupTable*@
addrCodeUnitsLE :: Int -> Int -> [Word8]
addrCodeUnitsLE :: Int -> Int -> [Word8]
addrCodeUnitsLE Int
unitSize Int
n
    | Int
n forall a. Ord a => a -> a -> Bool
>= Int
0    = forall a. Int -> [a] -> [a]
take Int
unitSize
        do forall a b. (a -> b) -> [a] -> [b]
map
            do \Int
m -> forall a. Num a => Integer -> a
fromInteger do forall a. Integral a => a -> Integer
toInteger do Int -> Int
mod8bit Int
m
            do forall a. (a -> a) -> a -> [a]
iterate (forall a. Bits a => a -> Int -> a
`Bits.shiftR` Int
8) Int
n
    | Int
n forall a. Eq a => a -> a -> Bool
== Int
-1   = forall a. Int -> a -> [a]
replicate Int
unitSize Word8
0xFF
    | Bool
otherwise = forall a. HasCallStack => StringLit -> a
error StringLit
"unsupported"
    where
        mod8bit :: Int -> Int
mod8bit Int
x = case forall a. Bits a => a -> Maybe Int
Bits.bitSizeMaybe Int
n of
            Maybe Int
Nothing -> Int
x forall a. Bits a => a -> a -> a
Bits..&. Int
0xFF
            Just Int
bs
                | Int
bs forall a. Ord a => a -> a -> Bool
<= Int
8   -> Int
x
                | Bool
otherwise -> Int
x forall a. Bits a => a -> a -> a
Bits..&. Int
0xFF

toTransOpsExp :: OutTransOpsRepr -> TH.Q TH.Exp
toTransOpsExp :: OutTransOpsRepr -> Q Exp
toTransOpsExp = \case
    OutTransWithOpsRepr [TransOp]
ops ->
        [Exp] -> Exp
TH.ListE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TransOp -> Q Exp
toTransOpExp [TransOp]
ops
    OutTransReduce (LAPEG.AltNum Int
alt) ->
        [e|[TransOpReduce $(TH.lift alt)]|]

toTransOpExp :: SRB.TransOp -> TH.Q TH.Exp
toTransOpExp :: TransOp -> Q Exp
toTransOpExp = \case
    SRB.TransOpEnter (LAPEG.VarNum Int
v) Bool
needBack Maybe StateNum
msn -> do
        let sn :: Int
sn = case Maybe StateNum
msn of
                Maybe StateNum
Nothing ->
                    Int
-1
                Just (SRB.StateNum Int
x) ->
                    Int
x
        [e|TransOpEnter $(TH.lift v) $(TH.lift needBack) $(TH.lift sn)|]
    SRB.TransOpPushBackpoint (SRB.StateNum Int
s) ->
        [e|TransOpPushBackpoint $(TH.lift s)|]
    SRB.TransOpHandleNot (LAPEG.AltNum Int
alt) ->
        [e|TransOpHandleNot $(TH.lift alt)|]
    TransOp
SRB.TransOpShift ->
        [e|TransOpShift|]

data OutTransRepr = OutTransRepr
    {
        OutTransRepr -> [Int]
outTransReprStates     :: [Int],
        OutTransRepr -> [Int]
outTransReprOpsNums    :: [Int],
        OutTransRepr -> [Q Exp]
outTransReprTransOps   :: [TH.Q TH.Exp],
        OutTransRepr -> Int
outTransReprNextOpsNum :: Int,
        OutTransRepr -> HashMap OutTransOpsRepr Int
outTransReprOpsMap     :: HashMap.HashMap OutTransOpsRepr Int
    }

data OutTransOpsRepr
    = OutTransWithOpsRepr [SRB.TransOp]
    | OutTransReduce LAPEG.AltNum
    deriving (OutTransOpsRepr -> OutTransOpsRepr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutTransOpsRepr -> OutTransOpsRepr -> Bool
$c/= :: OutTransOpsRepr -> OutTransOpsRepr -> Bool
== :: OutTransOpsRepr -> OutTransOpsRepr -> Bool
$c== :: OutTransOpsRepr -> OutTransOpsRepr -> Bool
Eq, Int -> OutTransOpsRepr -> ShowS
[OutTransOpsRepr] -> ShowS
OutTransOpsRepr -> StringLit
forall a.
(Int -> a -> ShowS) -> (a -> StringLit) -> ([a] -> ShowS) -> Show a
showList :: [OutTransOpsRepr] -> ShowS
$cshowList :: [OutTransOpsRepr] -> ShowS
show :: OutTransOpsRepr -> StringLit
$cshow :: OutTransOpsRepr -> StringLit
showsPrec :: Int -> OutTransOpsRepr -> ShowS
$cshowsPrec :: Int -> OutTransOpsRepr -> ShowS
Show, forall x. Rep OutTransOpsRepr x -> OutTransOpsRepr
forall x. OutTransOpsRepr -> Rep OutTransOpsRepr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OutTransOpsRepr x -> OutTransOpsRepr
$cfrom :: forall x. OutTransOpsRepr -> Rep OutTransOpsRepr x
Generic)

instance Hashable OutTransOpsRepr

outputParserAltKindFn
    :: TH.Name -> AlignableArray.T LAPEG.AltNum (LAPEG.Alt altDoc a)
    -> TH.Q TH.Dec
outputParserAltKindFn :: forall altDoc a. Name -> T AltNum (Alt altDoc a) -> Q Dec
outputParserAltKindFn Name
parserAltKindFnName T AltNum (Alt altDoc a)
alts = Pat -> Body -> [Dec] -> Dec
TH.ValD
    do Name -> Pat
TH.VarP Name
parserAltKindFnName
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
TH.NormalB [e|\i -> pteraTHArrayIndex table i|]
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
        table :: PteraTHArray Int AltKind
        table = pteraTHArrayFromList $(TH.lift do length alts - 1)
            $(TH.ListE <$> traverse altKindExp do toList alts)
    |]
    where
        altKindExp :: Alt altDoc a -> m Exp
altKindExp Alt altDoc a
alt = case forall altDoc a. Alt altDoc a -> AltKind
LAPEG.altKind Alt altDoc a
alt of
            AltKind
AltSeq -> [e|AltSeq|]
            AltKind
AltAnd -> [e|AltAnd|]
            AltKind
AltNot -> [e|AltNot|]

outputParserStateHelpFn
    :: TH.Name
    -> AlignableArray.T SRB.StateNum SRB.MState
    -> TH.Q TH.Dec
outputParserStateHelpFn :: Name -> T StateNum MState -> Q Dec
outputParserStateHelpFn Name
fnName T StateNum MState
states = Pat -> Body -> [Dec] -> Dec
TH.ValD
    do Name -> Pat
TH.VarP Name
fnName
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
TH.NormalB [e|\i -> pteraTHArrayIndex table i|]
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
        table :: PteraTHArray Int [(Int, Int)]
        table = pteraTHArrayFromList $(TH.lift do length states - 1)
            $(TH.ListE <$> traverse stateHelpExp do toList states)
    |]
    where
        stateHelpExp :: MState -> f Exp
stateHelpExp MState
st =
            let altItems :: [AltItem]
altItems = MState -> [AltItem]
SRB.stateAltItems MState
st
            in [Exp] -> Exp
TH.ListE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AltItem]
altItems \AltItem
altItem -> do
                let Int
altNum :: Int = coerce :: forall a b. Coercible a b => a -> b
coerce do AltItem -> AltNum
SRB.altItemAltNum AltItem
altItem
                    Int
pos :: Int = coerce :: forall a b. Coercible a b => a -> b
coerce do AltItem -> Position
SRB.altItemCurPos AltItem
altItem
                [e|($(TH.lift altNum) :: Int, $(TH.lift pos) :: Int)|]

outputParserAltHelpFn
    :: TH.Name
    -> AlignableArray.T LAPEG.AltNum (LAPEG.Alt altDoc a)
    -> AlignableArray.T LAPEG.VarNum (PEG.Var StringLit)
    -> TH.Q TH.Dec
outputParserAltHelpFn :: forall altDoc a.
Name
-> T AltNum (Alt altDoc a) -> T VarNum (Var StringLit) -> Q Dec
outputParserAltHelpFn Name
parserAltHelpFnName T AltNum (Alt altDoc a)
alts T VarNum (Var StringLit)
vars = Pat -> Body -> [Dec] -> Dec
TH.ValD
    do Name -> Pat
TH.VarP Name
parserAltHelpFnName
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
TH.NormalB [e|\i -> pteraTHArrayIndex table i|]
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
        table :: PteraTHArray Int (StringLit, Maybe ())
        table = pteraTHArrayFromList $(TH.lift do length alts - 1)
            $(TH.ListE <$> traverse altHelpExp do toList alts)
    |]
    where
        altHelpExp :: Alt altDoc a -> Q Exp
altHelpExp Alt altDoc a
alt =
            let v :: Var StringLit
v = forall n a. T n => Array n a -> n -> a
AlignableArray.forceIndex T VarNum (Var StringLit)
vars do forall altDoc a. Alt altDoc a -> VarNum
LAPEG.altVar Alt altDoc a
alt
            in [e|($(TH.lift do PEG.varHelp v), Nothing)|]

outputParserActionFn
    :: TH.Name
    -> AlignableArray.T LAPEG.AltNum (LAPEG.Alt altHelp (SemanticAction ctx))
    -> TH.Q TH.Dec
outputParserActionFn :: forall altHelp ctx.
Name -> T AltNum (Alt altHelp (SemanticAction ctx)) -> Q Dec
outputParserActionFn Name
parserActionFnName T AltNum (Alt altHelp (SemanticAction ctx))
alts = Pat -> Body -> [Dec] -> Dec
TH.ValD
    do Name -> Pat
TH.VarP Name
parserActionFnName
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
TH.NormalB [e|
        let arr = pteraTHArrayFromList $(TH.lift do length alts - 1)
                $(pure do
                    TH.ListE
                        [ TH.VarE do altActionForAltFnName n
                        | (n, _) <- AlignableArray.assocs alts
                        ]
                )
        in \i -> pteraTHArrayIndex arr i
    |]
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
        do \(AltNum
n, Alt altHelp (SemanticAction ctx)
alt) -> Pat -> Body -> [Dec] -> Dec
TH.ValD
            do Name -> Pat
TH.VarP do AltNum -> Name
altActionForAltFnName AltNum
n
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do Exp -> Body
TH.NormalB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {altDoc} {ctx}. Alt altDoc (Action (SemActM ctx)) -> Q Exp
altActionExp Alt altHelp (SemanticAction ctx)
alt
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        do forall n a. T n => Array n a -> [(n, a)]
AlignableArray.assocs T AltNum (Alt altHelp (SemanticAction ctx))
alts
    where
        altActionForAltFnName :: AltNum -> Name
altActionForAltFnName (LAPEG.AltNum Int
n) = StringLit -> Name
TH.mkName
            do StringLit
"pteraTHParserActionForAlt" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> StringLit
show Int
n

        altActionExp :: Alt altDoc (Action (SemActM ctx)) -> Q Exp
altActionExp Alt altDoc (Action (SemActM ctx))
alt = case forall altDoc a. Alt altDoc a -> a
LAPEG.altAction Alt altDoc (Action (SemActM ctx))
alt of
            Grammar.Action SemActM ctx us a
act -> [e|
                pteraTHAction $(Syntax.unsafeSemanticAction act)
                |]

outputRunnerFn
    :: TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name
    -> TH.Q TH.Dec
outputRunnerFn :: Name
-> Name -> Name -> Name -> Name -> Name -> Name -> Name -> Q Dec
outputRunnerFn
    Name
runnerFnName
    Name
parserInitialFnName
    Name
parserGetTokenNumFnName
    Name
parserTransFnName
    Name
parserAltKindFnName
    Name
parserStateHelpFnName
    Name
parserAltHelpFnName
    Name
parserActionFnName
    = Pat -> Body -> [Dec] -> Dec
TH.ValD do Name -> Pat
TH.VarP Name
runnerFnName
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
TH.NormalB [e|pteraTHUnsafeRunner parser|]
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
            parser = RunnerParser
                $(pure do TH.VarE parserInitialFnName)
                $(pure do TH.VarE parserGetTokenNumFnName)
                $(pure do TH.VarE parserTransFnName)
                $(pure do TH.VarE parserAltKindFnName)
                $(pure do TH.VarE parserStateHelpFnName)
                $(pure do TH.VarE parserAltHelpFnName)
                $(pure do TH.VarE parserActionFnName)
        |]