{-# LANGUAGE GADTs #-}
module CommonParserUtil
( LexerSpec(..), ParserSpec(..), AutomatonSpec(..), HandleParseError(..)
, lexing, lexingWithLineColumn, parsing, runAutomaton, parsingHaskell, runAutomatonHaskell
, get, getText
, LexError(..), ParseError(..)
, successfullyParsed, handleLexError, handleParseError) where
import Terminal
import TokenInterface
import Text.Regex.TDFA
import System.Exit
import System.Process
import Control.Monad
import Data.Typeable
import Control.Exception
import SaveProdRules
import AutomatonType
import LoadAutomaton
import Data.List (nub)
import Data.Maybe
import SynCompInterface
import Prelude hiding (catch)
import System.Directory
import Control.Exception
import System.IO.Error hiding (catch)
type RegExpStr = String
type LexFun token = String -> Maybe token
type LexerSpecList token = [(RegExpStr, LexFun token)]
data LexerSpec token =
LexerSpec { LexerSpec token -> token
endOfToken :: token,
LexerSpec token -> LexerSpecList token
lexerSpecList :: LexerSpecList token
}
type ProdRuleStr = String
type ParseFun token ast = Stack token ast -> ast
type ParserSpecList token ast = [(ProdRuleStr, ParseFun token ast)]
data ParserSpec token ast =
ParserSpec { ParserSpec token ast -> String
startSymbol :: String,
ParserSpec token ast -> ParserSpecList token ast
parserSpecList :: ParserSpecList token ast,
ParserSpec token ast -> String
baseDir :: String,
ParserSpec token ast -> String
actionTblFile :: String,
ParserSpec token ast -> String
gotoTblFile :: String,
ParserSpec token ast -> String
grammarFile :: String,
ParserSpec token ast -> String
parserSpecFile :: String,
ParserSpec token ast -> String
genparserexe :: String
}
data Spec token ast =
Spec (LexerSpec token) (ParserSpec token ast)
type Line = Int
type Column = Int
data LexError = LexError Int Int String
deriving (Typeable, Int -> LexError -> ShowS
[LexError] -> ShowS
LexError -> String
(Int -> LexError -> ShowS)
-> (LexError -> String) -> ([LexError] -> ShowS) -> Show LexError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LexError] -> ShowS
$cshowList :: [LexError] -> ShowS
show :: LexError -> String
$cshow :: LexError -> String
showsPrec :: Int -> LexError -> ShowS
$cshowsPrec :: Int -> LexError -> ShowS
Show)
instance Exception LexError
lexing :: TokenInterface token =>
LexerSpec token -> String -> IO [Terminal token]
lexing :: LexerSpec token -> String -> IO [Terminal token]
lexing LexerSpec token
lexerspec String
text = do
(Int
line, Int
col, [Terminal token]
terminalList) <- LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
forall token.
TokenInterface token =>
LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
lexingWithLineColumn LexerSpec token
lexerspec Int
1 Int
1 String
text
[Terminal token] -> IO [Terminal token]
forall (m :: * -> *) a. Monad m => a -> m a
return [Terminal token]
terminalList
lexingWithLineColumn :: TokenInterface token =>
LexerSpec token -> Line -> Column -> String -> IO (Line, Column, [Terminal token])
lexingWithLineColumn :: LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
lexingWithLineColumn LexerSpec token
lexerspec Int
line Int
col [] = do
let eot :: token
eot = LexerSpec token -> token
forall token. LexerSpec token -> token
endOfToken LexerSpec token
lexerspec
(Int, Int, [Terminal token]) -> IO (Int, Int, [Terminal token])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
line, Int
col, [String -> Int -> Int -> Maybe token -> Terminal token
forall token.
TokenInterface token =>
String -> Int -> Int -> Maybe token -> Terminal token
Terminal (token -> String
forall token. TokenInterface token => token -> String
fromToken token
eot) Int
line Int
col (token -> Maybe token
forall a. a -> Maybe a
Just token
eot)])
lexingWithLineColumn LexerSpec token
lexerspec Int
line Int
col String
text = do
(String
matchedText, String
theRestText, Maybe token
maybeTok) <-
Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
forall token.
TokenInterface token =>
Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
matchLexSpec Int
line Int
col (LexerSpec token -> LexerSpecList token
forall token. LexerSpec token -> LexerSpecList token
lexerSpecList LexerSpec token
lexerspec) String
text
let (Int
line_, Int
col_) = Int -> Int -> String -> (Int, Int)
moveLineCol Int
line Int
col String
matchedText
(Int
line__, Int
col__, [Terminal token]
terminalList) <- LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
forall token.
TokenInterface token =>
LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
lexingWithLineColumn LexerSpec token
lexerspec Int
line_ Int
col_ String
theRestText
case Maybe token
maybeTok of
Maybe token
Nothing -> (Int, Int, [Terminal token]) -> IO (Int, Int, [Terminal token])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
line__, Int
col__, [Terminal token]
terminalList)
Just token
tok -> do
let terminal :: Terminal token
terminal = String -> Int -> Int -> Maybe token -> Terminal token
forall token.
TokenInterface token =>
String -> Int -> Int -> Maybe token -> Terminal token
Terminal String
matchedText Int
line Int
col (token -> Maybe token
forall a. a -> Maybe a
Just token
tok)
(Int, Int, [Terminal token]) -> IO (Int, Int, [Terminal token])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
line__, Int
col__, Terminal token
terminalTerminal token -> [Terminal token] -> [Terminal token]
forall a. a -> [a] -> [a]
:[Terminal token]
terminalList)
matchLexSpec :: TokenInterface token =>
Line -> Column -> LexerSpecList token -> String
-> IO (String, String, Maybe token)
matchLexSpec :: Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
matchLexSpec Int
line Int
col [] String
text = do
LexError -> IO (String, String, Maybe token)
forall a e. Exception e => e -> a
throw (Int -> Int -> String -> LexError
CommonParserUtil.LexError Int
line Int
col String
text)
matchLexSpec Int
line Int
col ((String
aSpec,LexFun token
tokenBuilder):LexerSpecList token
lexerspec) String
text = do
let (String
pre, String
matched, String
post) = String
text String -> String -> (String, String, String)
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
aSpec :: (String,String,String)
case String
pre of
String
"" -> (String, String, Maybe token) -> IO (String, String, Maybe token)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
matched, String
post, LexFun token
tokenBuilder String
matched)
String
_ -> Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
forall token.
TokenInterface token =>
Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
matchLexSpec Int
line Int
col LexerSpecList token
lexerspec String
text
moveLineCol :: Line -> Column -> String -> (Line, Column)
moveLineCol :: Int -> Int -> String -> (Int, Int)
moveLineCol Int
line Int
col String
"" = (Int
line, Int
col)
moveLineCol Int
line Int
col (Char
'\n':String
text) = Int -> Int -> String -> (Int, Int)
moveLineCol (Int
lineInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
1 String
text
moveLineCol Int
line Int
col (Char
ch:String
text) = Int -> Int -> String -> (Int, Int)
moveLineCol Int
line (Int
colInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
text
type CurrentState = Int
type StateOnStackTop = Int
type LhsSymbol = String
type AutomatonSnapshot token ast =
(Stack token ast, ActionTable, GotoTable, ProdRules)
data ParseError token ast where
NotFoundAction :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
(Terminal token) -> CurrentState -> (Stack token ast) -> ActionTable -> GotoTable -> ProdRules -> [Terminal token] -> ParseError token ast
NotFoundGoto :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
StateOnStackTop -> LhsSymbol -> (Stack token ast) -> ActionTable -> GotoTable -> ProdRules -> [Terminal token] -> ParseError token ast
deriving (Typeable)
instance (Show token, Show ast) => Show (ParseError token ast) where
showsPrec :: Int -> ParseError token ast -> ShowS
showsPrec Int
p (NotFoundAction Terminal token
terminal Int
state Stack token ast
stack ActionTable
_ GotoTable
_ ProdRules
_ [Terminal token]
_) =
String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"NotFoundAction: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (Int -> String
forall a. Show a => a -> String
show Int
state) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal)
showsPrec Int
p (NotFoundGoto Int
topstate String
lhs Stack token ast
stack ActionTable
_ GotoTable
_ ProdRules
_ [Terminal token]
_) =
String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"NotFoundGoto: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (Int -> String
forall a. Show a => a -> String
show Int
topstate) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
lhs
instance (TokenInterface token, Typeable token, Show token, Typeable ast, Show ast)
=> Exception (ParseError token ast)
parsing :: Bool -> ParserSpec token ast -> [Terminal token] -> IO ast
parsing Bool
flag ParserSpec token ast
parserSpec [Terminal token]
terminalList =
Bool
-> ParserSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
Bool
-> ParserSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
parsingHaskell Bool
flag ParserSpec token ast
parserSpec [Terminal token]
terminalList Maybe token
forall a. Maybe a
Nothing
parsingHaskell :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
Bool -> ParserSpec token ast -> [Terminal token] -> Maybe token -> IO ast
parsingHaskell :: Bool
-> ParserSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
parsingHaskell Bool
flag ParserSpec token ast
parserSpec [Terminal token]
terminalList Maybe token
haskellOption = do
Bool
writtenBool <- String -> String -> [String] -> IO Bool
saveProdRules String
specFileName String
sSym [String]
pSpecList
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
writtenBool IO ()
generateAutomaton
(ActionTable
actionTbl, GotoTable
gotoTbl, ProdRules
prodRules) <-
String
-> String -> String -> IO (ActionTable, GotoTable, ProdRules)
loadAutomaton String
grammarFileName String
actionTblFileName String
gotoTblFileName
if ActionTable -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ActionTable
actionTbl Bool -> Bool -> Bool
|| GotoTable -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null GotoTable
gotoTbl Bool -> Bool -> Bool
|| ProdRules -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProdRules
prodRules
then do let hashFile :: String
hashFile = ShowS
getHashFileName String
specFileName
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Delete " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hashFile
String -> IO ()
removeIfExists String
hashFile
String -> IO ast
forall a. HasCallStack => String -> a
error (String -> IO ast) -> String -> IO ast
forall a b. (a -> b) -> a -> b
$ String
"Error: Empty automation: please rerun"
else do ast
ast <- Bool
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
Bool
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
runAutomatonHaskell Bool
flag
(AutomatonSpec :: forall token ast.
ActionTable
-> GotoTable
-> ProdRules
-> ParseFunList token ast
-> Int
-> AutomatonSpec token ast
AutomatonSpec {
am_initState :: Int
am_initState=Int
initState,
am_actionTbl :: ActionTable
am_actionTbl=ActionTable
actionTbl,
am_gotoTbl :: GotoTable
am_gotoTbl=GotoTable
gotoTbl,
am_prodRules :: ProdRules
am_prodRules=ProdRules
prodRules,
am_parseFuns :: ParseFunList token ast
am_parseFuns=ParseFunList token ast
pFunList })
[Terminal token]
terminalList Maybe token
haskellOption
ast -> IO ast
forall (m :: * -> *) a. Monad m => a -> m a
return ast
ast
where
specFileName :: String
specFileName = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
parserSpecFile ParserSpec token ast
parserSpec
grammarFileName :: String
grammarFileName = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
grammarFile ParserSpec token ast
parserSpec
actionTblFileName :: String
actionTblFileName = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
actionTblFile ParserSpec token ast
parserSpec
gotoTblFileName :: String
gotoTblFileName = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
gotoTblFile ParserSpec token ast
parserSpec
sSym :: String
sSym = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
startSymbol ParserSpec token ast
parserSpec
pSpecList :: [String]
pSpecList = ((String, ParseFun token ast) -> String)
-> [(String, ParseFun token ast)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, ParseFun token ast) -> String
forall a b. (a, b) -> a
fst (ParserSpec token ast -> [(String, ParseFun token ast)]
forall token ast. ParserSpec token ast -> ParserSpecList token ast
parserSpecList ParserSpec token ast
parserSpec)
pFunList :: ParseFunList token ast
pFunList = ((String, ParseFun token ast) -> ParseFun token ast)
-> [(String, ParseFun token ast)] -> ParseFunList token ast
forall a b. (a -> b) -> [a] -> [b]
map (String, ParseFun token ast) -> ParseFun token ast
forall a b. (a, b) -> b
snd (ParserSpec token ast -> [(String, ParseFun token ast)]
forall token ast. ParserSpec token ast -> ParserSpecList token ast
parserSpecList ParserSpec token ast
parserSpec)
generateAutomaton :: IO ()
generateAutomaton = do
ExitCode
exitCode <- String -> [String] -> IO ExitCode
rawSystem String
"stack"
[ String
"exec", String
"--",
String
"yapb-exe", String
specFileName, String
"-output",
String
grammarFileName, String
actionTblFileName, String
gotoTblFileName
]
case ExitCode
exitCode of
ExitFailure Int
code -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
exitCode
ExitCode
ExitSuccess -> String -> IO ()
putStrLn (String
"Successfully generated: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
actionTblFileName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
gotoTblFileName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
grammarFileName);
removeIfExists :: FilePath -> IO ()
removeIfExists :: String -> IO ()
removeIfExists String
fileName = String -> IO ()
removeFile String
fileName IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO ()
handleExists
where handleExists :: IOError -> IO ()
handleExists IOError
e
| IOError -> Bool
isDoesNotExistError IOError
e = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e
data StkElem token ast =
StkState Int
| StkTerminal (Terminal token)
| StkNonterminal (Maybe ast) String
instance TokenInterface token => Eq (StkElem token ast) where
(StkState Int
i) == :: StkElem token ast -> StkElem token ast -> Bool
== (StkState Int
j) = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j
(StkTerminal Terminal token
termi) == (StkTerminal Terminal token
termj) = Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
tokenTextFromTerminal Terminal token
termi String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
tokenTextFromTerminal Terminal token
termj
(StkNonterminal Maybe ast
_ String
si) == (StkNonterminal Maybe ast
_ String
sj) = String
si String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
sj
type Stack token ast = [StkElem token ast]
emptyStack :: [a]
emptyStack = []
get :: Stack token ast -> Int -> ast
get :: Stack token ast -> Int -> ast
get Stack token ast
stack Int
i =
case Stack token ast
stack Stack token ast -> Int -> StkElem token ast
forall a. [a] -> Int -> a
!! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) of
StkNonterminal (Just ast
ast) String
_ -> ast
ast
StkNonterminal Maybe ast
Nothing String
_ -> String -> ast
forall a. HasCallStack => String -> a
error (String -> ast) -> String -> ast
forall a b. (a -> b) -> a -> b
$ String
"get: empty ast in the nonterminal at stack"
StkElem token ast
_ -> String -> ast
forall a. HasCallStack => String -> a
error (String -> ast) -> String -> ast
forall a b. (a -> b) -> a -> b
$ String
"get: out of bound: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
getText :: Stack token ast -> Int -> String
getText :: Stack token ast -> Int -> String
getText Stack token ast
stack Int
i =
case Stack token ast
stack Stack token ast -> Int -> StkElem token ast
forall a. [a] -> Int -> a
!! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) of
StkTerminal (Terminal String
text Int
_ Int
_ Maybe token
_) -> String
text
StkElem token ast
_ -> ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"getText: out of bound: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
push :: a -> [a] -> [a]
push :: a -> [a] -> [a]
push a
elem [a]
stack = a
elema -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
stack
pop :: [a] -> (a, [a])
pop :: [a] -> (a, [a])
pop (a
elem:[a]
stack) = (a
elem, [a]
stack)
pop [] = String -> (a, [a])
forall a. HasCallStack => String -> a
error String
"Attempt to pop from the empty stack"
prStack :: TokenInterface token => Stack token ast -> String
prStack :: Stack token ast -> String
prStack [] = String
"STACK END"
prStack (StkState Int
i : Stack token ast
stack) = String
"S" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stack
prStack (StkTerminal (Terminal String
text Int
_ Int
_ (Just token
token)) : Stack token ast
stack) =
let str_token :: String
str_token = token -> String
forall token. TokenInterface token => token -> String
fromToken token
token in
(if String
str_token String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
text then String
str_token else (token -> String
forall token. TokenInterface token => token -> String
fromToken token
token String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" i.e. " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
text))
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stack
prStack (StkTerminal (Terminal String
text Int
_ Int
_ Maybe token
Nothing) : Stack token ast
stack) =
(String
token_na String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
text) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stack
prStack (StkNonterminal Maybe ast
_ String
str : Stack token ast
stack) = String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stack
currentState :: Stack token ast -> Int
currentState :: Stack token ast -> Int
currentState (StkState Int
i : Stack token ast
stack) = Int
i
currentState Stack token ast
_ = String -> Int
forall a. HasCallStack => String -> a
error String
"No state found in the stack top"
tokenTextFromTerminal :: TokenInterface token => Terminal token -> String
tokenTextFromTerminal :: Terminal token -> String
tokenTextFromTerminal (Terminal String
_ Int
_ Int
_ (Just token
token)) = token -> String
forall token. TokenInterface token => token -> String
fromToken token
token
tokenTextFromTerminal (Terminal String
_ Int
_ Int
_ Maybe token
Nothing) = String
token_na
lookupActionTable :: TokenInterface token => ActionTable -> Int -> (Terminal token) -> Maybe Action
lookupActionTable :: ActionTable -> Int -> Terminal token -> Maybe Action
lookupActionTable ActionTable
actionTbl Int
state Terminal token
terminal =
ActionTable -> (Int, String) -> String -> Maybe Action
forall a b. (Eq a, Show a) => [(a, b)] -> a -> String -> Maybe b
lookupTable ActionTable
actionTbl (Int
state,Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
tokenTextFromTerminal Terminal token
terminal)
(String
"Not found in the action table: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal)
lookupGotoTable :: GotoTable -> Int -> String -> Maybe Int
lookupGotoTable :: GotoTable -> Int -> String -> Maybe Int
lookupGotoTable GotoTable
gotoTbl Int
state String
nonterminalStr =
GotoTable -> (Int, String) -> String -> Maybe Int
forall a b. (Eq a, Show a) => [(a, b)] -> a -> String -> Maybe b
lookupTable GotoTable
gotoTbl (Int
state,String
nonterminalStr)
(String
"Not found in the goto table: ")
lookupTable :: (Eq a, Show a) => [(a,b)] -> a -> String -> Maybe b
lookupTable :: [(a, b)] -> a -> String -> Maybe b
lookupTable [(a, b)]
tbl a
key String
msg =
case [ b
val | (a
key', b
val) <- [(a, b)]
tbl, a
keya -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
key' ] of
[] -> Maybe b
forall a. Maybe a
Nothing
(b
h:[b]
_) -> b -> Maybe b
forall a. a -> Maybe a
Just b
h
revTakeRhs :: Int -> [a] -> [a]
revTakeRhs :: Int -> [a] -> [a]
revTakeRhs Int
0 [a]
stack = []
revTakeRhs Int
n (a
_:a
nt:[a]
stack) = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
revTakeRhs (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [a]
stack [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
nt]
data AutomatonSpec token ast =
AutomatonSpec {
AutomatonSpec token ast -> ActionTable
am_actionTbl :: ActionTable,
AutomatonSpec token ast -> GotoTable
am_gotoTbl :: GotoTable,
AutomatonSpec token ast -> ProdRules
am_prodRules :: ProdRules,
AutomatonSpec token ast -> ParseFunList token ast
am_parseFuns :: ParseFunList token ast,
AutomatonSpec token ast -> Int
am_initState :: Int
}
initState :: Int
initState = Int
0
type ParseFunList token ast = [ParseFun token ast]
runAutomaton :: Bool -> AutomatonSpec token ast -> [Terminal token] -> IO ast
runAutomaton Bool
flag AutomatonSpec token ast
amSpec [Terminal token]
terminalList =
Bool
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
Bool
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
runAutomatonHaskell Bool
flag AutomatonSpec token ast
amSpec [Terminal token]
terminalList Maybe token
forall a. Maybe a
Nothing
runAutomatonHaskell :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
Bool ->
AutomatonSpec token ast ->
[Terminal token] ->
Maybe token ->
IO ast
runAutomatonHaskell :: Bool
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
runAutomatonHaskell Bool
flag (rm_spec :: AutomatonSpec token ast
rm_spec @ AutomatonSpec {
am_initState :: forall token ast. AutomatonSpec token ast -> Int
am_initState=Int
initState,
am_actionTbl :: forall token ast. AutomatonSpec token ast -> ActionTable
am_actionTbl=ActionTable
actionTbl,
am_gotoTbl :: forall token ast. AutomatonSpec token ast -> GotoTable
am_gotoTbl=GotoTable
gotoTbl,
am_prodRules :: forall token ast. AutomatonSpec token ast -> ProdRules
am_prodRules=ProdRules
prodRules,
am_parseFuns :: forall token ast. AutomatonSpec token ast -> ParseFunList token ast
am_parseFuns=ParseFunList token ast
pFunList
}) [Terminal token]
terminalList Maybe token
haskellOption = do
let initStack :: [StkElem token ast]
initStack = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
initState) [StkElem token ast]
forall a. [a]
emptyStack
[Terminal token] -> [StkElem token ast] -> IO ast
run [Terminal token]
terminalList [StkElem token ast]
initStack
where
run :: [Terminal token] -> [StkElem token ast] -> IO ast
run [Terminal token]
terminalList [StkElem token ast]
stack = do
let state :: Int
state = [StkElem token ast] -> Int
forall token ast. Stack token ast -> Int
currentState [StkElem token ast]
stack
let terminal :: Terminal token
terminal = [Terminal token] -> Terminal token
forall a. [a] -> a
head [Terminal token]
terminalList
case ActionTable -> Int -> Terminal token -> Maybe Action
forall token.
TokenInterface token =>
ActionTable -> Int -> Terminal token -> Maybe Action
lookupActionTable ActionTable
actionTbl Int
state Terminal token
terminal of
Just Action
action -> do
Int
-> Terminal token
-> Action
-> [Terminal token]
-> [StkElem token ast]
-> IO ast
runAction Int
state Terminal token
terminal Action
action [Terminal token]
terminalList [StkElem token ast]
stack
Maybe Action
Nothing -> do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"lookActionTable failed (1st) with: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal)
case Maybe token
haskellOption of
Just token
extraToken -> do
let terminal_close_brace :: Terminal token
terminal_close_brace = String -> Int -> Int -> Maybe token -> Terminal token
forall token.
TokenInterface token =>
String -> Int -> Int -> Maybe token -> Terminal token
Terminal
(token -> String
forall token. TokenInterface token => token -> String
fromToken token
extraToken)
(Terminal token -> Int
forall token. TokenInterface token => Terminal token -> Int
terminalToLine Terminal token
terminal)
(Terminal token -> Int
forall token. TokenInterface token => Terminal token -> Int
terminalToCol Terminal token
terminal)
(token -> Maybe token
forall a. a -> Maybe a
Just token
extraToken)
case ActionTable -> Int -> Terminal token -> Maybe Action
forall token.
TokenInterface token =>
ActionTable -> Int -> Terminal token -> Maybe Action
lookupActionTable ActionTable
actionTbl Int
state Terminal token
terminal_close_brace of
Just Action
action -> do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"lookActionTable succeeded (2nd) with: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal_close_brace
Int
-> Terminal token
-> Action
-> [Terminal token]
-> [StkElem token ast]
-> IO ast
runAction Int
state Terminal token
terminal_close_brace Action
action (Terminal token
terminal_close_brace Terminal token -> [Terminal token] -> [Terminal token]
forall a. a -> [a] -> [a]
: [Terminal token]
terminalList) [StkElem token ast]
stack
Maybe Action
Nothing -> do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"lookActionTable failed (2nd) with: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal_close_brace
ParseError token ast -> IO ast
forall a e. Exception e => e -> a
throw (Terminal token
-> Int
-> [StkElem token ast]
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
Terminal token
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
NotFoundAction Terminal token
terminal Int
state [StkElem token ast]
stack ActionTable
actionTbl GotoTable
gotoTbl ProdRules
prodRules [Terminal token]
terminalList)
Maybe token
Nothing -> ParseError token ast -> IO ast
forall a e. Exception e => e -> a
throw (Terminal token
-> Int
-> [StkElem token ast]
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
Terminal token
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
NotFoundAction Terminal token
terminal Int
state [StkElem token ast]
stack ActionTable
actionTbl GotoTable
gotoTbl ProdRules
prodRules [Terminal token]
terminalList)
runAction :: Int
-> Terminal token
-> Action
-> [Terminal token]
-> [StkElem token ast]
-> IO ast
runAction Int
state Terminal token
terminal Action
action [Terminal token]
terminalList [StkElem token ast]
stack = do
Bool -> String -> IO ()
debug Bool
flag (String
"\nState " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state)
Bool -> String -> IO ()
debug Bool
flag (String
"Token " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
tokenTextFromTerminal Terminal token
terminal)
Bool -> String -> IO ()
debug Bool
flag (String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [StkElem token ast] -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack [StkElem token ast]
stack)
case Action
action of
Action
Accept -> do
Bool -> String -> IO ()
debug Bool
flag String
"Accept"
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal
case [StkElem token ast]
stack [StkElem token ast] -> Int -> StkElem token ast
forall a. [a] -> Int -> a
!! Int
1 of
StkNonterminal (Just ast
ast) String
_ -> ast -> IO ast
forall (m :: * -> *) a. Monad m => a -> m a
return ast
ast
StkNonterminal Maybe ast
Nothing String
_ -> String -> IO ast
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty ast in the stack nonterminal"
StkElem token ast
_ -> String -> IO ast
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not Stknontermianl on Accept"
Shift Int
toState -> do
Bool -> String -> IO ()
debug Bool
flag (String
"Shift " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
toState)
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal
let stack1 :: [StkElem token ast]
stack1 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Terminal token -> StkElem token ast
forall token ast. Terminal token -> StkElem token ast
StkTerminal ([Terminal token] -> Terminal token
forall a. [a] -> a
head [Terminal token]
terminalList)) [StkElem token ast]
stack
let stack2 :: [StkElem token ast]
stack2 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
toState) [StkElem token ast]
stack1
[Terminal token] -> [StkElem token ast] -> IO ast
run ([Terminal token] -> [Terminal token]
forall a. [a] -> [a]
tail [Terminal token]
terminalList) [StkElem token ast]
stack2
Reduce Int
n -> do
Bool -> String -> IO ()
debug Bool
flag (String
"Reduce " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
let prodrule :: (String, [String])
prodrule = ProdRules
prodRules ProdRules -> Int -> (String, [String])
forall a. [a] -> Int -> a
!! Int
n
Bool -> String -> IO ()
debug Bool
flag (String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String, [String]) -> String
forall a. Show a => a -> String
show (String, [String])
prodrule)
let builderFun :: ParseFun token ast
builderFun = ParseFunList token ast
pFunList ParseFunList token ast -> Int -> ParseFun token ast
forall a. [a] -> Int -> a
!! Int
n
let lhs :: String
lhs = (String, [String]) -> String
forall a b. (a, b) -> a
fst (String, [String])
prodrule
let rhsLength :: Int
rhsLength = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((String, [String]) -> [String]
forall a b. (a, b) -> b
snd (String, [String])
prodrule)
let rhsAst :: [StkElem token ast]
rhsAst = Int -> [StkElem token ast] -> [StkElem token ast]
forall a. Int -> [a] -> [a]
revTakeRhs Int
rhsLength [StkElem token ast]
stack
let ast :: ast
ast = ParseFun token ast
builderFun [StkElem token ast]
rhsAst
let stack1 :: [StkElem token ast]
stack1 = Int -> [StkElem token ast] -> [StkElem token ast]
forall a. Int -> [a] -> [a]
drop (Int
rhsLengthInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2) [StkElem token ast]
stack
let topState :: Int
topState = [StkElem token ast] -> Int
forall token ast. Stack token ast -> Int
currentState [StkElem token ast]
stack1
let toState :: Int
toState =
case GotoTable -> Int -> String -> Maybe Int
lookupGotoTable GotoTable
gotoTbl Int
topState String
lhs of
Just Int
state -> Int
state
Maybe Int
Nothing -> ParseError token ast -> Int
forall a e. Exception e => e -> a
throw (Int
-> String
-> [StkElem token ast]
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
Int
-> String
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
NotFoundGoto Int
topState String
lhs [StkElem token ast]
stack ActionTable
actionTbl GotoTable
gotoTbl ProdRules
prodRules [Terminal token]
terminalList)
let stack2 :: [StkElem token ast]
stack2 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Maybe ast -> String -> StkElem token ast
forall token ast. Maybe ast -> String -> StkElem token ast
StkNonterminal (ast -> Maybe ast
forall a. a -> Maybe a
Just ast
ast) String
lhs) [StkElem token ast]
stack1
let stack3 :: [StkElem token ast]
stack3 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
toState) [StkElem token ast]
stack2
[Terminal token] -> [StkElem token ast] -> IO ast
run [Terminal token]
terminalList [StkElem token ast]
stack3
debug :: Bool -> String -> IO ()
debug :: Bool -> String -> IO ()
debug Bool
flag String
msg = if Bool
flag then String -> IO ()
putStrLn String
msg else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
prlevel :: Int -> String
prlevel Int
n = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n (let spaces :: String
spaces = Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: String
spaces in String
spaces)
data Candidate =
TerminalSymbol String
| NonterminalSymbol String
deriving Candidate -> Candidate -> Bool
(Candidate -> Candidate -> Bool)
-> (Candidate -> Candidate -> Bool) -> Eq Candidate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Candidate -> Candidate -> Bool
$c/= :: Candidate -> Candidate -> Bool
== :: Candidate -> Candidate -> Bool
$c== :: Candidate -> Candidate -> Bool
Eq
instance Show Candidate where
showsPrec :: Int -> Candidate -> ShowS
showsPrec Int
p (TerminalSymbol String
s) = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"Terminal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
showsPrec Int
p (NonterminalSymbol String
s) = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"Nonterminal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
data Automaton token ast =
Automaton {
Automaton token ast -> ActionTable
actTbl :: ActionTable,
Automaton token ast -> GotoTable
gotoTbl :: GotoTable,
Automaton token ast -> ProdRules
prodRules :: ProdRules
}
data CompCandidates token ast = CompCandidates {
CompCandidates token ast -> Bool
cc_debugFlag :: Bool,
CompCandidates token ast -> Int
cc_searchMaxLevel :: Int,
CompCandidates token ast -> Bool
cc_simpleOrNested :: Bool,
CompCandidates token ast -> Automaton token ast
cc_automaton :: Automaton token ast
}
compCandidates
:: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> IO [[Candidate]]
compCandidates :: CompCandidates token ast
-> Int -> [Candidate] -> Int -> Stack token ast -> IO [[Candidate]]
compCandidates CompCandidates token ast
ccOption Int
level [Candidate]
symbols Int
state Stack token ast
stk = do
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs CompCandidates token ast
ccOption Int
level [Candidate]
symbols Int
state Stack token ast
stk []
compGammasDfs
:: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs :: CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs CompCandidates token ast
ccOption Int
level [Candidate]
symbols Int
state Stack token ast
stk [(Int, Stack token ast, String)]
history =
let flag :: Bool
flag = CompCandidates token ast -> Bool
forall token ast. CompCandidates token ast -> Bool
cc_debugFlag CompCandidates token ast
ccOption
maxLevel :: Int
maxLevel = CompCandidates token ast -> Int
forall token ast. CompCandidates token ast -> Int
cc_searchMaxLevel CompCandidates token ast
ccOption
isSimple :: Bool
isSimple = CompCandidates token ast -> Bool
forall token ast. CompCandidates token ast -> Bool
cc_simpleOrNested CompCandidates token ast
ccOption
automaton :: Automaton token ast
automaton = CompCandidates token ast -> Automaton token ast
forall token ast. CompCandidates token ast -> Automaton token ast
cc_automaton CompCandidates token ast
ccOption
actionTable :: ActionTable
actionTable = Automaton token ast -> ActionTable
forall token ast. Automaton token ast -> ActionTable
actTbl Automaton token ast
automaton
gotoTable :: GotoTable
gotoTable = Automaton token ast -> GotoTable
forall token ast. Automaton token ast -> GotoTable
gotoTbl Automaton token ast
automaton
productionRules :: ProdRules
productionRules = Automaton token ast -> ProdRules
forall token ast. Automaton token ast -> ProdRules
prodRules Automaton token ast
automaton
in
if Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLevel then
[[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return (if [Candidate] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Candidate]
symbols then [] else [[Candidate]
symbols])
else
Bool
-> Bool
-> Int
-> Int
-> Stack token ast
-> String
-> [(Int, Stack token ast, String)]
-> ([(Int, Stack token ast, String)] -> IO [[Candidate]])
-> IO [[Candidate]]
forall a token ast a.
(Eq a, TokenInterface token, Show a) =>
Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
flag Bool
False Int
level Int
state Stack token ast
stk String
"" [(Int, Stack token ast, String)]
history
(\[(Int, Stack token ast, String)]
history ->
case [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int
prnum | ((Int
s,String
lookahead),Reduce Int
prnum) <- ActionTable
actionTable, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
s] of
[] ->
case [(String, Int)] -> [(String, Int)]
forall a. Eq a => [a] -> [a]
nub [(String
nonterminal,Int
toState) | ((Int
fromState,String
nonterminal),Int
toState) <- GotoTable
gotoTable, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
fromState] of
[] ->
if [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool
True | ((Int
s,String
lookahead),Action
Accept) <- ActionTable
actionTable, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
s] Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
then do
[[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else let cand2 :: [(String, Int)]
cand2 = [(String, Int)] -> [(String, Int)]
forall a. Eq a => [a] -> [a]
nub [(String
terminal,Int
snext) | ((Int
s,String
terminal),Shift Int
snext) <- ActionTable
actionTable, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
s] in
let len :: Int
len = [(String, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Int)]
cand2 in
case [(String, Int)]
cand2 of
[] -> [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[(String, Int)]
_ -> do [[[Candidate]]]
listOfList <-
(((String, Int), Integer) -> IO [[Candidate]])
-> [((String, Int), Integer)] -> IO [[[Candidate]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ ((String
terminal,Int
snext),Integer
i)->
let stk1 :: Stack token ast
stk1 = StkElem token ast -> Stack token ast -> Stack token ast
forall a. a -> [a] -> [a]
push (Terminal token -> StkElem token ast
forall token ast. Terminal token -> StkElem token ast
StkTerminal (String -> Int -> Int -> Maybe token -> Terminal token
forall token.
TokenInterface token =>
String -> Int -> Int -> Maybe token -> Terminal token
Terminal String
terminal Int
0 Int
0 Maybe token
forall a. Maybe a
Nothing)) Stack token ast
stk
stk2 :: Stack token ast
stk2 = StkElem token ast -> Stack token ast -> Stack token ast
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
snext) Stack token ast
stk1
in
Bool
-> Bool
-> Int
-> Int
-> Stack token ast
-> String
-> [(Int, Stack token ast, String)]
-> ([(Int, Stack token ast, String)] -> IO [[Candidate]])
-> IO [[Candidate]]
forall a token ast a.
(Eq a, TokenInterface token, Show a) =>
Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
flag Bool
True Int
level Int
snext Stack token ast
stk2 String
terminal [(Int, Stack token ast, String)]
history
(\[(Int, Stack token ast, String)]
history1 -> do
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"SHIFT [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
terminal String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
snext
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Goto/Shift symbols: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show ([Candidate]
symbols[Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++[String -> Candidate
TerminalSymbol String
terminal])
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stk2
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs CompCandidates token ast
ccOption (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ([Candidate]
symbols[Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++[String -> Candidate
TerminalSymbol String
terminal]) Int
snext Stack token ast
stk2 [(Int, Stack token ast, String)]
history1) )
([(String, Int)] -> [Integer] -> [((String, Int), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(String, Int)]
cand2 [Integer
1..])
[[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Candidate]] -> IO [[Candidate]])
-> [[Candidate]] -> IO [[Candidate]]
forall a b. (a -> b) -> a -> b
$ [[[Candidate]]] -> [[Candidate]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Candidate]]]
listOfList
[(String, Int)]
nontermStateList -> do
let len :: Int
len = [(String, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Int)]
nontermStateList
[[[Candidate]]]
listOfList <-
(((String, Int), Integer) -> IO [[Candidate]])
-> [((String, Int), Integer)] -> IO [[[Candidate]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ ((String
nonterminal,Int
snext),Integer
i) ->
let stk1 :: Stack token ast
stk1 = StkElem token ast -> Stack token ast -> Stack token ast
forall a. a -> [a] -> [a]
push (Maybe ast -> String -> StkElem token ast
forall token ast. Maybe ast -> String -> StkElem token ast
StkNonterminal Maybe ast
forall a. Maybe a
Nothing String
nonterminal) Stack token ast
stk
stk2 :: Stack token ast
stk2 = StkElem token ast -> Stack token ast -> Stack token ast
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
snext) Stack token ast
stk1
in
Bool
-> Bool
-> Int
-> Int
-> Stack token ast
-> String
-> [(Int, Stack token ast, String)]
-> ([(Int, Stack token ast, String)] -> IO [[Candidate]])
-> IO [[Candidate]]
forall a token ast a.
(Eq a, TokenInterface token, Show a) =>
Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
flag Bool
True Int
level Int
snext Stack token ast
stk2 String
nonterminal [(Int, Stack token ast, String)]
history
(\[(Int, Stack token ast, String)]
history1 -> do
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"GOTO [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] at "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
nonterminal String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
snext
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Goto/Shift symbols:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show ([Candidate]
symbols[Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++[String -> Candidate
NonterminalSymbol String
nonterminal])
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stk2
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs CompCandidates token ast
ccOption (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ([Candidate]
symbols[Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++[String -> Candidate
NonterminalSymbol String
nonterminal]) Int
snext Stack token ast
stk2 [(Int, Stack token ast, String)]
history1) )
([(String, Int)] -> [Integer] -> [((String, Int), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(String, Int)]
nontermStateList [Integer
1..])
[[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Candidate]] -> IO [[Candidate]])
-> [[Candidate]] -> IO [[Candidate]]
forall a b. (a -> b) -> a -> b
$ [[[Candidate]]] -> [[Candidate]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Candidate]]]
listOfList
[Int]
prnumList -> do
let len :: Int
len = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
prnumList
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"# of prNumList to reduce: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" at State " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProdRules -> String
forall a. Show a => a -> String
show [ ProdRules
productionRules ProdRules -> Int -> (String, [String])
forall a. [a] -> Int -> a
!! Int
prnum | Int
prnum <- [Int]
prnumList ]
do [[[Candidate]]]
listOfList <-
((Int, Integer) -> IO [[Candidate]])
-> [(Int, Integer)] -> IO [[[Candidate]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (Int
prnum,Integer
i) -> (
Bool
-> Bool
-> Int
-> Int
-> Stack token ast
-> String
-> [(Int, Stack token ast, String)]
-> ([(Int, Stack token ast, String)] -> IO [[Candidate]])
-> IO [[Candidate]]
forall a token ast a.
(Eq a, TokenInterface token, Show a) =>
Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
flag Bool
True Int
level Int
state Stack token ast
stk (Int -> String
forall a. Show a => a -> String
show Int
prnum) [(Int, Stack token ast, String)]
history
(\[(Int, Stack token ast, String)]
history1 -> do
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"State " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"REDUCE" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" prod #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
prnum
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String, [String]) -> String
forall a. Show a => a -> String
show (ProdRules
productionRules ProdRules -> Int -> (String, [String])
forall a. [a] -> Int -> a
!! Int
prnum)
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Goto/Shift symbols: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show [Candidate]
symbols
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stk
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> Int
-> IO [[Candidate]]
forall token ast p.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
CompCandidates token ast
-> Int
-> [Candidate]
-> p
-> [StkElem token ast]
-> [(Int, [StkElem token ast], String)]
-> Int
-> IO [[Candidate]]
compGammasDfsForReduce CompCandidates token ast
ccOption Int
level [Candidate]
symbols Int
state Stack token ast
stk [(Int, Stack token ast, String)]
history1 Int
prnum)) )
([Int] -> [Integer] -> [(Int, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
prnumList [Integer
1..])
[[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Candidate]] -> IO [[Candidate]])
-> [[Candidate]] -> IO [[Candidate]]
forall a b. (a -> b) -> a -> b
$ [[[Candidate]]] -> [[Candidate]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Candidate]]]
listOfList )
compGammasDfsForReduce :: CompCandidates token ast
-> Int
-> [Candidate]
-> p
-> [StkElem token ast]
-> [(Int, [StkElem token ast], String)]
-> Int
-> IO [[Candidate]]
compGammasDfsForReduce CompCandidates token ast
ccOption Int
level [Candidate]
symbols p
state [StkElem token ast]
stk [(Int, [StkElem token ast], String)]
history Int
prnum =
let flag :: Bool
flag = CompCandidates token ast -> Bool
forall token ast. CompCandidates token ast -> Bool
cc_debugFlag CompCandidates token ast
ccOption
maxLevel :: Int
maxLevel = CompCandidates token ast -> Int
forall token ast. CompCandidates token ast -> Int
cc_searchMaxLevel CompCandidates token ast
ccOption
isSimple :: Bool
isSimple = CompCandidates token ast -> Bool
forall token ast. CompCandidates token ast -> Bool
cc_simpleOrNested CompCandidates token ast
ccOption
automaton :: Automaton token ast
automaton = CompCandidates token ast -> Automaton token ast
forall token ast. CompCandidates token ast -> Automaton token ast
cc_automaton CompCandidates token ast
ccOption
actionTable :: ActionTable
actionTable = Automaton token ast -> ActionTable
forall token ast. Automaton token ast -> ActionTable
actTbl Automaton token ast
automaton
gotoTable :: GotoTable
gotoTable = Automaton token ast -> GotoTable
forall token ast. Automaton token ast -> GotoTable
gotoTbl Automaton token ast
automaton
productionRules :: ProdRules
productionRules = Automaton token ast -> ProdRules
forall token ast. Automaton token ast -> ProdRules
prodRules Automaton token ast
automaton
in
let prodrule :: (String, [String])
prodrule = ProdRules
productionRules ProdRules -> Int -> (String, [String])
forall a. [a] -> Int -> a
!! Int
prnum
lhs :: String
lhs = (String, [String]) -> String
forall a b. (a, b) -> a
fst (String, [String])
prodrule
rhs :: [String]
rhs = (String, [String]) -> [String]
forall a b. (a, b) -> b
snd (String, [String])
prodrule
rhsLength :: Int
rhsLength = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
rhs
in
if ( (Int
rhsLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Candidate] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Candidate]
symbols) ) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False
then do
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"[LEN COND: False] length rhs > length symbols: NOT "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
rhsLength String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Candidate] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Candidate]
symbols)
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show [Candidate]
symbols
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level
[[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
let stk1 :: [StkElem token ast]
stk1 = Int -> [StkElem token ast] -> [StkElem token ast]
forall a. Int -> [a] -> [a]
drop (Int
rhsLengthInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2) [StkElem token ast]
stk
let topState :: Int
topState = [StkElem token ast] -> Int
forall token ast. Stack token ast -> Int
currentState [StkElem token ast]
stk1
let toState :: Int
toState =
case GotoTable -> Int -> String -> Maybe Int
lookupGotoTable GotoTable
gotoTable Int
topState String
lhs of
Just Int
state -> Int
state
Maybe Int
Nothing -> String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"[compGammasDfsForReduce] Must not happen: lhs: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lhs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" state: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
topState
let stk2 :: [StkElem token ast]
stk2 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Maybe ast -> String -> StkElem token ast
forall token ast. Maybe ast -> String -> StkElem token ast
StkNonterminal Maybe ast
forall a. Maybe a
Nothing String
lhs) [StkElem token ast]
stk1
let stk3 :: [StkElem token ast]
stk3 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
toState) [StkElem token ast]
stk2
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"GOTO after REDUCE: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
topState String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lhs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
toState
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Goto/Shift symbols: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"[]"
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [StkElem token ast] -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack [StkElem token ast]
stk3
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Found a gamma: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show [Candidate]
symbols
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
if Bool
isSimple
then [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return (if [Candidate] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Candidate]
symbols then [] else [[Candidate]
symbols])
else do [[Candidate]]
listOfList <- CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> [StkElem token ast]
-> [(Int, [StkElem token ast], String)]
-> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs CompCandidates token ast
ccOption (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [] Int
toState [StkElem token ast]
stk3 [(Int, [StkElem token ast], String)]
history
[[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return (if [Candidate] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Candidate]
symbols then [[Candidate]]
listOfList else ([Candidate]
symbols [Candidate] -> [[Candidate]] -> [[Candidate]]
forall a. a -> [a] -> [a]
: ([Candidate] -> [Candidate]) -> [[Candidate]] -> [[Candidate]]
forall a b. (a -> b) -> [a] -> [b]
map ([Candidate]
symbols [Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++) [[Candidate]]
listOfList))
noCycleCheck :: Bool
noCycleCheck :: Bool
noCycleCheck = Bool
True
checkCycle :: Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
debugflag Bool
flag Int
level a
state [StkElem token ast]
stk String
action [(a, [StkElem token ast], String)]
history [(a, [StkElem token ast], String)] -> IO [a]
cont =
if Bool
flag Bool -> Bool -> Bool
&& (a
state,[StkElem token ast]
stk,String
action) (a, [StkElem token ast], String)
-> [(a, [StkElem token ast], String)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(a, [StkElem token ast], String)]
history
then do
Bool -> String -> IO ()
debug Bool
debugflag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"CYCLE is detected !!"
Bool -> String -> IO ()
debug Bool
debugflag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
state String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
action
Bool -> String -> IO ()
debug Bool
debugflag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ [StkElem token ast] -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack [StkElem token ast]
stk
Bool -> String -> IO ()
debug Bool
debugflag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
[a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else [(a, [StkElem token ast], String)] -> IO [a]
cont ( (a
state,[StkElem token ast]
stk,String
action) (a, [StkElem token ast], String)
-> [(a, [StkElem token ast], String)]
-> [(a, [StkElem token ast], String)]
forall a. a -> [a] -> [a]
: [(a, [StkElem token ast], String)]
history )
successfullyParsed :: IO [EmacsDataItem]
successfullyParsed :: IO [EmacsDataItem]
successfullyParsed = [EmacsDataItem] -> IO [EmacsDataItem]
forall (m :: * -> *) a. Monad m => a -> m a
return [EmacsDataItem
SynCompInterface.SuccessfullyParsed]
handleLexError :: IO [EmacsDataItem]
handleLexError :: IO [EmacsDataItem]
handleLexError = [EmacsDataItem] -> IO [EmacsDataItem]
forall (m :: * -> *) a. Monad m => a -> m a
return [EmacsDataItem
SynCompInterface.LexError]
data HandleParseError token = HandleParseError {
HandleParseError token -> Bool
debugFlag :: Bool,
HandleParseError token -> Int
searchMaxLevel :: Int,
HandleParseError token -> Bool
simpleOrNested :: Bool,
HandleParseError token -> [Terminal token]
postTerminalList :: [Terminal token],
HandleParseError token -> Maybe ShowS
nonterminalToStringMaybe :: Maybe (String->String)
}
handleParseError :: TokenInterface token => HandleParseError token -> ParseError token ast -> IO [EmacsDataItem]
handleParseError :: HandleParseError token
-> ParseError token ast -> IO [EmacsDataItem]
handleParseError HandleParseError token
hpeOption ParseError token ast
parseError = HandleParseError token
-> ParseError token ast -> IO [EmacsDataItem]
forall token token ast.
TokenInterface token =>
HandleParseError token
-> ParseError token ast -> IO [EmacsDataItem]
unwrapParseError HandleParseError token
hpeOption ParseError token ast
parseError
unwrapParseError :: HandleParseError token
-> ParseError token ast -> IO [EmacsDataItem]
unwrapParseError HandleParseError token
hpeOption (NotFoundAction Terminal token
_ Int
state Stack token ast
stk ActionTable
_actTbl GotoTable
_gotoTbl ProdRules
_prodRules [Terminal token]
terminalList) = do
let automaton :: Automaton token ast
automaton = Automaton :: forall token ast.
ActionTable -> GotoTable -> ProdRules -> Automaton token ast
Automaton {actTbl :: ActionTable
actTbl=ActionTable
_actTbl, gotoTbl :: GotoTable
gotoTbl=GotoTable
_gotoTbl, prodRules :: ProdRules
prodRules=ProdRules
_prodRules}
HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
forall token ast token token.
(Typeable token, Typeable ast, Show token, Show ast,
TokenInterface token, TokenInterface token,
TokenInterface token) =>
HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
arrivedAtTheEndOfSymbol HandleParseError token
hpeOption Int
state Stack token ast
stk Automaton token ast
automaton [Terminal token]
terminalList
unwrapParseError HandleParseError token
hpeOption (NotFoundGoto Int
state String
_ Stack token ast
stk ActionTable
_actTbl GotoTable
_gotoTbl ProdRules
_prodRules [Terminal token]
terminalList) = do
let automaton :: Automaton token ast
automaton = Automaton :: forall token ast.
ActionTable -> GotoTable -> ProdRules -> Automaton token ast
Automaton {actTbl :: ActionTable
actTbl=ActionTable
_actTbl, gotoTbl :: GotoTable
gotoTbl=GotoTable
_gotoTbl, prodRules :: ProdRules
prodRules=ProdRules
_prodRules}
HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
forall token ast token token.
(Typeable token, Typeable ast, Show token, Show ast,
TokenInterface token, TokenInterface token,
TokenInterface token) =>
HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
arrivedAtTheEndOfSymbol HandleParseError token
hpeOption Int
state Stack token ast
stk Automaton token ast
automaton [Terminal token]
terminalList
arrivedAtTheEndOfSymbol :: HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
arrivedAtTheEndOfSymbol HandleParseError token
hpeOption Int
state Stack token ast
stk Automaton token ast
automaton [Terminal token]
terminalList = do
if [Terminal token] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Terminal token]
terminalList Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then do
HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> IO [EmacsDataItem]
forall token ast token.
(Typeable token, Typeable ast, Show token, Show ast,
TokenInterface token, TokenInterface token) =>
HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> IO [EmacsDataItem]
_handleParseError HandleParseError token
hpeOption Int
state Stack token ast
stk Automaton token ast
automaton
else do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"length terminalList /= 1 : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Terminal token] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Terminal token]
terminalList)
(Terminal token -> IO ()) -> [Terminal token] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Terminal token
t -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString (Terminal token -> String) -> Terminal token -> String
forall a b. (a -> b) -> a -> b
$ Terminal token
t) [Terminal token]
terminalList
[EmacsDataItem] -> IO [EmacsDataItem]
forall (m :: * -> *) a. Monad m => a -> m a
return [[String] -> EmacsDataItem
SynCompInterface.ParseError ((Terminal token -> String) -> [Terminal token] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString [Terminal token]
terminalList)]
_handleParseError :: HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> IO [EmacsDataItem]
_handleParseError
(hpeOption :: HandleParseError token
hpeOption @ HandleParseError {
debugFlag :: forall token. HandleParseError token -> Bool
debugFlag=Bool
flag,
searchMaxLevel :: forall token. HandleParseError token -> Int
searchMaxLevel=Int
maxLevel,
simpleOrNested :: forall token. HandleParseError token -> Bool
simpleOrNested=Bool
isSimple,
postTerminalList :: forall token. HandleParseError token -> [Terminal token]
postTerminalList=[Terminal token]
terminalListAfterCursor,
nonterminalToStringMaybe :: forall token. HandleParseError token -> Maybe ShowS
nonterminalToStringMaybe=Maybe ShowS
_nonterminalToStringMaybe})
Int
state Stack token ast
stk Automaton token ast
automaton = do
let ccOption :: CompCandidates token ast
ccOption = CompCandidates :: forall token ast.
Bool
-> Int -> Bool -> Automaton token ast -> CompCandidates token ast
CompCandidates {
cc_debugFlag :: Bool
cc_debugFlag=Bool
flag,
cc_searchMaxLevel :: Int
cc_searchMaxLevel=Int
maxLevel,
cc_simpleOrNested :: Bool
cc_simpleOrNested=Bool
isSimple,
cc_automaton :: Automaton token ast
cc_automaton=Automaton token ast
automaton }
[[Candidate]]
candidateListList <- CompCandidates token ast
-> Int -> [Candidate] -> Int -> Stack token ast -> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
Show ast) =>
CompCandidates token ast
-> Int -> [Candidate] -> Int -> Stack token ast -> IO [[Candidate]]
compCandidates CompCandidates token ast
ccOption Int
0 [] Int
state Stack token ast
stk
let colorListList_symbols :: [[EmacsColorCandidate]]
colorListList_symbols =
[ [Candidate] -> [Terminal token] -> [EmacsColorCandidate]
forall token.
TokenInterface token =>
[Candidate] -> [Terminal token] -> [EmacsColorCandidate]
filterCandidates [Candidate]
candidateList [Terminal token]
terminalListAfterCursor
| [Candidate]
candidateList <- [[Candidate]]
candidateListList ]
let convFun :: ShowS
convFun =
case Maybe ShowS
_nonterminalToStringMaybe of
Maybe ShowS
Nothing -> \String
s -> String
"..."
Just ShowS
fn -> ShowS
fn
let colorListList_ :: [[EmacsColor]]
colorListList_ = ([EmacsColorCandidate] -> [EmacsColor])
-> [[EmacsColorCandidate]] -> [[EmacsColor]]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS -> [EmacsColorCandidate] -> [EmacsColor]
stringfyCandidates ShowS
convFun) [[EmacsColorCandidate]]
colorListList_symbols
let colorListList :: [[EmacsColor]]
colorListList = ([EmacsColor] -> [EmacsColor]) -> [[EmacsColor]] -> [[EmacsColor]]
forall a b. (a -> b) -> [a] -> [b]
map [EmacsColor] -> [EmacsColor]
collapseCandidates [[EmacsColor]]
colorListList_
let strList :: [String]
strList = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [ [String] -> String
concatStrList [String]
strList | [String]
strList <- ([EmacsColor] -> [String]) -> [[EmacsColor]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ((EmacsColor -> String) -> [EmacsColor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map EmacsColor -> String
showEmacsColor) [[EmacsColor]]
colorListList ]
let rawStrListList :: [[String]]
rawStrListList = [[String]] -> [[String]]
forall a. Eq a => [a] -> [a]
nub [ [String]
strList | [String]
strList <- ([EmacsColor] -> [String]) -> [[EmacsColor]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ((EmacsColor -> String) -> [EmacsColor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map EmacsColor -> String
showRawEmacsColor) [[EmacsColor]]
colorListList ]
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
showConcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([EmacsColorCandidate] -> String)
-> [[EmacsColorCandidate]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\[EmacsColorCandidate]
x -> ([EmacsColorCandidate] -> String
forall a. Show a => a -> String
show [EmacsColorCandidate]
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")) [[EmacsColorCandidate]]
colorListList_symbols
Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
showConcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\[String]
x -> ([String] -> String
forall a. Show a => a -> String
show [String]
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")) [[String]]
rawStrListList
[EmacsDataItem] -> IO [EmacsDataItem]
forall (m :: * -> *) a. Monad m => a -> m a
return ([EmacsDataItem] -> IO [EmacsDataItem])
-> [EmacsDataItem] -> IO [EmacsDataItem]
forall a b. (a -> b) -> a -> b
$ (String -> EmacsDataItem) -> [String] -> [EmacsDataItem]
forall a b. (a -> b) -> [a] -> [b]
map String -> EmacsDataItem
Candidate [String]
strList
where
showConcat :: [String] -> String
showConcat [] = String
""
showConcat (String
s:[String]
ss) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
showConcat [String]
ss
data EmacsColor =
Gray String Line Column
| White String
deriving (Int -> EmacsColor -> ShowS
[EmacsColor] -> ShowS
EmacsColor -> String
(Int -> EmacsColor -> ShowS)
-> (EmacsColor -> String)
-> ([EmacsColor] -> ShowS)
-> Show EmacsColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmacsColor] -> ShowS
$cshowList :: [EmacsColor] -> ShowS
show :: EmacsColor -> String
$cshow :: EmacsColor -> String
showsPrec :: Int -> EmacsColor -> ShowS
$cshowsPrec :: Int -> EmacsColor -> ShowS
Show, EmacsColor -> EmacsColor -> Bool
(EmacsColor -> EmacsColor -> Bool)
-> (EmacsColor -> EmacsColor -> Bool) -> Eq EmacsColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmacsColor -> EmacsColor -> Bool
$c/= :: EmacsColor -> EmacsColor -> Bool
== :: EmacsColor -> EmacsColor -> Bool
$c== :: EmacsColor -> EmacsColor -> Bool
Eq)
data EmacsColorCandidate =
GrayCandidate Candidate Line Column
| WhiteCandidate Candidate
deriving EmacsColorCandidate -> EmacsColorCandidate -> Bool
(EmacsColorCandidate -> EmacsColorCandidate -> Bool)
-> (EmacsColorCandidate -> EmacsColorCandidate -> Bool)
-> Eq EmacsColorCandidate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmacsColorCandidate -> EmacsColorCandidate -> Bool
$c/= :: EmacsColorCandidate -> EmacsColorCandidate -> Bool
== :: EmacsColorCandidate -> EmacsColorCandidate -> Bool
$c== :: EmacsColorCandidate -> EmacsColorCandidate -> Bool
Eq
instance Show EmacsColorCandidate where
showsPrec :: Int -> EmacsColorCandidate -> ShowS
showsPrec Int
p (GrayCandidate Candidate
c Int
lin Int
col) = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"Gray " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Candidate -> String
forall a. Show a => a -> String
show Candidate
c
showsPrec Int
p (WhiteCandidate Candidate
c) = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"White " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Candidate -> String
forall a. Show a => a -> String
show Candidate
c
filterCandidates :: (TokenInterface token) => [Candidate] -> [Terminal token] -> [EmacsColorCandidate]
filterCandidates :: [Candidate] -> [Terminal token] -> [EmacsColorCandidate]
filterCandidates [Candidate]
candidates [Terminal token]
terminalListAfterCursor =
[Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
forall token.
TokenInterface token =>
[Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f [Candidate]
candidates [Terminal token]
terminalListAfterCursor []
where
f :: [Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f (Candidate
a:[Candidate]
alpha) (Terminal token
b:[Terminal token]
beta) [EmacsColorCandidate]
accm
| Candidate -> Terminal token -> Bool
forall token. Candidate -> Terminal token -> Bool
equal Candidate
a Terminal token
b = [Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f [Candidate]
alpha [Terminal token]
beta (Candidate -> Int -> Int -> EmacsColorCandidate
GrayCandidate Candidate
a (Terminal token -> Int
forall token. TokenInterface token => Terminal token -> Int
terminalToLine Terminal token
b) (Terminal token -> Int
forall token. TokenInterface token => Terminal token -> Int
terminalToCol Terminal token
b) EmacsColorCandidate
-> [EmacsColorCandidate] -> [EmacsColorCandidate]
forall a. a -> [a] -> [a]
: [EmacsColorCandidate]
accm)
| Bool
otherwise = [Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f [Candidate]
alpha (Terminal token
bTerminal token -> [Terminal token] -> [Terminal token]
forall a. a -> [a] -> [a]
:[Terminal token]
beta) (Candidate -> EmacsColorCandidate
WhiteCandidate Candidate
a EmacsColorCandidate
-> [EmacsColorCandidate] -> [EmacsColorCandidate]
forall a. a -> [a] -> [a]
: [EmacsColorCandidate]
accm)
f [] [Terminal token]
beta [EmacsColorCandidate]
accm = [EmacsColorCandidate] -> [EmacsColorCandidate]
forall a. [a] -> [a]
reverse [EmacsColorCandidate]
accm
f (Candidate
a:[Candidate]
alpha) [] [EmacsColorCandidate]
accm = [Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f [Candidate]
alpha [] (Candidate -> EmacsColorCandidate
WhiteCandidate Candidate
a EmacsColorCandidate
-> [EmacsColorCandidate] -> [EmacsColorCandidate]
forall a. a -> [a] -> [a]
: [EmacsColorCandidate]
accm)
equal :: Candidate -> Terminal token -> Bool
equal (TerminalSymbol String
s1) (Terminal String
s2 Int
_ Int
_ Maybe token
_) = String
s1String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
s2
equal (NonterminalSymbol String
s1) Terminal token
_ = Bool
False
stringfyCandidates :: (String -> String) -> [EmacsColorCandidate] -> [EmacsColor]
stringfyCandidates :: ShowS -> [EmacsColorCandidate] -> [EmacsColor]
stringfyCandidates ShowS
convFun [EmacsColorCandidate]
candidates = (EmacsColorCandidate -> EmacsColor)
-> [EmacsColorCandidate] -> [EmacsColor]
forall a b. (a -> b) -> [a] -> [b]
map EmacsColorCandidate -> EmacsColor
stringfyCandidate [EmacsColorCandidate]
candidates
where
stringfyCandidate :: EmacsColorCandidate -> EmacsColor
stringfyCandidate (GrayCandidate Candidate
sym Int
line Int
col) = String -> Int -> Int -> EmacsColor
Gray (Candidate -> String
strCandidate Candidate
sym) Int
line Int
col
stringfyCandidate (WhiteCandidate Candidate
sym) = String -> EmacsColor
White (Candidate -> String
strCandidate Candidate
sym)
strCandidate :: Candidate -> String
strCandidate (TerminalSymbol String
s) = String
s
strCandidate (NonterminalSymbol String
s) = ShowS
convFun String
s
collapseCandidates :: [EmacsColor] -> [EmacsColor]
collapseCandidates [] = []
collapseCandidates [EmacsColor
a] = [EmacsColor
a]
collapseCandidates ((Gray String
"..." Int
l1 Int
c1) : (Gray String
"..." Int
l2 Int
c2) : [EmacsColor]
cs) =
[EmacsColor] -> [EmacsColor]
collapseCandidates ((String -> Int -> Int -> EmacsColor
Gray String
"..." Int
l2 Int
c2) EmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
: [EmacsColor]
cs)
collapseCandidates ((White String
"...") : (White String
"...") : [EmacsColor]
cs) =
[EmacsColor] -> [EmacsColor]
collapseCandidates ((String -> EmacsColor
White String
"...") EmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
: [EmacsColor]
cs)
collapseCandidates (EmacsColor
a:EmacsColor
b:[EmacsColor]
cs) = EmacsColor
a EmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
: [EmacsColor] -> [EmacsColor]
collapseCandidates (EmacsColor
bEmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
:[EmacsColor]
cs)
showSymbol :: Candidate -> String
showSymbol (TerminalSymbol String
s) = String
s
showSymbol (NonterminalSymbol String
_) = String
"..."
showRawSymbol :: Candidate -> String
showRawSymbol (TerminalSymbol String
s) = String
s
showRawSymbol (NonterminalSymbol String
s) = String
s
showEmacsColor :: EmacsColor -> String
showEmacsColor (Gray String
s Int
line Int
col) = String
"gray " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
showEmacsColor (White String
s) = String
"white " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
showRawEmacsColor :: EmacsColor -> String
showRawEmacsColor (Gray String
s Int
line Int
col) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"@" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
showRawEmacsColor (White String
s) = String
s
concatStrList :: [String] -> String
concatStrList [] = String
""
concatStrList [String
str] = String
str
concatStrList (String
str:[String]
strs) = String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
concatStrList [String]
strs