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