-- |
-- Module: M.IO.TH
-- Description: Template Haskell generators for packet parsing states
-- Copyright: (c) axionbuster, 2025
-- License: BSD-3-Clause
--
-- This module provides Template Haskell functionality to generate parser states
-- for client-server packet handling. It uses a simple grammar to define packet
-- mappings and their associated codes.
--
-- == Usage
--
-- Define parser states using the 'states' quasi-quoter:
--
-- @
-- -- creates mystatepair :: 'ParserStates'
-- [states|
--   mystatepair
--   Login:1f:2f     -- Login packet: recv=0x1f, send=0x2f
--   Handshake::3f   -- Handshake packet: send=0x3f only
--   |]
-- @
--
-- See: 'ParserStates', 'forserver', and 'forclient'.
--
-- == Note
--
-- All numerals are hexadecimal.
module M.IO.TH (ParserStates (..), states) where

import Control.Applicative.Combinators (manyTill, skipManyTill)
import Control.Monad
import Control.Monad.Fix
import Data.Char (isLetter, ord)
import Data.Function
import Data.Functor
import Data.HashMap.Strict qualified as H
import Data.IntMap.Strict qualified as I
import Data.Proxy
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Typeable (typeRep)
import Data.Word
import FlatParse.Stateful hiding (Parser, Result)
import Language.Haskell.TH hiding (Code)
import Language.Haskell.TH.Quote
import M.IO.Internal.Datagram
import M.IO.Internal.EffectTypes
import M.Pack

-- | A quasi-quoter for generating parser states.
-- Parses the input grammar and generates appropriate ParserState pairs.
states :: QuasiQuoter
states :: QuasiQuoter
states =
  QuasiQuoter
    { quoteDec :: [Char] -> Q [Dec]
quoteDec = \((forall (st :: ZeroBitType). Parser st () (Name, [S]))
-> ByteString -> Result (Name, [S])
forall a.
(forall (st :: ZeroBitType). Parser st () a)
-> ByteString -> Result a
parsepure0 Parser st () (Name, [S])
forall (st :: ZeroBitType). Parser st () (Name, [S])
forall (st :: ZeroBitType) r. Parser st r (Name, [S])
doc (ByteString -> Result (Name, [S]))
-> ([Char] -> ByteString) -> [Char] -> Result (Name, [S])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> ([Char] -> Text) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack -> Result (Name, [S])
pr) ->
        case Result (Name, [S])
pr of
          OK (Name
n, [S]
m) Int
_ ByteString
_ -> do
            let two :: m (Item b) -> m (Item b) -> m b
two m (Item b)
a m (Item b)
b = do Item b
p <- m (Item b)
a; Item b
q <- m (Item b)
b; b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Item b
p, Item b
q]
            (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure -> Q Type
t, Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure -> Q Exp
b) <- [S] -> Q (Type, Exp)
thparserstates [S]
m
            Q (Item [Dec]) -> Q (Item [Dec]) -> Q [Dec]
forall {m :: * -> *} {b}.
(Monad m, IsList b) =>
m (Item b) -> m (Item b) -> m b
two
              do Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
n Q Type
t
              do Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
b) []
          Err ParseError
e -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error do
            [Char]
"states quasiquoter: unexpected error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ParseError -> [Char]
showparseerror ParseError
e
          Result (Name, [S])
Fail -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error [Char]
"states quasiquoter: unexpected error (no message)",
      quoteExp :: [Char] -> Q Exp
quoteExp = [Char] -> [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error [Char]
"states quasiquoter cannot be used in an expression",
      quotePat :: [Char] -> Q Pat
quotePat = [Char] -> [Char] -> Q Pat
forall a. HasCallStack => [Char] -> a
error [Char]
"states quasiquoter cannot be used in a pattern",
      quoteType :: [Char] -> Q Type
quoteType = [Char] -> [Char] -> Q Type
forall a. HasCallStack => [Char] -> a
error [Char]
"states quasiquoter cannot be used in a type"
    }

-- | Represents a pair of parser states - one for server-side parsing and one for client-side.
-- The states contain mappings between packet types, codes and identifiers.
data ParserStates = ParserStates
  { ParserStates -> ParserState
forserver :: ParserState,
    ParserStates -> ParserState
forclient :: ParserState
  }

-- | Internal representation of a single packet definition line from the grammar.
-- Contains the packet name and optional receive/send codes.
data S = S
  { S -> [Char]
sna :: String, -- packet name
    S -> Maybe Int
recv :: Maybe Int, -- receive code (client in/server out)
    S -> Maybe Int
send :: Maybe Int -- send code (client out/server in)
  }

-- | Helper for integer conversion
fi :: (Integral a, Num b) => a -> b
fi :: forall a b. (Integral a, Num b) => a -> b
fi = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Lookup with runtime error on missing key
forceindex :: I.IntMap a -> Int -> a
forceindex :: forall a. IntMap a -> Int -> a
forceindex = IntMap a -> Int -> a
forall a. IntMap a -> Int -> a
(I.!)

-- | List concatenation helper
concat2 :: [a] -> [a] -> [a]
concat2 :: forall a. [a] -> [a] -> [a]
concat2 = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)

okorerror :: Result a -> a
okorerror :: forall a. Result a -> a
okorerror = \case
  OK a
a Int
_ ByteString
_ -> a
a
  Result a
Fail -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"<code generated by IO.TH>: unexpected uninformative failure"
  Err ParseError
e -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"<code generated by IO.TH>: error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ParseError -> [Char]
showparseerror ParseError
e

-- | Generate Template Haskell type signature and expression for a ParserStates pair.
-- Takes a list of packet definitions and produces corresponding parser states.
thparserstates :: [S] -> Q (Type, Exp)
thparserstates :: [S] -> Q (Type, Exp)
thparserstates [S]
rows = do
  let genparse :: (S -> Maybe Int) -> Q Exp
genparse S -> Maybe Int
l =
        let f :: S -> [(Q Type, Q Exp)] -> [(Q Type, Q Exp)]
f S
s [(Q Type, Q Exp)]
a
              | Just Int
i <- S -> Maybe Int
l S
s =
                  (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ S -> [Char]
sna S
s, Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (Int -> Lit) -> Int -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Q Exp) -> Int -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int
i) (Q Type, Q Exp) -> [(Q Type, Q Exp)] -> [(Q Type, Q Exp)]
forall a. a -> [a] -> [a]
: [(Q Type, Q Exp)]
a
              | Bool
otherwise = [(Q Type, Q Exp)]
a
            pairs :: [(Q Type, Q Exp)]
pairs = (S -> [(Q Type, Q Exp)] -> [(Q Type, Q Exp)])
-> [(Q Type, Q Exp)] -> [S] -> [(Q Type, Q Exp)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr S -> [(Q Type, Q Exp)] -> [(Q Type, Q Exp)]
f [] [S]
rows
         in Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'I.fromList) do
              [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (((Q Type, Q Exp) -> Q Exp) -> [(Q Type, Q Exp)] -> [Q Exp])
-> [(Q Type, Q Exp)] -> ((Q Type, Q Exp) -> Q Exp) -> [Q Exp]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Q Type, Q Exp) -> Q Exp) -> [(Q Type, Q Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map [(Q Type, Q Exp)]
pairs \(Q Type
ty, Q Exp
co) ->
                [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [Q Exp
Item [Q Exp]
co, Q Exp -> Q Type -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
appTypeE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unpacksome) Q Type
ty]
      gencode :: (S -> Maybe Int) -> (S -> Maybe Int) -> Q Exp
gencode S -> Maybe Int
li S -> Maybe Int
lo =
        let f :: (S -> Maybe a) -> S -> [(m Exp, m Exp)] -> [(m Exp, m Exp)]
f S -> Maybe a
l S
s [(m Exp, m Exp)]
a
              | Just a
i <- S -> Maybe a
l S
s =
                  let t :: Name
t = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ S -> [Char]
sna S
s
                   in ( m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'typeRep) (m Exp -> m Type -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
appTypeE (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Proxy) (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
t)),
                        Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> m Exp) -> (a -> Lit) -> a -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (a -> Integer) -> a -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (Integral a, Num b) => a -> b
fi (a -> m Exp) -> a -> m Exp
forall a b. (a -> b) -> a -> b
$ a
i
                      )
                        (m Exp, m Exp) -> [(m Exp, m Exp)] -> [(m Exp, m Exp)]
forall a. a -> [a] -> [a]
: [(m Exp, m Exp)]
a
              | Bool
otherwise = [(m Exp, m Exp)]
a
            inbound :: [(Q Exp, Q Exp)]
inbound = (S -> [(Q Exp, Q Exp)] -> [(Q Exp, Q Exp)])
-> [(Q Exp, Q Exp)] -> [S] -> [(Q Exp, Q Exp)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((S -> Maybe Int) -> S -> [(Q Exp, Q Exp)] -> [(Q Exp, Q Exp)]
forall {m :: * -> *} {m :: * -> *} {a}.
(Quote m, Quote m, Integral a) =>
(S -> Maybe a) -> S -> [(m Exp, m Exp)] -> [(m Exp, m Exp)]
f S -> Maybe Int
li) [] [S]
rows
            outbound :: [(Q Exp, Q Exp)]
outbound = (S -> [(Q Exp, Q Exp)] -> [(Q Exp, Q Exp)])
-> [(Q Exp, Q Exp)] -> [S] -> [(Q Exp, Q Exp)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((S -> Maybe Int) -> S -> [(Q Exp, Q Exp)] -> [(Q Exp, Q Exp)]
forall {m :: * -> *} {m :: * -> *} {a}.
(Quote m, Quote m, Integral a) =>
(S -> Maybe a) -> S -> [(m Exp, m Exp)] -> [(m Exp, m Exp)]
f S -> Maybe Int
lo) [] [S]
rows
            u :: [(m Exp, m Exp)] -> Name -> m Exp
u [(m Exp, m Exp)]
l Name
i = [m Exp] -> m Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([m Exp] -> m Exp) -> [m Exp] -> m Exp
forall a b. (a -> b) -> a -> b
$ (((m Exp, m Exp) -> m Exp) -> [(m Exp, m Exp)] -> [m Exp])
-> [(m Exp, m Exp)] -> ((m Exp, m Exp) -> m Exp) -> [m Exp]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((m Exp, m Exp) -> m Exp) -> [(m Exp, m Exp)] -> [m Exp]
forall a b. (a -> b) -> [a] -> [b]
map [(m Exp, m Exp)]
l \(m Exp
tr, m Exp
co) ->
              [m Exp] -> m Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE
                [ [m Exp] -> m Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
i, m Exp
Item [m Exp]
tr],
                  m Exp -> m Type -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE m Exp
co (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Word8)
                ]
         in Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'H.fromList) do
              Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                ( Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                    (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'concat2)
                    ([(Q Exp, Q Exp)] -> Name -> Q Exp
forall {m :: * -> *}. Quote m => [(m Exp, m Exp)] -> Name -> m Exp
u [(Q Exp, Q Exp)]
inbound 'Inbound)
                )
                ([(Q Exp, Q Exp)] -> Name -> Q Exp
forall {m :: * -> *}. Quote m => [(m Exp, m Exp)] -> Name -> m Exp
u [(Q Exp, Q Exp)]
outbound 'Outbound)
      -- Server uses send for inbound, recv for outbound
      gensparse :: Q Exp
gensparse = (S -> Maybe Int) -> Q Exp
genparse S -> Maybe Int
send
      genscode :: Q Exp
genscode = (S -> Maybe Int) -> (S -> Maybe Int) -> Q Exp
gencode S -> Maybe Int
send S -> Maybe Int
recv
      -- Client uses recv for inbound, send for outbound
      gencparse :: Q Exp
gencparse = (S -> Maybe Int) -> Q Exp
genparse S -> Maybe Int
recv
      genccode :: Q Exp
genccode = (S -> Maybe Int) -> (S -> Maybe Int) -> Q Exp
gencode S -> Maybe Int
recv S -> Maybe Int
send
  Name
argname <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"argname" -- some temporary binder
  Name
u <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"u" -- uninterpreted (essentially code * rest of packet)
  Name
a <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"a" -- the parsing list
  Name
b <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"b" -- the direction * type -> code list
  Name
d <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"d" -- direction
  Name
y <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y" -- type
  let half :: Q Exp -> Q Exp -> Q Exp
half Q Exp
g0 Q Exp
g1 =
        [Q Dec] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE [Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
g0) [], Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
b) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
g1) []] do
          Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'ParserState) do
            Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argname) do
              Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
                (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argname)
                [ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
                    (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Parse [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
u])
                    ( Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB do
                        Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                          (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'okorerror)
                          ( Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                              ( Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                                  (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'parsepure0)
                                  ( Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                                      (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'forceindex) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a))
                                      ( Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                                          (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fi)
                                          (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'pkcode) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
u))
                                      )
                                  )
                              )
                              (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'pkdata) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
u))
                          )
                    )
                    [],
                  Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
                    (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Code [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
d, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y])
                    ( Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB do
                        Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                          ( Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'H.lookup)
                              ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
d, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y])
                          )
                          (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b)
                    )
                    []
                ]
      sig :: Q Type
sig = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''ParserStates
  Type
s1 <- Q Type
sig
  Exp
s2 <-
    Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
      ( Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
          (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'ParserStates)
          (Q Exp -> Q Exp -> Q Exp
half Q Exp
gensparse Q Exp
genscode)
      )
      (Q Exp -> Q Exp -> Q Exp
half Q Exp
gencparse Q Exp
genccode)
  (Type, Exp) -> Q (Type, Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
s1, Exp
s2)

-- | Parse a single colon character
colon :: Parser st r ()
colon :: forall (st :: ZeroBitType) r. Parser st r ()
colon = (Char -> Bool) -> ParserT st r ParseError ()
forall (st :: ZeroBitType) r e. (Char -> Bool) -> ParserT st r e ()
skipSatisfyAscii (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')

-- | Parse a colon with error reporting
colon' :: Parser st r ()
colon' :: forall (st :: ZeroBitType) r. Parser st r ()
colon' = ParserT st r ParseError ()
-> ParseError -> ParserT st r ParseError ()
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> e -> ParserT st r e a
cut ParserT st r ParseError ()
forall (st :: ZeroBitType) r. Parser st r ()
colon ParseError
"expected colon (:)"

-- | Parse a hexadecimal number into an Int
-- Supports both uppercase and lowercase hex digits
hexnumber :: Parser st r Int
hexnumber :: forall (st :: ZeroBitType) r. Parser st r Int
hexnumber = do
  (Int
p, Int
n) <- (Int -> (Int, Int) -> (Int, Int))
-> Parser st r Int
-> ParserT st r ParseError (Int, Int)
-> ParserT st r ParseError (Int, Int)
forall a b (st :: ZeroBitType) r e.
(a -> b -> b)
-> ParserT st r e a -> ParserT st r e b -> ParserT st r e b
chainr Int -> (Int, Int) -> (Int, Int)
forall {b}. Num b => b -> (b, b) -> (b, b)
f Parser st r Int
forall {st :: ZeroBitType} {r} {e}. ParserT st r e Int
digit ((Int, Int) -> ParserT st r ParseError (Int, Int)
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Int
0))
  Bool -> ParserT st r ParseError ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1)
  Int -> Parser st r Int
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
  where
    f :: b -> (b, b) -> (b, b)
f b
n (!b
place, !b
a) = (b
place b -> b -> b
forall a. Num a => a -> a -> a
* b
16, b
a b -> b -> b
forall a. Num a => a -> a -> a
+ b
place b -> b -> b
forall a. Num a => a -> a -> a
* b
n)
    digit :: ParserT st r e Int
digit =
      (Char -> Bool) -> ParserT st r e Char
forall (st :: ZeroBitType) r e.
(Char -> Bool) -> ParserT st r e Char
satisfyAscii Char -> Bool
d ParserT st r e Char -> (Char -> Int) -> ParserT st r e Int
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Char
c | Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' -> Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0'
        Char
c | Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F' -> Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A'
        Char
c | Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' -> Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a'
        Char
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"hexnumber/digit: impossible"
    d :: Char -> Bool
d = (Bool -> Bool -> Bool)
-> (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall a b c.
(a -> b -> c) -> (Char -> a) -> (Char -> b) -> Char -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) Char -> Bool
isDigit ((Char -> [Char] -> Bool) -> [Char] -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem @[]) [Char]
"ABCDEFabcdef")

-- | Parse a valid identifier
-- First char must be letter, underscore or quote
-- Later chars can also include dots and digits
ident :: Parser st r String
ident :: forall (st :: ZeroBitType) r. Parser st r [Char]
ident =
  (Char -> [Char] -> [Char])
-> ParserT st r ParseError Char
-> ParserT st r ParseError [Char]
-> ParserT st r ParseError [Char]
forall a b c.
(a -> b -> c)
-> ParserT st r ParseError a
-> ParserT st r ParseError b
-> ParserT st r ParseError c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
    (:)
    do (Char -> Bool) -> ParserT st r ParseError Char
forall (st :: ZeroBitType) r e.
(Char -> Bool) -> ParserT st r e Char
satisfyAscii Char -> Bool
firstchar
    do ParserT st r ParseError Char -> ParserT st r ParseError [Char]
forall a. ParserT st r ParseError a -> ParserT st r ParseError [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> ParserT st r ParseError Char
forall (st :: ZeroBitType) r e.
(Char -> Bool) -> ParserT st r e Char
satisfyAscii Char -> Bool
laterchar)
  where
    liftany :: [b -> Bool] -> b -> Bool
liftany = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr @[] ((Bool -> Bool -> Bool) -> (b -> Bool) -> (b -> Bool) -> b -> Bool
forall a b c. (a -> b -> c) -> (b -> a) -> (b -> b) -> b -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||)) (Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False)
    firstchar :: Char -> Bool
firstchar = [Char -> Bool] -> Char -> Bool
forall {b}. [b -> Bool] -> b -> Bool
liftany [(Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''), (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'), Item [Char -> Bool]
Char -> Bool
isLetter]
    laterchar :: Char -> Bool
laterchar = [Char -> Bool] -> Char -> Bool
forall {b}. [b -> Bool] -> b -> Bool
liftany [(Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'), (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'), (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''), Item [Char -> Bool]
Char -> Bool
isDigit, Item [Char -> Bool]
Char -> Bool
isLetter]

-- | Parse an identifier with error reporting
ident' :: Parser st r String
ident' :: forall (st :: ZeroBitType) r. Parser st r [Char]
ident' = ParserT st r ParseError [Char]
-> ParseError -> ParserT st r ParseError [Char]
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> e -> ParserT st r e a
cut ParserT st r ParseError [Char]
forall (st :: ZeroBitType) r. Parser st r [Char]
ident ParseError
"expected an identifier"

-- | Skip a line comment starting with --
linecomment :: Parser st r ()
linecomment :: forall (st :: ZeroBitType) r. Parser st r ()
linecomment =
  ParserT st r ParseError Word8
-> (Word8 -> ParserT st r ParseError ())
-> ParserT st r ParseError ()
-> ParserT st r ParseError ()
forall (st :: ZeroBitType) r e a ret.
ParserT st r e a
-> (a -> ParserT st r e ret)
-> ParserT st r e ret
-> ParserT st r e ret
withOption
    ParserT st r ParseError Word8
forall (st :: ZeroBitType) r e. ParserT st r e Word8
anyWord8
    (\case Word8
10 -> ParserT st r ParseError ()
forall (st :: ZeroBitType) r. Parser st r ()
ws; Word8
_ -> ParserT st r ParseError ()
forall (st :: ZeroBitType) r. Parser st r ()
linecomment)
    (() -> ParserT st r ParseError ()
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Skip a multi-line comment between {- and -}
-- Handles nested comments correctly
multilinecomment :: Parser st r ()
multilinecomment :: forall (st :: ZeroBitType) r. Parser st r ()
multilinecomment =
  (Int
1 :: Int) Int -> (Int -> Parser st r ()) -> Parser st r ()
forall a b. a -> (a -> b) -> b
& ((Int -> Parser st r ()) -> Int -> Parser st r ())
-> Int -> Parser st r ()
forall a. (a -> a) -> a
fix \Int -> Parser st r ()
f -> \case
    Int
0 -> Parser st r ()
forall (st :: ZeroBitType) r. Parser st r ()
ws
    Int
n ->
      $( switch
           [|
             case _ of
               "-}" -> f (n - 1)
               "{-" -> f (n + 1)
               _ -> branch anyWord8 (f n) (pure ())
             |]
       )

-- | Skip whitespace and comments
ws :: Parser st r ()
ws :: forall (st :: ZeroBitType) r. Parser st r ()
ws =
  $( switch
       [|
         case _ of
           " " -> ws
           "\n" -> ws
           "\t" -> ws
           "\r" -> ws
           "--" -> linecomment
           "{-" -> multilinecomment
           _ -> pure ()
         |]
   )

-- | Skip to end of current line
skipline :: Parser st r ()
skipline :: forall (st :: ZeroBitType) r. Parser st r ()
skipline = ParserT st r ParseError Word8
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill ParserT st r ParseError Word8
forall (st :: ZeroBitType) r e. ParserT st r e Word8
anyWord8 (ParserT st r ParseError ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
eof ParserT st r ParseError ()
-> ParserT st r ParseError () -> ParserT st r ParseError ()
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> (Char -> Bool) -> ParserT st r ParseError ()
forall (st :: ZeroBitType) r e. (Char -> Bool) -> ParserT st r e ()
skipSatisfyAscii (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'))

-- | Parse a single packet definition line
-- Format: <name>:<recv code>:<send code>
line :: Parser st r S
line :: forall (st :: ZeroBitType) r. Parser st r S
line = do
  [Char]
sna <- Parser st r ()
forall (st :: ZeroBitType) r. Parser st r ()
ws Parser st r ()
-> ParserT st r ParseError [Char] -> ParserT st r ParseError [Char]
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError [Char]
forall (st :: ZeroBitType) r. Parser st r [Char]
ident' ParserT st r ParseError [Char]
-> Parser st r () -> ParserT st r ParseError [Char]
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
forall (st :: ZeroBitType) r. Parser st r ()
colon'
  Maybe Int
recv <- Parser st r ()
forall (st :: ZeroBitType) r. Parser st r ()
ws Parser st r ()
-> ParserT st r ParseError (Maybe Int)
-> ParserT st r ParseError (Maybe Int)
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError Int -> ParserT st r ParseError (Maybe Int)
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e (Maybe a)
optional ParserT st r ParseError Int
forall (st :: ZeroBitType) r. Parser st r Int
hexnumber ParserT st r ParseError (Maybe Int)
-> Parser st r () -> ParserT st r ParseError (Maybe Int)
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
forall (st :: ZeroBitType) r. Parser st r ()
colon'
  Maybe Int
send <- Parser st r ()
forall (st :: ZeroBitType) r. Parser st r ()
ws Parser st r ()
-> ParserT st r ParseError (Maybe Int)
-> ParserT st r ParseError (Maybe Int)
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError Int -> ParserT st r ParseError (Maybe Int)
forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e (Maybe a)
optional ParserT st r ParseError Int
forall (st :: ZeroBitType) r. Parser st r Int
hexnumber ParserT st r ParseError (Maybe Int)
-> Parser st r () -> ParserT st r ParseError (Maybe Int)
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
forall (st :: ZeroBitType) r. Parser st r ()
skipline
  S -> Parser st r S
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure S {[Char]
Maybe Int
sna :: [Char]
recv :: Maybe Int
send :: Maybe Int
sna :: [Char]
recv :: Maybe Int
send :: Maybe Int
..}

-- | Parse the complete grammar document
-- First line contains state name
-- Remaining lines contain packet definitions
doc :: Parser st r (Name, [S])
doc :: forall (st :: ZeroBitType) r. Parser st r (Name, [S])
doc = do
  -- name of the pair
  Name
n <- [Char] -> Name
mkName ([Char] -> Name)
-> ParserT st r ParseError [Char] -> ParserT st r ParseError Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser st r ()
forall (st :: ZeroBitType) r. Parser st r ()
ws Parser st r ()
-> ParserT st r ParseError [Char] -> ParserT st r ParseError [Char]
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT st r ParseError [Char]
forall (st :: ZeroBitType) r. Parser st r [Char]
ident')
  -- body
  [S]
m <- ParserT st r ParseError S
-> Parser st r () -> ParserT st r ParseError [S]
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m [a]
manyTill (ParserT st r ParseError S
forall (st :: ZeroBitType) r. Parser st r S
line ParserT st r ParseError S
-> Parser st r () -> ParserT st r ParseError S
forall a b.
ParserT st r ParseError a
-> ParserT st r ParseError b -> ParserT st r ParseError a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser st r ()
forall (st :: ZeroBitType) r. Parser st r ()
ws) Parser st r ()
forall (st :: ZeroBitType) r e. ParserT st r e ()
eof
  (Name, [S]) -> Parser st r (Name, [S])
forall a. a -> ParserT st r ParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, [S]
m)