{-# 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.EnumMap.Strict               as EnumMap
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.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
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
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]
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, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => TlexTransStateSize -> m Exp
forall (m :: * -> *).
Quote m =>
TlexTransStateSize -> Code m TlexTransStateSize
liftTyped :: forall (m :: * -> *).
Quote m =>
TlexTransStateSize -> Code m TlexTransStateSize
$cliftTyped :: forall (m :: * -> *).
Quote m =>
TlexTransStateSize -> Code m TlexTransStateSize
lift :: forall (m :: * -> *). Quote m => TlexTransStateSize -> m Exp
$clift :: forall (m :: * -> *). Quote m => TlexTransStateSize -> m 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 forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
offset forall a. Num a => a -> a -> a
+ Int
c
    in forall a. (forall s. ST s a) -> a
ST.runST
        do forall s a. STRep s a -> ST s a
ST.ST \State# s
s0# -> case TlexTransStateSize
unitSize of
            TlexTransStateSize
TlexTransStateSize8  -> case forall d. Addr# -> Int# -> State# d -> (# State# d, Word8# #)
Prim.readWord8OffAddr# Addr#
table# Int#
i# State# s
s0# of
                (# State# s
s1#, Word8#
r# #) -> case Word# -> Int#
Prim.word2Int# do Word8# -> Word#
Prim.word8ToWord# Word8#
r# of
                    Int#
255# -> (# State# s
s1#, Int
-1 #)
                    Int#
ri#  -> (# State# s
s1#, Int# -> Int
Types.I# Int#
ri# #)
            TlexTransStateSize
TlexTransStateSize16 -> case forall d. Addr# -> Int# -> State# d -> (# State# d, Word16# #)
Prim.readWord16OffAddr# Addr#
table# Int#
i# State# s
s0# of
                (# State# s
s1#, Word16#
r# #) -> case Word# -> Int#
Prim.word2Int# do Word16# -> Word#
Prim.word16ToWord# Word16#
r# of
                    Int#
65535# -> (# State# s
s1#, Int
-1 #)
                    Int#
ri#    -> (# State# s
s1#, Int# -> Int
Types.I# Int#
ri# #)
            TlexTransStateSize
TlexTransStateSize32 -> case forall d. Addr# -> Int# -> State# d -> (# State# d, Int32# #)
Prim.readInt32OffAddr# Addr#
table# Int#
i# State# s
s0# of
                (# State# s
s1#, Int32#
r# #) -> (# State# s
s1#, Int# -> Int
Types.I# do Int32# -> Int#
Prim.int32ToInt# Int32#
r# #)

type TlexArray = Array.Array Int

{-# INLINE tlexArray #-}
tlexArray :: Int -> [a] -> TlexArray a
tlexArray :: forall a. Int -> [a] -> TlexArray a
tlexArray Int
l [a]
xs = 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 :: forall a. TlexArray a -> Int -> a
tlexArrayIndex TlexArray a
arr Int
i = TlexArray a
arr 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
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
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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Type
TH.ConT Name
startStateTyName
        codeUnitTy :: Q Type
codeUnitTy = forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Type
TH.ConT Name
codeUnitTyName
        semanticActionTy :: Q Type
semanticActionTy = forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Type
TH.ConT Name
semanticActionTyName
        thTlexInitialFn :: Q Exp
thTlexInitialFn = forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Exp
TH.VarE Name
thTlexInitialFnName
        thTlexTransFn :: Q Exp
thTlexTransFn = forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Exp
TH.VarE Name
thTlexTransFnName
        thTlexAcceptFn :: Q Exp
thTlexAcceptFn = forall (f :: * -> *) a. Applicative f => a -> f a
pure @TH.Q do Name -> Exp
TH.VarE Name
thTlexAcceptFnName

    forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> [TyVarBndr ()] -> Type -> Dec
TH.TySynD Name
startStateTyName [] do OutputContext -> Type
outputCtxStartStateTy OutputContext
ctx
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> [TyVarBndr ()] -> Type -> Dec
TH.TySynD Name
codeUnitTyName [] do OutputContext -> Type
outputCtxCodeUnitTy OutputContext
ctx
        , 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 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
            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
<$> [e|\s0 -> runRunner runner s0|]
            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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> Int|]
        , forall a. DFA a -> Name -> Q Dec
outputTlexInitialFn DFA (Q Exp)
dfa Name
thTlexInitialFnName

        , Name -> Type -> Dec
TH.SigD Name
thTlexTransFnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [t|Int -> Int -> Int|]
        , 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 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 :: forall a. 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 <- forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"table"
    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
<$> do Exp -> Body
TH.NormalB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                [e|\x -> tlexArrayIndex $(pure do TH.VarE tableValName) x|]
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                [ Name -> Type -> Dec
TH.SigD Name
tableValName 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
            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
<$> do
                    ([Exp]
es, Int
l) <- Q ([Exp], Int)
tableList
                    Int -> [Exp] -> Q Exp
outputTlexArrayLit Int
l [Exp]
es
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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) = forall a. a -> [(Int, a)] -> ([a], Int)
sequentialListFromAscList
                    [e|-1|]
                    [ (forall a. Enum a => a -> Int
fromEnum StartState
ss, forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
TH.lift do forall a. Enum a => a -> Int
fromEnum StateNum
sn)
                    | (StartState
ss, StateNum
sn) <- forall k a. Enum k => EnumMap k a -> [(k, a)]
EnumMap.toAscList EnumMap StartState StateNum
dfaInitials
                    ]
            in do
                [Exp]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Exp]
es
                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 :: forall a. 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 = forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize do Int
maxUnitB forall a. Num a => a -> a -> a
- Int
minUnitB
        um :: Int
um = do Int
1 forall a. Bits a => a -> Int -> a
`Bits.shiftL` Int
ubs
            forall a. Num a => a -> a -> a
- Int
1
        l :: [Int]
l = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            do \DFAState a
dstState ->
                let smDef :: Int
smDef = case forall a. DFAState a -> Maybe StateNum
DFA.dstOtherTrans DFAState a
dstState of
                        Maybe StateNum
Nothing -> Int
-1
                        Just StateNum
sm -> forall a. Enum a => a -> Int
fromEnum StateNum
sm
                    dstTrans :: IntMap StateNum
dstTrans = forall a. DFAState a -> IntMap StateNum
DFA.dstTrans DFAState a
dstState
                in forall a b. (a -> b) -> [a] -> [b]
map
                    do \Int
i -> case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i IntMap StateNum
dstTrans of
                        Just StateNum
sm -> forall a. Enum a => a -> Int
fromEnum StateNum
sm
                        Maybe StateNum
Nothing -> Int
smDef
                    [Int
0..Int
um]
            do 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 = forall a. (FiniteBits a, Ord a, Num a) => a -> Int
Bits.maxBitSize do (forall (t :: * -> *) a. Foldable t => t a -> Int
length StateArray (DFAState a)
dfaTrans forall a. Num a => a -> a -> a
- Int
1) forall a. Num a => a -> a -> a
+ Int
1
        sbsEnum :: TlexTransStateSize
sbsEnum = if
            | Int
ubs forall a. Num a => a -> a -> a
+ Int
sbs forall a. Ord a => a -> a -> Bool
> Int
29 -> forall a. HasCallStack => String -> a
error String
"exceed over bit size limited"
            | Bool
otherwise      -> 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
        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
<$>
                [e|\s c -> tlexLookupTlexTransTable
                    $(unitBitSizeExp ubs)
                    $(TH.lift sbsEnum)
                    $(tableAddrExp sbsEnum l)
                    s (c - $(TH.lift minUnitB))
                |]
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    where
        unitBitSizeExp :: a -> f Exp
unitBitSizeExp a
ubs = forall (f :: * -> *) a. Applicative f => a -> f a
pure
            do Lit -> Exp
TH.LitE do Integer -> Lit
TH.IntegerL do forall a b. (Integral a, Num b) => a -> b
fromIntegral a
ubs

        stateSize :: a -> TlexTransStateSize
stateSize a
sbs
            | a
sbs forall a. Ord a => a -> a -> Bool
<= a
8  = TlexTransStateSize
TlexTransStateSize8
            | a
sbs 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 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 \a
sn -> forall a. (Bits a, Integral a) => Int -> a -> [Word8]
addrCodeUnitsLE Int
us
                                do 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 :: forall a. (Bits a, Integral a) => Int -> a -> [Word8]
addrCodeUnitsLE Int
us a
n
    | a
n forall a. Ord a => a -> a -> Bool
>= a
0    = forall a. Int -> [a] -> [a]
take Int
us
        do forall a b. (a -> b) -> [a] -> [b]
map
            do \a
m -> forall a. Num a => Integer -> a
fromInteger do forall a. Integral a => a -> Integer
toInteger do a -> a
mod8bit a
m
            do forall a. (a -> a) -> a -> [a]
iterate (forall a. Bits a => a -> Int -> a
`Bits.shiftR` Int
8) a
n
    | a
n forall a. Eq a => a -> a -> Bool
== a
-1   = forall a. Int -> a -> [a]
replicate Int
us Word8
0xFF
    | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"unsupported"
    where
        mod8bit :: a -> a
mod8bit a
x = case forall a. Bits a => a -> Maybe Int
Bits.bitSizeMaybe a
n of
            Maybe Int
Nothing -> a
x forall a. Bits a => a -> a -> a
Bits..&. a
0xFF
            Just Int
bs
                | Int
bs forall a. Ord a => a -> a -> Bool
<= Int
8   -> a
x
                | Bool
otherwise -> a
x 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 <- forall (m :: * -> *). Quote m => String -> m 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
        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
<$>
                [e|
                    \x -> if x >= $(TH.lift l)
                        then Nothing
                        else tlexArrayIndex $(pure do TH.VarE tableValName) x
                |]
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                [ Name -> Type -> Dec
TH.SigD Name
tableValName 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
            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
<$> Int -> [Exp] -> Q Exp
outputTlexArrayLit Int
l [Exp]
es
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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) = forall a. a -> [(Int, a)] -> ([a], Int)
sequentialListFromAscList
                    [e|Nothing|]
                    do
                        (StateNum
sn, DFAState (Q Exp)
dstSt) <- forall a. StateArray a -> [(StateNum, a)]
MState.arrayAssocs StateArray (DFAState (Q Exp))
dfaTrans
                        let accExp :: Q Exp
accExp = case 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)|]
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Enum a => a -> Int
fromEnum StateNum
sn, Q Exp
accExp)
            in do
                [Exp]
es' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Exp]
es
                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 :: forall a. a -> [(Int, a)] -> ([a], Int)
sequentialListFromAscList a
v [(Int, a)]
xs =
    let ([a] -> [a]
l0, Int
m) = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xforall a. a -> [a] -> [a]
:), forall a. Enum a => a -> a
succ Int
i)
            do (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 forall a. Eq a => a -> a -> Bool
== Int
i   = [a] -> [a]
l
            | Bool
otherwise = Int -> Int -> ([a] -> [a]) -> [a] -> [a]
fillV Int
i
                do forall a. Enum a => a -> a
succ Int
pi
                do [a] -> [a]
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
vforall a. a -> [a] -> [a]
:)