yapb-0.1.0: src/parserlib/CommonParserUtil.hs
{-# LANGUAGE GADTs #-}
module CommonParserUtil 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
-- Lexer Specification
type RegExpStr = String
type LexFun token = String -> Maybe token
type LexerSpecList token = [(RegExpStr, LexFun token)]
data LexerSpec token =
LexerSpec { endOfToken :: token,
lexerSpecList :: LexerSpecList token
}
-- Parser Specification
type ProdRuleStr = String
type ParseFun token ast = Stack token ast -> ast
type ParserSpecList token ast = [(ProdRuleStr, ParseFun token ast)]
data ParserSpec token ast =
ParserSpec { startSymbol :: String,
parserSpecList :: ParserSpecList token ast,
baseDir :: String, -- ex) ./
actionTblFile :: String, -- ex) actiontable.txt
gotoTblFile :: String, -- ex) gototable.txt
grammarFile :: String, -- ex) grammar.txt
parserSpecFile :: String, -- ex) mygrammar.grm
genparserexe :: String -- ex) yapb-exe
}
-- Specification
data Spec token ast =
Spec (LexerSpec token) (ParserSpec token ast)
--------------------------------------------------------------------------------
-- The lexing machine
--------------------------------------------------------------------------------
type Line = Int
type Column = Int
--
data LexError = LexError Int Int String -- Line, Col, Text
deriving (Typeable, Show)
instance Exception LexError
prLexError (LexError line col text) = do
putStr $ "No matching lexer spec at "
putStr $ "Line " ++ show line
putStr $ "Column " ++ show col
putStr $ " : "
putStr $ take 10 text
--
lexing :: TokenInterface token =>
LexerSpec token -> String -> IO [Terminal token]
lexing lexerspec text = lexing_ lexerspec 1 1 text
lexing_ :: TokenInterface token =>
LexerSpec token -> Line -> Column -> String -> IO [Terminal token]
lexing_ lexerspec line col [] = do
let eot = endOfToken lexerspec
return [Terminal (fromToken eot) line col eot]
lexing_ lexerspec line col text = do
(matchedText, theRestText, maybeTok) <-
matchLexSpec line col (lexerSpecList lexerspec) text
let (line_, col_) = moveLineCol line col matchedText
terminalList <- lexing_ lexerspec line_ col_ theRestText
case maybeTok of
Nothing -> return terminalList
Just tok -> do
let terminal = Terminal matchedText line col tok
return (terminal:terminalList)
matchLexSpec :: TokenInterface token =>
Line -> Column -> LexerSpecList token -> String
-> IO (String, String, Maybe token)
matchLexSpec line col [] text = do
throw (LexError line col text)
-- putStr $ "No matching lexer spec at "
-- putStr $ "Line " ++ show line
-- putStr $ "Column " ++ show col
-- putStr $ " : "
-- putStr $ take 10 text
-- exitWith (ExitFailure (-1))
matchLexSpec line col ((aSpec,tokenBuilder):lexerspec) text = do
let (pre, matched, post) = text =~ aSpec :: (String,String,String)
case pre of
"" -> return (matched, post, tokenBuilder matched)
_ -> matchLexSpec line col lexerspec text
moveLineCol :: Line -> Column -> String -> (Line, Column)
moveLineCol line col "" = (line, col)
moveLineCol line col ('\n':text) = moveLineCol (line+1) 1 text
moveLineCol line col (ch:text) = moveLineCol line (col+1) text
--------------------------------------------------------------------------------
-- The parsing machine
--------------------------------------------------------------------------------
--
data ParseError token ast where
-- teminal, state, stack actiontbl, gototbl
NotFoundAction :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
(Terminal token) -> Int -> (Stack token ast) -> ActionTable -> GotoTable -> ParseError token ast
-- topState, lhs, stack, actiontbl, gototbl,
NotFoundGoto :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
Int -> String -> (Stack token ast) -> ActionTable -> GotoTable -> ParseError token ast
deriving (Typeable)
instance (Show token, Show ast) => Show (ParseError token ast) where
showsPrec p (NotFoundAction terminal state stack _ _) =
(++) "NotFoundAction" . (++) (terminalToString terminal) . (++) (show state) -- . (++) (show stack)
showsPrec p (NotFoundGoto topstate lhs stack _ _) =
(++) "NotFoundGoto" . (++) (show topstate) . (++) lhs -- . (++) (show stack)
instance (TokenInterface token, Typeable token, Show token, Typeable ast, Show ast)
=> Exception (ParseError token ast)
prParseError (NotFoundAction terminal state stack actiontbl gototbl) = do
putStrLn $
("Not found in the action table: "
++ terminalToString terminal)
++ " : "
++ show (state, tokenTextFromTerminal terminal)
++ "\n" ++ prStack stack ++ "\n"
prParseError (NotFoundGoto topState lhs stack actiontbl gototbl) = do
putStrLn $
("Not found in the goto table: ")
++ " : "
++ show (topState,lhs) ++ "\n"
++ prStack stack ++ "\n"
--
parsing :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
ParserSpec token ast -> [Terminal token] -> IO ast
parsing parserSpec terminalList = do
-- 1. Save the production rules in the parser spec (Parser.hs).
writtenBool <- saveProdRules specFileName sSym pSpecList
-- 2. If the grammar file is written,
-- run the following command to generate prod_rules/action_table/goto_table files.
-- stack exec -- genlrparser-exe mygrammar.grm -output prod_rules.txt action_table.txt goto_table.txt
when writtenBool generateAutomaton
-- 3. Load automaton files (prod_rules/action_table/goto_table.txt)
(actionTbl, gotoTbl, prodRules) <-
loadAutomaton grammarFileName actionTblFileName gotoTblFileName
-- 4. Run the automaton
ast <- runAutomaton actionTbl gotoTbl prodRules pFunList terminalList
-- putStrLn "done." -- It was for the interafce with Java-version RPC calculus interpreter.
return ast
where
specFileName = parserSpecFile parserSpec
grammarFileName = grammarFile parserSpec
actionTblFileName = actionTblFile parserSpec
gotoTblFileName = gotoTblFile parserSpec
executable = genparserexe parserSpec
sSym = startSymbol parserSpec
pSpecList = map fst (parserSpecList parserSpec)
pFunList = map snd (parserSpecList parserSpec)
generateAutomaton = do
exitCode <- rawSystem "stack"
[ "exec", "--",
executable, specFileName, "-output",
grammarFileName, actionTblFileName, gotoTblFileName
]
case exitCode of
ExitFailure code -> exitWith exitCode
ExitSuccess -> putStrLn ("Successfully generated: " ++
actionTblFileName ++ ", " ++
gotoTblFileName ++ ", " ++
grammarFileName);
-- Stack
data StkElem token ast =
StkState Int
| StkTerminal (Terminal token)
| StkNonterminal ast String -- String for printing Nonterminal instead of ast
type Stack token ast = [StkElem token ast]
emptyStack = []
get :: Stack token ast -> Int -> ast
get stack i =
case stack !! (i-1) of
StkNonterminal ast _ -> ast
_ -> error $ "get: out of bound: " ++ show i
getText :: Stack token ast -> Int -> String
getText stack i =
case stack !! (i-1) of
StkTerminal (Terminal text _ _ _) -> text
_ -> error $ "getText: out of bound: " ++ show i
push :: a -> [a] -> [a]
push elem stack = elem:stack
pop :: [a] -> (a, [a])
pop (elem:stack) = (elem, stack)
pop [] = error "Attempt to pop from the empty stack"
prStack :: TokenInterface token => Stack token ast -> String
prStack [] = "end"
prStack (StkState i : stack) = "S" ++ show i ++ " : " ++ prStack stack
prStack (StkTerminal (Terminal text _ _ token) : stack) =
fromToken token ++ "(" ++ text ++ ")" ++ " : " ++ prStack stack
prStack (StkNonterminal ast str : stack) = str ++ " : " ++ prStack stack
-- Utility for Automation
currentState :: Stack token ast -> Int
currentState (StkState i : stack) = i
currentState _ = error "No state found in the stack top"
tokenTextFromTerminal :: TokenInterface token => Terminal token -> String
tokenTextFromTerminal (Terminal _ _ _ token) = fromToken token
lookupActionTable :: TokenInterface token => ActionTable -> Int -> (Terminal token) -> Maybe Action
lookupActionTable actionTbl state terminal =
lookupTable actionTbl (state,tokenTextFromTerminal terminal)
("Not found in the action table: " ++ terminalToString terminal)
lookupGotoTable :: GotoTable -> Int -> String -> Maybe Int
lookupGotoTable gotoTbl state nonterminalStr =
lookupTable gotoTbl (state,nonterminalStr)
("Not found in the goto table: ")
lookupTable :: (Eq a, Show a) => [(a,b)] -> a -> String -> Maybe b
lookupTable tbl key msg =
case [ val | (key', val) <- tbl, key==key' ] of
[] -> Nothing -- error $ msg ++ " : " ++ show key
(h:_) -> Just h
-- Note: take 1th, 3rd, 5th, ... of 2*len elements from stack and reverse it!
-- example) revTakeRhs 2 [a1,a2,a3,a4,a5,a6,...]
-- = [a4, a2]
revTakeRhs :: Int -> [a] -> [a]
revTakeRhs 0 stack = []
revTakeRhs n (_:nt:stack) = revTakeRhs (n-1) stack ++ [nt]
-- Automaton
runAutomaton :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
{- static part -}
ActionTable -> GotoTable -> ProdRules -> [ParseFun token ast] ->
{- dynamic part -}
[Terminal token] ->
{- AST -}
IO ast
runAutomaton actionTbl gotoTbl prodRules pFunList terminalList = do
let initStack = push (StkState 0) emptyStack
run terminalList initStack
where
{- run :: TokenInterface token => [Terminal token] -> Stack token ast -> IO ast -}
run terminalList stack = do
let state = currentState stack
let terminal = head terminalList
let text = tokenTextFromTerminal terminal
let action =
case lookupActionTable actionTbl state terminal of
Just action -> action
Nothing -> throw (NotFoundAction terminal state stack actionTbl gotoTbl)
-- error $ ("Not found in the action table: "
-- ++ terminalToString terminal)
-- ++ " : "
-- ++ show (state, tokenTextFromTerminal terminal)
-- ++ "\n" ++ prStack stack ++ "\n"
debug ("\nState " ++ show state)
debug ("Token " ++ text)
debug ("Stack " ++ prStack stack)
case action of
Accept -> do
debug "Accept"
case stack !! 1 of
StkNonterminal ast _ -> return ast
_ -> fail "Not Stknontermianl on Accept"
Shift toState -> do
debug ("Shift " ++ show toState)
let stack1 = push (StkTerminal (head terminalList)) stack
let stack2 = push (StkState toState) stack1
run (tail terminalList) stack2
Reduce n -> do
debug ("Reduce " ++ show n)
let prodrule = prodRules !! n
debug ("\t" ++ show prodrule)
let builderFun = pFunList !! n
let lhs = fst prodrule
let rhsLength = length (snd prodrule)
let rhsAst = revTakeRhs rhsLength stack
let ast = builderFun rhsAst
let stack1 = drop (rhsLength*2) stack
let topState = currentState stack1
let toState =
case lookupGotoTable gotoTbl topState lhs of
Just state -> state
Nothing -> throw (NotFoundGoto topState lhs stack actionTbl gotoTbl)
-- error $ ("Not found in the goto table: ")
-- ++ " : "
-- ++ show (topState,lhs) ++ "\n"
-- ++ prStack stack ++ "\n"
let stack2 = push (StkNonterminal ast lhs) stack1
let stack3 = push (StkState toState) stack2
run terminalList stack3
flag = False
debug :: String -> IO ()
debug msg = if flag then putStrLn msg else return ()
--
data Candidate =
TerminalSymbol String
| NonterminalSymbol String
deriving Show
compCandidates :: [Candidate] -> Int -> ActionTable -> GotoTable -> IO [[Candidate]]
compCandidates symbols state actTbl gotoTbl = do
putStrLn (show symbols)
case [(lookahead,prnum) | ((s,lookahead),Reduce prnum) <- actTbl, state==s] of
[] -> do let cand1 = [(nonterminal,snext) | ((s,nonterminal),snext) <- gotoTbl, state==s]
let cand2 = [(terminal,snext) | ((s,terminal),Shift snext) <- actTbl, state==s]
if null cand1
then
do listOfList <-
mapM (\(terminal,snext)-> do
putStrLn $ "state " ++ show state ++
": shift to " ++ show snext ++
" on " ++ terminal
compCandidates
(symbols++[TerminalSymbol terminal]) snext actTbl gotoTbl) cand2
return $ concat listOfList
else
do listOfList <-
mapM (\(nonterminal,snext)-> do
putStrLn $ "state " ++ show state ++
": go to " ++ show snext ++
" on " ++ nonterminal
compCandidates
(symbols++[NonterminalSymbol nonterminal]) snext actTbl gotoTbl) cand1
return $ concat listOfList
l -> do putStrLn $ "state " ++ show state ++
": found reduce prodrule #" ++ show (snd (head l)) ++
" on " ++ fst (head l)
putStrLn $ "CANDIDATE: " ++ show [symbols]
return [symbols]