{-# 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 :: 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"

    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ Name -> Type -> Dec
TH.SigD Name
parserInitialFnName (Type -> Dec) -> Q Type -> Q Dec
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 T Int StringLit (Maybe altDoc) (SemanticAction ctx)
-> EnumMap Int StateNum
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 (Type -> Dec) -> Q Type -> Q Dec
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
            (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body) -> Q Exp -> Q Body
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
            |]
            Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

        , Name -> Type -> Dec
TH.SigD Name
parserTransFnName (Type -> Dec) -> Q Type -> Q Dec
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 T Int StringLit (Maybe altDoc) (SemanticAction ctx)
-> T StateNum MState
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 (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> AltKind|]
        , Name -> T AltNum (Alt (Maybe altDoc) (SemanticAction ctx)) -> Q Dec
forall altDoc a. Name -> T AltNum (Alt altDoc a) -> Q Dec
outputParserAltKindFn Name
parserAltKindFnName do T Int StringLit (Maybe altDoc) (SemanticAction ctx)
-> T AltNum (Alt (Maybe altDoc) (SemanticAction ctx))
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 (Type -> Dec) -> Q Type -> Q Dec
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 T Int StringLit (Maybe altDoc) (SemanticAction ctx)
-> T StateNum MState
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 (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> (StringLit, Maybe ())|]
        , Name
-> T AltNum (Alt (Maybe altDoc) (SemanticAction ctx))
-> T VarNum (Var StringLit)
-> Q Dec
forall altDoc a.
Name
-> T AltNum (Alt altDoc a) -> T VarNum (Var StringLit) -> Q Dec
outputParserAltHelpFn Name
parserAltHelpFnName
            do T Int StringLit (Maybe altDoc) (SemanticAction ctx)
-> T AltNum (Alt (Maybe altDoc) (SemanticAction ctx))
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 T Int StringLit (Maybe altDoc) (SemanticAction ctx)
-> T VarNum (Var StringLit)
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 (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> ActionM $(customCtxTy param)|]
        , Name -> T AltNum (Alt (Maybe altDoc) (SemanticAction ctx)) -> Q Dec
forall altHelp ctx.
Name -> T AltNum (Alt altHelp (SemanticAction ctx)) -> Q Dec
outputParserActionFn Name
parserActionFnName do T Int StringLit (Maybe altDoc) (SemanticAction ctx)
-> T AltNum (Alt (Maybe altDoc) (SemanticAction ctx))
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 (Type -> Dec) -> Q Type -> Q Dec
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
            (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body) -> Q Exp -> Q Body
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
            |]
            Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
                table = pteraTHArrayFromList $(TH.lift ub) $(TH.ListE <$> qes)
            |]
    where
        ub :: Int
ub = if EnumMap Int StateNum -> Bool
forall k a. EnumMap k a -> Bool
EnumMap.null EnumMap Int StateNum
initials
            then Int
-1
            else let (Int
i, StateNum
_) = EnumMap Int StateNum -> (Int, StateNum)
forall k a. Enum k => EnumMap k a -> (k, a)
EnumMap.findMax EnumMap Int StateNum
initials in Int
i

        qes :: Q [Exp]
qes = (Int -> Q Exp) -> [Int] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
            do \Int
i -> case Int -> EnumMap Int StateNum -> Maybe StateNum
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)|]
            [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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stateBitSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
29 ->
        StringLit -> Q Dec
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
            (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body) -> Q Exp -> Q Body
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
            |]
            Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
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 = Int -> Int
forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize
            -- input tokens + special tokens (-1)
            do Int
maxTokBound Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
minTokBound Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        tokMax :: Int
tokMax = (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
tokBitSize) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        stateBitSize :: Int
stateBitSize = Int -> Int
forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize do T StateNum MState -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length T StateNum MState
states Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        stateByteSize :: Int
stateByteSize = if
            | Int
stateBitSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8  -> Int
1
            | Int
stateBitSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
16 -> Int
2
            | Bool
otherwise          -> Int
4
        stateTableLookupFn :: Q Exp
stateTableLookupFn = if
            | Int
stateBitSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8  -> [e|pteraTHLookupTable8|]
            | Int
stateBitSize Int -> Int -> Bool
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        opsNumBitSize :: Int
opsNumBitSize = Int -> Int
forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize Int
opsNumMax
        opsNumByteSize :: Int
opsNumByteSize = if
            | Int
opsNumBitSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8  -> Int
1
            | Int
opsNumBitSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
16 -> Int
2
            | Bool
otherwise           -> Int
4
        opsNumTableLookupFn :: Q Exp
opsNumTableLookupFn = if
            | Int
opsNumBitSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8  -> [e|pteraTHLookupTable8|]
            | Int
opsNumBitSize Int -> Int -> Bool
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 = (OutTransRepr -> MState -> OutTransRepr)
-> OutTransRepr -> [MState] -> OutTransRepr
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
        (OutTransRepr -> Int -> OutTransRepr)
-> OutTransRepr -> [Int] -> OutTransRepr
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 Int -> T Trans -> Maybe Trans
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 OutTransOpsRepr -> HashMap OutTransOpsRepr Int -> Maybe Int
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
                                , OutTransOpsRepr
-> Int
-> HashMap OutTransOpsRepr Int
-> HashMap OutTransOpsRepr Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                                , OutTransOpsRepr -> Q Exp
toTransOpsExp OutTransOpsRepr
opsReprQ Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
:[Q Exp]
transOps0
                                )
                OutTransRepr :: [Int]
-> [Int]
-> [Q Exp]
-> Int
-> HashMap OutTransOpsRepr Int
-> OutTransRepr
OutTransRepr
                    { $sel:outTransReprStates:OutTransRepr :: [Int]
outTransReprStates = Int
toSnInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:OutTransRepr -> [Int]
outTransReprStates OutTransRepr
acc1
                    , $sel:outTransReprOpsNums:OutTransRepr :: [Int]
outTransReprOpsNums = Int
opsNumInt -> [Int] -> [Int]
forall 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 :: [Int]
-> [Int]
-> [Q Exp]
-> Int
-> HashMap OutTransOpsRepr Int
-> OutTransRepr
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 = HashMap OutTransOpsRepr Int
forall k v. HashMap k v
HashMap.empty
        }
    do T StateNum MState -> [MState]
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 = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    do Lit -> Exp
TH.LitE
        do [Word8] -> Lit
TH.StringPrimL
            do (Int -> [Word8]) -> [Int] -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                do \Int
sn -> Int -> Int -> [Word8]
addrCodeUnitsLE Int
unitSize
                    do Int -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0    = Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take Int
unitSize
        do (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map
            do \Int
m -> Integer -> Word8
forall a. Num a => Integer -> a
fromInteger do Int -> Integer
forall a. Integral a => a -> Integer
toInteger do Int -> Int
mod8bit Int
m
            do (Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bits.shiftR` Int
8) Int
n
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
-1   = Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
unitSize Word8
0xFF
    | Bool
otherwise = StringLit -> [Word8]
forall a. HasCallStack => StringLit -> a
error StringLit
"unsupported"
    where
        mod8bit :: Int -> Int
mod8bit = case Int -> Maybe Int
forall a. Bits a => a -> Maybe Int
Bits.bitSizeMaybe Int
n of
            Maybe Int
Nothing -> \Int
x -> Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
Bits..&. Int
0xFF
            Just Int
bs
                | Int
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8   -> \Int
x -> Int
x
                | Bool
otherwise -> \Int
x -> Int
x Int -> Int -> Int
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 ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TransOp -> Q Exp) -> [TransOp] -> Q [Exp]
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
(OutTransOpsRepr -> OutTransOpsRepr -> Bool)
-> (OutTransOpsRepr -> OutTransOpsRepr -> Bool)
-> Eq OutTransOpsRepr
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
(Int -> OutTransOpsRepr -> ShowS)
-> (OutTransOpsRepr -> StringLit)
-> ([OutTransOpsRepr] -> ShowS)
-> Show OutTransOpsRepr
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. OutTransOpsRepr -> Rep OutTransOpsRepr x)
-> (forall x. Rep OutTransOpsRepr x -> OutTransOpsRepr)
-> Generic OutTransOpsRepr
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 :: 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
    (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body) -> Q Exp -> Q Body
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)
                $(TH.ListE <$> traverse altKindExp do toList alts)
        in \i -> pteraTHArrayIndex arr i
    |]
    Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    where
        altKindExp :: Alt altDoc a -> Q Exp
altKindExp Alt altDoc a
alt = case Alt altDoc a -> AltKind
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
    (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body) -> Q Exp -> Q Body
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 states - 1)
                $(TH.ListE <$> traverse stateHelpExp do toList states)
        in \i -> pteraTHArrayIndex arr i
    |]
    Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    where
        stateHelpExp :: MState -> Q Exp
stateHelpExp MState
st =
            let altItems :: [AltItem]
altItems = MState -> [AltItem]
SRB.stateAltItems MState
st
            in [Exp] -> Exp
TH.ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AltItem] -> (AltItem -> Q Exp) -> Q [Exp]
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 = AltNum -> Int
coerce do AltItem -> AltNum
SRB.altItemAltNum AltItem
altItem
                    Int
pos :: Int = Position -> Int
coerce do AltItem -> Position
SRB.altItemCurPos AltItem
altItem
                [e|($(TH.lift altNum), $(TH.lift pos))|]

outputParserAltHelpFn
    :: TH.Name
    -> AlignableArray.T LAPEG.AltNum (LAPEG.Alt altDoc a)
    -> AlignableArray.T LAPEG.VarNum (PEG.Var StringLit)
    -> TH.Q TH.Dec
outputParserAltHelpFn :: 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
    (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body) -> Q Exp -> Q Body
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)
                $(TH.ListE <$> traverse altHelpExp do toList alts)
        in \i -> pteraTHArrayIndex arr i
    |]
    Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    where
        altHelpExp :: Alt altDoc a -> Q Exp
altHelpExp Alt altDoc a
alt =
            let v :: Var StringLit
v = T VarNum (Var StringLit) -> VarNum -> Var StringLit
forall n a. T n => Array n a -> n -> a
AlignableArray.forceIndex T VarNum (Var StringLit)
vars do Alt altDoc a -> VarNum
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 :: 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
    (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body) -> Q Exp -> Q Body
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
    |]
    Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((AltNum, Alt altHelp (SemanticAction ctx)) -> Q Dec)
-> [(AltNum, Alt altHelp (SemanticAction ctx))] -> Q [Dec]
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
            (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do Exp -> Body
TH.NormalB (Exp -> Body) -> Q Exp -> Q Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Alt altHelp (SemanticAction ctx) -> Q Exp
forall altDoc ctx. Alt altDoc (Action (SemActM ctx)) -> Q Exp
altActionExp Alt altHelp (SemanticAction ctx)
alt
            Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        do T AltNum (Alt altHelp (SemanticAction ctx))
-> [(AltNum, Alt altHelp (SemanticAction ctx))]
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" StringLit -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> StringLit
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 Alt altDoc (Action (SemActM ctx)) -> Action (SemActM ctx)
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
        (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body) -> Q Exp -> Q Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Body
TH.NormalB [e|pteraTHUnsafeRunner parser|]
        Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
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)
        |]