{-# LANGUAGE MagicHash       #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.Lexer.Tlex.Output.TH (
    TlexContext (..),
    TlexResult (..),
    Runner (..),
    runRunner,
    TlexTransStateSize (..),
    tlexLookupTlexTransTable,
    TlexArray,
    tlexArray,
    tlexArrayIndex,
    OutputContext (..),
    outputDfa,

    -- for tests
    addrCodeUnitsLE,
) where

import           Language.Lexer.Tlex.Prelude

import qualified Data.Array                        as Array
import qualified Data.Bits                         as Bits
import qualified Data.IntMap.Strict                as IntMap
import qualified GHC.Prim                          as Prim
import qualified GHC.ST                            as ST
import qualified GHC.Types                         as Types
import qualified Language.Haskell.TH               as TH
import qualified Language.Haskell.TH.Syntax        as TH
import qualified Language.Lexer.Tlex.Data.Bits     as Bits
import qualified Language.Lexer.Tlex.Data.EnumMap  as EnumMap
import qualified Language.Lexer.Tlex.Machine.DFA   as DFA
import qualified Language.Lexer.Tlex.Machine.State as MState
import           Language.Lexer.Tlex.Runner
import qualified Language.Lexer.Tlex.Syntax        as Tlex


data TlexTransStateSize
    = TlexTransStateSize8
    | TlexTransStateSize16
    | TlexTransStateSize32
    deriving (TlexTransStateSize -> TlexTransStateSize -> Bool
(TlexTransStateSize -> TlexTransStateSize -> Bool)
-> (TlexTransStateSize -> TlexTransStateSize -> Bool)
-> Eq TlexTransStateSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TlexTransStateSize -> TlexTransStateSize -> Bool
$c/= :: TlexTransStateSize -> TlexTransStateSize -> Bool
== :: TlexTransStateSize -> TlexTransStateSize -> Bool
$c== :: TlexTransStateSize -> TlexTransStateSize -> Bool
Eq, Int -> TlexTransStateSize -> ShowS
[TlexTransStateSize] -> ShowS
TlexTransStateSize -> String
(Int -> TlexTransStateSize -> ShowS)
-> (TlexTransStateSize -> String)
-> ([TlexTransStateSize] -> ShowS)
-> Show TlexTransStateSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TlexTransStateSize] -> ShowS
$cshowList :: [TlexTransStateSize] -> ShowS
show :: TlexTransStateSize -> String
$cshow :: TlexTransStateSize -> String
showsPrec :: Int -> TlexTransStateSize -> ShowS
$cshowsPrec :: Int -> TlexTransStateSize -> ShowS
Show, Int -> TlexTransStateSize
TlexTransStateSize -> Int
TlexTransStateSize -> [TlexTransStateSize]
TlexTransStateSize -> TlexTransStateSize
TlexTransStateSize -> TlexTransStateSize -> [TlexTransStateSize]
TlexTransStateSize
-> TlexTransStateSize -> TlexTransStateSize -> [TlexTransStateSize]
(TlexTransStateSize -> TlexTransStateSize)
-> (TlexTransStateSize -> TlexTransStateSize)
-> (Int -> TlexTransStateSize)
-> (TlexTransStateSize -> Int)
-> (TlexTransStateSize -> [TlexTransStateSize])
-> (TlexTransStateSize
    -> TlexTransStateSize -> [TlexTransStateSize])
-> (TlexTransStateSize
    -> TlexTransStateSize -> [TlexTransStateSize])
-> (TlexTransStateSize
    -> TlexTransStateSize
    -> TlexTransStateSize
    -> [TlexTransStateSize])
-> Enum TlexTransStateSize
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TlexTransStateSize
-> TlexTransStateSize -> TlexTransStateSize -> [TlexTransStateSize]
$cenumFromThenTo :: TlexTransStateSize
-> TlexTransStateSize -> TlexTransStateSize -> [TlexTransStateSize]
enumFromTo :: TlexTransStateSize -> TlexTransStateSize -> [TlexTransStateSize]
$cenumFromTo :: TlexTransStateSize -> TlexTransStateSize -> [TlexTransStateSize]
enumFromThen :: TlexTransStateSize -> TlexTransStateSize -> [TlexTransStateSize]
$cenumFromThen :: TlexTransStateSize -> TlexTransStateSize -> [TlexTransStateSize]
enumFrom :: TlexTransStateSize -> [TlexTransStateSize]
$cenumFrom :: TlexTransStateSize -> [TlexTransStateSize]
fromEnum :: TlexTransStateSize -> Int
$cfromEnum :: TlexTransStateSize -> Int
toEnum :: Int -> TlexTransStateSize
$ctoEnum :: Int -> TlexTransStateSize
pred :: TlexTransStateSize -> TlexTransStateSize
$cpred :: TlexTransStateSize -> TlexTransStateSize
succ :: TlexTransStateSize -> TlexTransStateSize
$csucc :: TlexTransStateSize -> TlexTransStateSize
Enum, TlexTransStateSize -> Q Exp
TlexTransStateSize -> Q (TExp TlexTransStateSize)
(TlexTransStateSize -> Q Exp)
-> (TlexTransStateSize -> Q (TExp TlexTransStateSize))
-> Lift TlexTransStateSize
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: TlexTransStateSize -> Q (TExp TlexTransStateSize)
$cliftTyped :: TlexTransStateSize -> Q (TExp TlexTransStateSize)
lift :: TlexTransStateSize -> Q Exp
$clift :: TlexTransStateSize -> Q Exp
TH.Lift)

{-# INLINE tlexLookupTlexTransTable #-}
tlexLookupTlexTransTable :: Int -> TlexTransStateSize -> Prim.Addr#
    -> Int -> Int -> Int
tlexLookupTlexTransTable :: Int -> TlexTransStateSize -> Addr# -> Int -> Int -> Int
tlexLookupTlexTransTable Int
offset TlexTransStateSize
unitSize Addr#
table# Int
s Int
c =
    let !(Types.I# Int#
i#) = Int
s Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c
    in (forall s. ST s Int) -> Int
forall a. (forall s. ST s a) -> a
ST.runST
        do STRep s Int -> ST s Int
forall s a. STRep s a -> ST s a
ST.ST \State# s
s0# -> case TlexTransStateSize
unitSize of
            TlexTransStateSize
TlexTransStateSize8  -> case Addr# -> Int# -> State# s -> (# State# s, Word# #)
forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #)
Prim.readWord8OffAddr# Addr#
table# Int#
i# State# s
s0# of
                (# State# s
s1#, Word#
r# #) -> case Word#
r# of
                    Word#
255##   -> (# State# s
s1#, Int
-1 #)
                    Word#
_       -> (# State# s
s1#, Int# -> Int
Types.I# do Word# -> Int#
Prim.word2Int# Word#
r# #)
            TlexTransStateSize
TlexTransStateSize16 -> case Addr# -> Int# -> State# s -> (# State# s, Word# #)
forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #)
Prim.readWord16OffAddr# Addr#
table# Int#
i# State# s
s0# of
                (# State# s
s1#, Word#
r# #) -> case Word#
r# of
                    Word#
65535## -> (# State# s
s1#, Int
-1 #)
                    Word#
_       -> (# State# s
s1#, Int# -> Int
Types.I# do Word# -> Int#
Prim.word2Int# Word#
r# #)
            TlexTransStateSize
TlexTransStateSize32 -> case Addr# -> Int# -> State# s -> (# State# s, Int# #)
forall d. Addr# -> Int# -> State# d -> (# State# d, Int# #)
Prim.readInt32OffAddr# Addr#
table# Int#
i# State# s
s0# of
                (# State# s
s1#, Int#
r# #) -> (# State# s
s1#, Int# -> Int
Types.I# Int#
r# #)

type TlexArray = Array.Array Int

{-# INLINE tlexArray #-}
tlexArray :: Int -> [a] -> TlexArray a
tlexArray :: Int -> [a] -> TlexArray a
tlexArray Int
l [a]
xs = (Int, Int) -> [a] -> TlexArray a
forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (Int
0,Int
l) [a]
xs

{-# INLINE tlexArrayIndex #-}
tlexArrayIndex :: TlexArray a -> Int -> a
tlexArrayIndex :: TlexArray a -> Int -> a
tlexArrayIndex TlexArray a
arr Int
i = TlexArray a
arr TlexArray a -> Int -> a
forall i e. Ix i => Array i e -> i -> e
Array.! Int
i

{-
type TlexStartState = ...
type TlexSemanticAction = ...
type TlexCodeUnit = ...

tlexScan :: TlexContext s TlexCodeUnit m => TlexStartState -> m (TlexResult s TlexSemanticAction)
tlexScan s0 = runRunner runner s0
    where
        runner = Runner
            { tlexInitial = thTlexInitial
            , tlexAccept = thTlexAccept
            , tlexTrans = thTlexTrans
            }

thTlexInitial :: Int -> Int
thTlexInitial = \x -> tlexArrayIndex tlexInitialTable x
    where
        table :: TlexArray Int
        table = tlexArray 10 [10,...]

thTlexTrans :: Int -> Int -> Int
thTlexTrans = \s c -> tlexLookupTlexTransTable
    8
    TlexTransTableStateSize8
    "\x02\x00\x00\x00..."#
    s (c - 0)

thTlexAccept :: Int -> Maybe TlexSemanticAction
thTlexAccept = \x -> if x >= 120
        then Nothing
        else tlexArrayIndex table x
    where
        table :: TlexArray (Maybe TlexSemanticAction)
        table = tlexArray 120 [Nothing,...]
-}
data OutputContext = OutputContext
    { OutputContext -> Type
outputCtxStartStateTy     :: TH.Type
    , OutputContext -> Type
outputCtxCodeUnitTy       :: TH.Type
    , OutputContext -> (Int, Int)
outputCtxCodeUnitBounds   :: (Int, Int)
    , OutputContext -> Type
outputCtxSemanticActionTy :: TH.Type
    }
    deriving (OutputContext -> OutputContext -> Bool
(OutputContext -> OutputContext -> Bool)
-> (OutputContext -> OutputContext -> Bool) -> Eq OutputContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputContext -> OutputContext -> Bool
$c/= :: OutputContext -> OutputContext -> Bool
== :: OutputContext -> OutputContext -> Bool
$c== :: OutputContext -> OutputContext -> Bool
Eq, Int -> OutputContext -> ShowS
[OutputContext] -> ShowS
OutputContext -> String
(Int -> OutputContext -> ShowS)
-> (OutputContext -> String)
-> ([OutputContext] -> ShowS)
-> Show OutputContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutputContext] -> ShowS
$cshowList :: [OutputContext] -> ShowS
show :: OutputContext -> String
$cshow :: OutputContext -> String
showsPrec :: Int -> OutputContext -> ShowS
$cshowsPrec :: Int -> OutputContext -> ShowS
Show)

outputDfa :: OutputContext -> DFA.DFA (TH.Q TH.Exp) -> TH.Q [TH.Dec]
outputDfa :: OutputContext -> DFA (Q Exp) -> Q [Dec]
outputDfa OutputContext
ctx DFA (Q Exp)
dfa = do
    let startStateTyName :: Name
startStateTyName = String -> Name
TH.mkName String
"TlexStartState"
        codeUnitTyName :: Name
codeUnitTyName = String -> Name
TH.mkName String
"TlexCodeUnit"
        semanticActionTyName :: Name
semanticActionTyName = String -> Name
TH.mkName String
"TlexSemanticAction"
        tlexScanFnName :: Name
tlexScanFnName = String -> Name
TH.mkName String
"tlexScan"
        thTlexInitialFnName :: Name
thTlexInitialFnName = String -> Name
TH.mkName String
"thTlexInitial"
        thTlexTransFnName :: Name
thTlexTransFnName = String -> Name
TH.mkName String
"thTlexTrans"
        thTlexAcceptFnName :: Name
thTlexAcceptFnName = String -> Name
TH.mkName String
"thTlexAccept"

    let startStateTy :: Q Type
startStateTy = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Type
TH.ConT Name
startStateTyName
        codeUnitTy :: Q Type
codeUnitTy = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Type
TH.ConT Name
codeUnitTyName
        semanticActionTy :: Q Type
semanticActionTy = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Type
TH.ConT Name
semanticActionTyName
        thTlexInitialFn :: Q Exp
thTlexInitialFn = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Exp
TH.VarE Name
thTlexInitialFnName
        thTlexTransFn :: Q Exp
thTlexTransFn = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Exp
TH.VarE Name
thTlexTransFnName
        thTlexAcceptFn :: Q Exp
thTlexAcceptFn = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Exp
TH.VarE Name
thTlexAcceptFnName

    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> [TyVarBndr] -> Type -> Dec
TH.TySynD Name
startStateTyName [] do OutputContext -> Type
outputCtxStartStateTy OutputContext
ctx
        , Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> [TyVarBndr] -> Type -> Dec
TH.TySynD Name
codeUnitTyName [] do OutputContext -> Type
outputCtxCodeUnitTy OutputContext
ctx
        , Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> [TyVarBndr] -> Type -> Dec
TH.TySynD Name
semanticActionTyName [] do OutputContext -> Type
outputCtxSemanticActionTy OutputContext
ctx

        , Name -> Type -> Dec
TH.SigD Name
tlexScanFnName (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|
            forall s m. TlexContext s $(codeUnitTy) m
                => $(startStateTy) -> m (TlexResult s $(semanticActionTy))
        |]
        , Pat -> Body -> [Dec] -> Dec
TH.ValD
            do Name -> Pat
TH.VarP Name
tlexScanFnName
            (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
<$> [e|\s0 -> runRunner runner s0|]
            Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
                runner = Runner
                    $(thTlexInitialFn)
                    $(thTlexAcceptFn)
                    $(thTlexTransFn)
            |]

        , Name -> Type -> Dec
TH.SigD Name
thTlexInitialFnName (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> Int|]
        , DFA (Q Exp) -> Name -> Q Dec
forall a. DFA a -> Name -> Q Dec
outputTlexInitialFn DFA (Q Exp)
dfa Name
thTlexInitialFnName

        , Name -> Type -> Dec
TH.SigD Name
thTlexTransFnName (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> Int -> Int|]
        , DFA (Q Exp) -> (Int, Int) -> Name -> Q Dec
forall a. DFA a -> (Int, Int) -> Name -> Q Dec
outputTlexTransFn DFA (Q Exp)
dfa
            do OutputContext -> (Int, Int)
outputCtxCodeUnitBounds OutputContext
ctx
            Name
thTlexTransFnName

        , Name -> Type -> Dec
TH.SigD Name
thTlexAcceptFnName (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> Maybe $(semanticActionTy)|]
        , DFA (Q Exp) -> Q Type -> Name -> Q Dec
outputTlexAcceptFn DFA (Q Exp)
dfa Q Type
semanticActionTy Name
thTlexAcceptFnName
        ]

outputTlexInitialFn :: DFA.DFA a -> TH.Name -> TH.Q TH.Dec
outputTlexInitialFn :: DFA a -> Name -> Q Dec
outputTlexInitialFn DFA.DFA{ EnumMap StartState StateNum
$sel:dfaInitials:DFA :: forall a. DFA a -> EnumMap StartState StateNum
dfaInitials :: EnumMap StartState StateNum
dfaInitials } Name
fnName = do
    Name
tableValName <- String -> Q Name
TH.newName String
"table"
    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
<$> do Exp -> Body
TH.NormalB (Exp -> Body) -> Q Exp -> Q Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                [e|\x -> tlexArrayIndex $(pure do TH.VarE tableValName) x|]
        Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [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
tableValName (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    [t|TlexArray Int|]
                , Name -> Q Dec
tableDec Name
tableValName
                ]
    where
        tableDec :: TH.Name -> TH.Q TH.Dec
        tableDec :: Name -> Q Dec
tableDec Name
valName = Pat -> Body -> [Dec] -> Dec
TH.ValD
            do Name -> Pat
TH.VarP Name
valName
            (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
<$> do
                    ([Exp]
es, Int
l) <- Q ([Exp], Int)
tableList
                    Int -> [Exp] -> Q Exp
outputTlexArrayLit Int
l [Exp]
es
            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 []

        tableList :: TH.Q ([TH.Exp], Int)
        tableList :: Q ([Exp], Int)
tableList =
            let ([Q Exp]
es, Int
l) = Q Exp -> [(Int, Q Exp)] -> ([Q Exp], Int)
forall a. a -> [(Int, a)] -> ([a], Int)
sequentialListFromAscList
                    [e|-1|]
                    [ (StartState -> Int
forall a. Enum a => a -> Int
fromEnum StartState
ss, Int -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift do StateNum -> Int
forall a. Enum a => a -> Int
fromEnum StateNum
sn)
                    | (StartState
ss, StateNum
sn) <- EnumMap StartState StateNum -> [(StartState, StateNum)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EnumMap.toAscList EnumMap StartState StateNum
dfaInitials
                    ]
            in do
                [Exp]
es' <- [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Exp]
es
                ([Exp], Int) -> Q ([Exp], Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Exp]
es', Int
l)

outputTlexTransFn :: DFA.DFA a -> (Int, Int) -> TH.Name -> TH.Q TH.Dec
outputTlexTransFn :: DFA a -> (Int, Int) -> Name -> Q Dec
outputTlexTransFn DFA.DFA{ StateArray (DFAState a)
$sel:dfaTrans:DFA :: forall a. DFA a -> StateArray (DFAState a)
dfaTrans :: StateArray (DFAState a)
dfaTrans } (Int
minUnitB, Int
maxUnitB) Name
fnName =
    let ubs :: Int
ubs = Int -> Int
forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize do Int
maxUnitB Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
minUnitB
        um :: Int
um = do Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
ubs
            Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        l :: [Int]
l = (DFAState a -> [Int]) -> [DFAState a] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            do \DFAState a
dstState ->
                let smDef :: Int
smDef = case DFAState a -> Maybe StateNum
forall a. DFAState a -> Maybe StateNum
DFA.dstOtherTrans DFAState a
dstState of
                        Maybe StateNum
Nothing -> Int
-1
                        Just StateNum
sm -> StateNum -> Int
forall a. Enum a => a -> Int
fromEnum StateNum
sm
                    dstTrans :: IntMap StateNum
dstTrans = DFAState a -> IntMap StateNum
forall a. DFAState a -> IntMap StateNum
DFA.dstTrans DFAState a
dstState
                in (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map
                    do \Int
i -> case Int -> IntMap StateNum -> Maybe StateNum
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i IntMap StateNum
dstTrans of
                        Just StateNum
sm -> StateNum -> Int
forall a. Enum a => a -> Int
fromEnum StateNum
sm
                        Maybe StateNum
Nothing -> Int
smDef
                    [Int
0..Int
um]
            do StateArray (DFAState a) -> [DFAState a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StateArray (DFAState a)
dfaTrans
        -- count of states + count of specials (i.e. -1)
        sbs :: Int
sbs = Int -> Int
forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize do (StateArray (DFAState a) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StateArray (DFAState a)
dfaTrans Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        sbsEnum :: TlexTransStateSize
sbsEnum = if
            | Int
ubs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sbs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
29 -> String -> TlexTransStateSize
forall a. HasCallStack => String -> a
error String
"exceed over bit size limited"
            | Bool
otherwise      -> Int -> TlexTransStateSize
forall a. (Ord a, Num a) => a -> TlexTransStateSize
stateSize Int
sbs
    in 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
<$> do Exp -> Body
TH.NormalB (Exp -> Body) -> Q Exp -> Q Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                [e|\s c -> tlexLookupTlexTransTable
                    $(unitBitSizeExp ubs)
                    $(TH.lift sbsEnum)
                    $(tableAddrExp sbsEnum l)
                    s (c - $(TH.lift minUnitB))
                |]
        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
        unitBitSizeExp :: a -> f Exp
unitBitSizeExp a
ubs = Exp -> f Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            do Lit -> Exp
TH.LitE do Integer -> Lit
TH.IntegerL do a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
ubs

        stateSize :: a -> TlexTransStateSize
stateSize a
sbs
            | a
sbs a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
8  = TlexTransStateSize
TlexTransStateSize8
            | a
sbs a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
16 = TlexTransStateSize
TlexTransStateSize16
            | Bool
otherwise = TlexTransStateSize
TlexTransStateSize32

        tableAddrExp :: TlexTransStateSize -> t a -> f Exp
tableAddrExp TlexTransStateSize
ss t a
l =
            let us :: Int
us = case TlexTransStateSize
ss of
                    TlexTransStateSize
TlexTransStateSize8  -> Int
1
                    TlexTransStateSize
TlexTransStateSize16 -> Int
2
                    TlexTransStateSize
TlexTransStateSize32 -> Int
4
            in Exp -> f Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                do Lit -> Exp
TH.LitE
                    do [Word8] -> Lit
TH.StringPrimL
                        do (a -> [Word8]) -> t a -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                            do \a
sn -> Int -> Int -> [Word8]
forall a. (Bits a, Integral a) => Int -> a -> [Word8]
addrCodeUnitsLE Int
us
                                do a -> Int
forall a. Enum a => a -> Int
fromEnum a
sn
                            do t a
l

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

outputTlexAcceptFn
    :: DFA.DFA (TH.Q TH.Exp) -> (TH.Q TH.Type) -> TH.Name -> TH.Q TH.Dec
outputTlexAcceptFn :: DFA (Q Exp) -> Q Type -> Name -> Q Dec
outputTlexAcceptFn DFA.DFA{ StateArray (DFAState (Q Exp))
dfaTrans :: StateArray (DFAState (Q Exp))
$sel:dfaTrans:DFA :: forall a. DFA a -> StateArray (DFAState a)
dfaTrans } Q Type
semanticActionTy Name
fnName = do
    Name
tableValName <- String -> Q Name
TH.newName String
"table"
    ([Exp]
es, Int
l) <- Q ([Exp], Int)
tableList
    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
<$> do Exp -> Body
TH.NormalB (Exp -> Body) -> Q Exp -> Q Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                [e|
                    \x -> if x >= $(TH.lift l)
                        then Nothing
                        else tlexArrayIndex $(pure do TH.VarE tableValName) x
                |]
        Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [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
tableValName (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    [t|TlexArray (Maybe $(semanticActionTy))|]
                , Name -> [Exp] -> Int -> Q Dec
tableDec Name
tableValName [Exp]
es Int
l
                ]
    where
        tableDec :: Name -> [Exp] -> Int -> Q Dec
tableDec Name
valName [Exp]
es Int
l = Pat -> Body -> [Dec] -> Dec
TH.ValD
            do Name -> Pat
TH.VarP Name
valName
            (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
<$> Int -> [Exp] -> Q Exp
outputTlexArrayLit Int
l [Exp]
es
            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 []

        tableList :: TH.Q ([TH.Exp], Int)
        tableList :: Q ([Exp], Int)
tableList =
            let ([Q Exp]
es, Int
l) = Q Exp -> [(Int, Q Exp)] -> ([Q Exp], Int)
forall a. a -> [(Int, a)] -> ([a], Int)
sequentialListFromAscList
                    [e|Nothing|]
                    do
                        (StateNum
sn, DFAState (Q Exp)
dstSt) <- StateArray (DFAState (Q Exp)) -> [(StateNum, DFAState (Q Exp))]
forall a. StateArray a -> [(StateNum, a)]
MState.arrayAssocs StateArray (DFAState (Q Exp))
dfaTrans
                        let accExp :: Q Exp
accExp = case DFAState (Q Exp) -> [Accept (Q Exp)]
forall a. DFAState a -> [Accept a]
DFA.dstAccepts DFAState (Q Exp)
dstSt of
                                []    -> [e|Nothing|]
                                Accept (Q Exp)
acc:[Accept (Q Exp)]
_ -> [e|Just $(Tlex.accSemanticAction acc)|]
                        (Int, Q Exp) -> [(Int, Q Exp)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateNum -> Int
forall a. Enum a => a -> Int
fromEnum StateNum
sn, Q Exp
accExp)
            in do
                [Exp]
es' <- [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Exp]
es
                ([Exp], Int) -> Q ([Exp], Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Exp]
es', Int
l)

outputTlexArrayLit :: Int -> [TH.Exp] -> TH.Q TH.Exp
outputTlexArrayLit :: Int -> [Exp] -> Q Exp
outputTlexArrayLit Int
l [Exp]
es =
    [e|tlexArray $(TH.lift l) $(pure do TH.ListE es)|]

sequentialListFromAscList :: a -> [(Int, a)] -> ([a], Int)
sequentialListFromAscList :: a -> [(Int, a)] -> ([a], Int)
sequentialListFromAscList a
v [(Int, a)]
xs =
    let ([a] -> [a]
l0, Int
m) = (([a] -> [a], Int) -> (Int, a) -> ([a] -> [a], Int))
-> ([a] -> [a], Int) -> [(Int, a)] -> ([a] -> [a], Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
            do \([a] -> [a]
l, !Int
pi) (Int
i, a
x) -> (Int -> Int -> ([a] -> [a]) -> [a] -> [a]
fillV Int
i Int
pi [a] -> [a]
l ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:), Int -> Int
forall a. Enum a => a -> a
succ Int
i)
            do ([a] -> [a]
forall a. a -> a
id, Int
0)
            do [(Int, a)]
xs
    in ([a] -> [a]
l0 [], Int
m)
    where
        fillV :: Int -> Int -> ([a] -> [a]) -> [a] -> [a]
fillV Int
i !Int
pi [a] -> [a]
l
            | Int
pi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i   = [a] -> [a]
l
            | Bool
otherwise = Int -> Int -> ([a] -> [a]) -> [a] -> [a]
fillV Int
i
                do Int -> Int
forall a. Enum a => a -> a
succ Int
pi
                do [a] -> [a]
l ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:)