{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}

module TypedSession.State.Parser (runProtocolParser) where

import qualified Data.List as L
import Data.Void (Void)
import Text.Megaparsec hiding (Label, label)
import Text.Megaparsec.Char (space1, string)
import qualified Text.Megaparsec.Char as LC
import qualified Text.Megaparsec.Char.Lexer as L
import TypedSession.State.Type

type Parser = Parsec Void String

spaceConsumer :: Parser ()
spaceConsumer :: Parser ()
spaceConsumer =
  Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
    Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1
    (Tokens [Char] -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment [Char]
Tokens [Char]
"--")
    (Tokens [Char] -> Tokens [Char] -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockCommentNested [Char]
Tokens [Char]
"{-" [Char]
Tokens [Char]
"-}")

symbol :: String -> Parser String
symbol :: [Char] -> Parser [Char]
symbol = Parser ()
-> Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
spaceConsumer

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = Parser ()
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer

msg, label, branch, branchSt, goto, terminal :: Parser String
msg :: Parser [Char]
msg = [Char] -> Parser [Char]
symbol [Char]
"Msg"
label :: Parser [Char]
label = [Char] -> Parser [Char]
symbol [Char]
"Label"
branch :: Parser [Char]
branch = [Char] -> Parser [Char]
symbol [Char]
"Branch"
branchSt :: Parser [Char]
branchSt = [Char] -> Parser [Char]
symbol [Char]
"BranchSt"
goto :: Parser [Char]
goto = [Char] -> Parser [Char]
symbol [Char]
"Goto"
terminal :: Parser [Char]
terminal = [Char] -> Parser [Char]
symbol [Char]
"Terminal"

integer :: Parser Integer
integer :: Parser Integer
integer = Parser Integer -> Parser Integer
forall a. Parser a -> Parser a
lexeme Parser Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal

comma :: Parser String
comma :: Parser [Char]
comma = [Char] -> Parser [Char]
symbol [Char]
","

brackets :: Parser a -> Parser a
brackets :: forall a. Parser a -> Parser a
brackets = Parser [Char]
-> Parser [Char]
-> ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ([Char] -> Parser [Char]
symbol [Char]
"[") ([Char] -> Parser [Char]
symbol [Char]
"]")

braces :: Parser a -> Parser a
braces :: forall a. Parser a -> Parser a
braces = Parser [Char]
-> Parser [Char]
-> ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ([Char] -> Parser [Char]
symbol [Char]
"{") ([Char] -> Parser [Char]
symbol [Char]
"}")

dbg :: String -> m a -> m a
dbg :: forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
_ m a
ma = m a
ma

constrOrType :: Parser String
constrOrType :: Parser [Char]
constrOrType = [Char] -> Parser [Char] -> Parser [Char]
forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
"constrOrType" (Parser [Char] -> Parser [Char]) -> Parser [Char] -> Parser [Char]
forall a b. (a -> b) -> a -> b
$ do
  x <- ParsecT Void [Char] Identity Char
ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
LC.upperChar
  xs <- many LC.alphaNumChar
  spaceConsumer
  pure (x : xs)

mkParserA :: forall a. (Enum a, Bounded a, Show a) => Parser a
mkParserA :: forall a. (Enum a, Bounded a, Show a) => Parser a
mkParserA = do
  let rg :: [a]
rg = [forall a. Bounded a => a
minBound @a .. a
forall a. Bounded a => a
maxBound]
      rg' :: [a]
rg' =
        ((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, a) -> a
forall a b. (a, b) -> b
snd
          ([(Int, a)] -> [a])
-> ([(Int, a)] -> [(Int, a)]) -> [(Int, a)] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> (Int, a) -> Ordering) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (\(Int
a, a
_) (Int
b, a
_) -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
b Int
a)
          ([(Int, a)] -> [a]) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> (a -> [Char]) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show) [a]
rg) [a]
rg
  a <-
    [ParsecT Void [Char] Identity a] -> ParsecT Void [Char] Identity a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT Void [Char] Identity a]
 -> ParsecT Void [Char] Identity a)
-> [ParsecT Void [Char] Identity a]
-> ParsecT Void [Char] Identity a
forall a b. (a -> b) -> a -> b
$ (a -> ParsecT Void [Char] Identity a)
-> [a] -> [ParsecT Void [Char] Identity a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
r -> (Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (a -> [Char]
forall a. Show a => a -> [Char]
show a
r) ParsecT Void [Char] Identity (Tokens [Char])
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ParsecT Void [Char] Identity a
forall a. a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r)) [a]
rg'
  spaceConsumer
  pure a

parseMsg
  :: forall r
   . (Enum r, Bounded r, Show r)
  => Parser (MsgOrLabel Creat r)
parseMsg :: forall r.
(Enum r, Bounded r, Show r) =>
Parser (MsgOrLabel Creat r)
parseMsg = [Char]
-> ParsecT Void [Char] Identity (MsgOrLabel Creat r)
-> ParsecT Void [Char] Identity (MsgOrLabel Creat r)
forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
"Msg" (ParsecT Void [Char] Identity (MsgOrLabel Creat r)
 -> ParsecT Void [Char] Identity (MsgOrLabel Creat r))
-> ParsecT Void [Char] Identity (MsgOrLabel Creat r)
-> ParsecT Void [Char] Identity (MsgOrLabel Creat r)
forall a b. (a -> b) -> a -> b
$ do
  Parser [Char]
msg
  constr <- Parser [Char]
constrOrType
  args <- brackets ((some constrOrType) `sepBy` comma)
  from <- mkParserA @r
  to <- mkParserA @r
  pure $ Msg () constr args from to

parseLabel :: (Show r) => Parser (MsgOrLabel Creat r)
parseLabel :: forall r. Show r => Parser (MsgOrLabel Creat r)
parseLabel = [Char]
-> ParsecT Void [Char] Identity (MsgOrLabel Creat r)
-> ParsecT Void [Char] Identity (MsgOrLabel Creat r)
forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
"Label" (ParsecT Void [Char] Identity (MsgOrLabel Creat r)
 -> ParsecT Void [Char] Identity (MsgOrLabel Creat r))
-> ParsecT Void [Char] Identity (MsgOrLabel Creat r)
-> ParsecT Void [Char] Identity (MsgOrLabel Creat r)
forall a b. (a -> b) -> a -> b
$ do
  Parser [Char]
label
  i <- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int)
-> Parser Integer -> ParsecT Void [Char] Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
integer
  pure $ Label () i

parseGoto :: (Show bst, Show r) => Parser (Protocol Creat r bst)
parseGoto :: forall bst r. (Show bst, Show r) => Parser (Protocol Creat r bst)
parseGoto = [Char]
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
"Goto" (ParsecT Void [Char] Identity (Protocol Creat r bst)
 -> ParsecT Void [Char] Identity (Protocol Creat r bst))
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall a b. (a -> b) -> a -> b
$ do
  Parser [Char]
goto
  i <- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int)
-> Parser Integer -> ParsecT Void [Char] Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
integer
  pure $ Goto () i

parseTerminal :: (Show bst, Show r) => Parser (Protocol Creat r bst)
parseTerminal :: forall bst r. (Show bst, Show r) => Parser (Protocol Creat r bst)
parseTerminal = [Char]
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
"Terminal" (ParsecT Void [Char] Identity (Protocol Creat r bst)
 -> ParsecT Void [Char] Identity (Protocol Creat r bst))
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall a b. (a -> b) -> a -> b
$ do
  Parser [Char]
terminal
  Protocol Creat r bst
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall a. a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Protocol Creat r bst
 -> ParsecT Void [Char] Identity (Protocol Creat r bst))
-> Protocol Creat r bst
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall a b. (a -> b) -> a -> b
$ XTerminal Creat -> Protocol Creat r bst
forall eta r bst. XTerminal eta -> Protocol eta r bst
Terminal ()

parseBranchSt
  :: forall bst r
   . (Enum bst, Bounded bst, Show bst, Enum r, Bounded r, Show r)
  => Parser (BranchSt Creat r bst)
parseBranchSt :: forall bst r.
(Enum bst, Bounded bst, Show bst, Enum r, Bounded r, Show r) =>
Parser (BranchSt Creat r bst)
parseBranchSt = [Char]
-> ParsecT Void [Char] Identity (BranchSt Creat r bst)
-> ParsecT Void [Char] Identity (BranchSt Creat r bst)
forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
"BranchSt" (ParsecT Void [Char] Identity (BranchSt Creat r bst)
 -> ParsecT Void [Char] Identity (BranchSt Creat r bst))
-> ParsecT Void [Char] Identity (BranchSt Creat r bst)
-> ParsecT Void [Char] Identity (BranchSt Creat r bst)
forall a b. (a -> b) -> a -> b
$ do
  Parser [Char]
branchSt
  bst <- forall a. (Enum a, Bounded a, Show a) => Parser a
mkParserA @bst
  args <- brackets ((some constrOrType) `sepBy` comma)
  prot <- parseProtocol @r @bst
  pure (BranchSt () bst args prot)

parseBranch
  :: forall r bst
   . (Enum r, Bounded r, Show r, Enum bst, Bounded bst, Show bst) => Parser (Protocol Creat r bst)
parseBranch :: forall r bst.
(Enum r, Bounded r, Show r, Enum bst, Bounded bst, Show bst) =>
Parser (Protocol Creat r bst)
parseBranch = [Char]
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
"Branch" (ParsecT Void [Char] Identity (Protocol Creat r bst)
 -> ParsecT Void [Char] Identity (Protocol Creat r bst))
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall a b. (a -> b) -> a -> b
$ do
  Parser [Char]
branch
  r1 <- forall a. (Enum a, Bounded a, Show a) => Parser a
mkParserA @r
  st <- constrOrType
  braces $ do
    branchSts <- some (parseBranchSt @bst @r)
    pure (Branch () r1 st branchSts)

parseMsgOrLabel
  :: forall r bst
   . (Enum r, Bounded r, Show r, Enum bst, Bounded bst, Show bst)
  => Parser (Protocol Creat r bst)
parseMsgOrLabel :: forall r bst.
(Enum r, Bounded r, Show r, Enum bst, Bounded bst, Show bst) =>
Parser (Protocol Creat r bst)
parseMsgOrLabel = [Char]
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
"MsgOrLabel" (ParsecT Void [Char] Identity (Protocol Creat r bst)
 -> ParsecT Void [Char] Identity (Protocol Creat r bst))
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall a b. (a -> b) -> a -> b
$ do
  msgOrLabel <- [ParsecT Void [Char] Identity (MsgOrLabel Creat r)]
-> ParsecT Void [Char] Identity (MsgOrLabel Creat r)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [forall r.
(Enum r, Bounded r, Show r) =>
Parser (MsgOrLabel Creat r)
parseMsg @r, ParsecT Void [Char] Identity (MsgOrLabel Creat r)
forall r. Show r => Parser (MsgOrLabel Creat r)
parseLabel]
  prot <- parseProtocol @r @bst
  pure (msgOrLabel :> prot)

parseProtocol
  :: forall r bst
   . (Enum r, Bounded r, Show r, Enum bst, Bounded bst, Show bst)
  => Parser (Protocol Creat r bst)
parseProtocol :: forall r bst.
(Enum r, Bounded r, Show r, Enum bst, Bounded bst, Show bst) =>
Parser (Protocol Creat r bst)
parseProtocol = [Char]
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall (m :: * -> *) a. [Char] -> m a -> m a
dbg [Char]
"Protocol" (ParsecT Void [Char] Identity (Protocol Creat r bst)
 -> ParsecT Void [Char] Identity (Protocol Creat r bst))
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall a b. (a -> b) -> a -> b
$ do
  [ParsecT Void [Char] Identity (Protocol Creat r bst)]
-> ParsecT Void [Char] Identity (Protocol Creat r bst)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParsecT Void [Char] Identity (Protocol Creat r bst)
forall bst r. (Show bst, Show r) => Parser (Protocol Creat r bst)
parseGoto, ParsecT Void [Char] Identity (Protocol Creat r bst)
forall bst r. (Show bst, Show r) => Parser (Protocol Creat r bst)
parseTerminal, forall r bst.
(Enum r, Bounded r, Show r, Enum bst, Bounded bst, Show bst) =>
Parser (Protocol Creat r bst)
parseBranch @r @bst, ParsecT Void [Char] Identity (Protocol Creat r bst)
forall r bst.
(Enum r, Bounded r, Show r, Enum bst, Bounded bst, Show bst) =>
Parser (Protocol Creat r bst)
parseMsgOrLabel]

runProtocolParser
  :: forall r bst
   . (Enum r, Enum bst, Bounded r, Bounded bst, Show r, Show bst)
  => String
  -> Either String (Protocol Creat r bst)
runProtocolParser :: forall r bst.
(Enum r, Enum bst, Bounded r, Bounded bst, Show r, Show bst) =>
[Char] -> Either [Char] (Protocol Creat r bst)
runProtocolParser [Char]
st =
  let res :: Either (ParseErrorBundle [Char] Void) (Protocol Creat r bst)
res = Parsec Void [Char] (Protocol Creat r bst)
-> [Char]
-> [Char]
-> Either (ParseErrorBundle [Char] Void) (Protocol Creat r bst)
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
runParser (Parser ()
-> Parser ()
-> Parsec Void [Char] (Protocol Creat r bst)
-> Parsec Void [Char] (Protocol Creat r bst)
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between Parser ()
spaceConsumer Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof (Parsec Void [Char] (Protocol Creat r bst)
 -> Parsec Void [Char] (Protocol Creat r bst))
-> Parsec Void [Char] (Protocol Creat r bst)
-> Parsec Void [Char] (Protocol Creat r bst)
forall a b. (a -> b) -> a -> b
$ forall r bst.
(Enum r, Bounded r, Show r, Enum bst, Bounded bst, Show bst) =>
Parser (Protocol Creat r bst)
parseProtocol @r @bst) [Char]
"" [Char]
st
   in case Either (ParseErrorBundle [Char] Void) (Protocol Creat r bst)
res of
        Left ParseErrorBundle [Char] Void
e -> [Char] -> Either [Char] (Protocol Creat r bst)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (Protocol Creat r bst))
-> [Char] -> Either [Char] (Protocol Creat r bst)
forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty @String @Void ParseErrorBundle [Char] Void
e
        Right Protocol Creat r bst
a -> Protocol Creat r bst -> Either [Char] (Protocol Creat r bst)
forall a b. b -> Either a b
Right Protocol Creat r bst
a