yapb-0.2: src/parserlib/algo/SynCompAlgoPEPM.hs
module SynCompAlgoPEPM (compCandidates) where
import AutomatonType
import Config
import Terminal
import TokenInterface
import CommonParserUtil
import SynCompAlgoUtil
import Data.Typeable
import Data.List (nub)
-- |
compCandidates
:: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> IO ([[Candidate]], Bool)
compCandidates ccOption level symbols state stk =
let flag = cc_debugFlag ccOption in
debug flag "" $
debug flag "[compCandidates] " $
debug flag (" - state: " ++ show state) $
debug flag (" - stack: " ++ prStack stk) $
debug flag "" $
do cands <- compGammasDfs ccOption level symbols state stk []
-- do extendedCompCandidates ccOption symbols state stk
maybeConfig <- readConfig
case maybeConfig of
Nothing -> return (cands, True) -- Display is set to True???
Just config -> return (cands, config_DISPLAY config)
-- |
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 ccOption level symbols state stk history =
let flag = cc_debugFlag ccOption
maxLevel = cc_maxLevel ccOption
printLevel = cc_printLevel ccOption
isSimple = cc_simpleOrNested ccOption
automaton = cc_automaton ccOption
actionTable = actTbl automaton
gotoTable = gotoTbl automaton
productionRules = prodRules automaton
in
if level > maxLevel then
let result_symbols = if null symbols then [] else [symbols] in
debug flag (prlevel level ++ "maxlevel reached.") $
debug flag (prlevel level ++ " - " ++ show result_symbols) $
do return result_symbols
else
checkCycle flag False level state stk "" history
(\history ->
{- 1. Reduce -}
case nub [prnum | ((s,lookahead),Reduce prnum) <- actionTable, state==s, isReducible productionRules prnum stk] of
[] ->
{- 2. Goto table -}
debug flag (prlevel level ++ "no reduce: " ++ show state) $
case nub [(nonterminal,toState) | ((fromState,nonterminal),toState) <- gotoTable, state==fromState] of
[] ->
debug flag (prlevel level ++ "no goto: " ++ show state) $
{- 3. Accept -}
if length [True | ((s,lookahead),Accept) <- actionTable, state==s] >= 1
then
debug flag (prlevel level ++ "accept: " ++ show state) $
return []
{- 4. Shift -}
else let cand2 = nub [(terminal,snext) | ((s,terminal),Shift snext) <- actionTable, state==s] in
let len = length cand2 in
case cand2 of
[] ->
debug flag (prlevel level ++ "no shift: " ++ show state) $
return []
_ -> do listOfList <-
mapM (\ ((terminal,snext),i)->
let stk1 = push (StkTerminal (Terminal terminal 0 0 Nothing)) stk in -- Todo: ??? (toToken terminal)
let stk2 = push (StkState snext) stk1 in
debug flag (prlevel level ++ "SHIFT [" ++ show i ++ "/" ++ show len ++ "]: "
++ show state ++ " -> " ++ terminal ++ " -> " ++ show snext) $
debug flag (prlevel level ++ " - " ++ "Stack " ++ prStack stk2) $
debug flag (prlevel level ++ " - " ++ "Symbols: " ++ show (symbols++[TerminalSymbol terminal])) $
debug flag "" $
checkCycle flag True level snext stk2 terminal history
(\history1 ->
compGammasDfs ccOption (level+1) (symbols++[TerminalSymbol terminal]) snext stk2 history1) )
(zip cand2 [1..])
return $ concat listOfList
nontermStateList -> do
let len = length nontermStateList
listOfList <-
mapM (\ ((nonterminal,snext),i) ->
let stk1 = push (StkNonterminal Nothing nonterminal) stk
stk2 = push (StkState snext) stk1
in
-- checkCycle False level snext stk2 ("GOTO " ++ show snext ++ " " ++ nonterminal) history
-- checkCycle True level state stk nonterminal history
checkCycle flag True level snext stk2 nonterminal history
(\history1 ->
debug flag (prlevel level ++ "GOTO [" ++ show i ++ "/" ++ show len ++ "] at "
++ show state ++ " -> " ++ show nonterminal ++ " -> " ++ show snext) $
debug flag (prlevel level ++ " - " ++ "Stack " ++ prStack stk2) $
debug flag (prlevel level ++ " - " ++ "Symbols:" ++ show (symbols++[NonterminalSymbol nonterminal])) $
debug flag "" $
compGammasDfs ccOption (level+1) (symbols++[NonterminalSymbol nonterminal]) snext stk2 history1) )
(zip nontermStateList [1..])
return $ concat listOfList
prnumList ->
let len = length prnumList in
debug flag (prlevel level ++ "# of prNumList to reduce: " ++ show len ++ " at State " ++ show state) $
debug flag (prlevel (level+1) ++ show [ productionRules !! prnum | prnum <- prnumList ]) $
do listOfList <-
mapM (\ (prnum,i) -> (
-- checkCycle False level state stk ("REDUCE " ++ show prnum) history
checkCycle flag True level state stk (show prnum) history
(\history1 ->
debug flag (prlevel level ++ "REDUCE" ++
"[" ++ show i ++ "/" ++ show len ++ "] at " ++
show state ++ " " ++
showProductionRule (productionRules !! prnum)) $
-- debug flag (prlevel level ++ " - prod rule: " ++ show (productionRules !! prnum)) $
-- debug flag (prlevel level ++ " - State " ++ show state) $
debug flag (prlevel level ++ " - Stack " ++ prStack stk) $
debug flag (prlevel level ++ " - Symbols: " ++ show symbols) $
debug flag "" $
compGammasDfsForReduce ccOption level symbols state stk history1 prnum)) )
(zip prnumList [1..])
return $ concat listOfList )
compGammasDfsForReduce ccOption level symbols state stk history prnum =
let flag = cc_debugFlag ccOption
isSimple = cc_simpleOrNested ccOption
automaton = cc_automaton ccOption
prodrule = (prodRules automaton) !! prnum
lhs = fst prodrule
rhs = snd prodrule
rhsLength = length rhs
in
if ( {- rhsLength == 0 || -} (rhsLength > length symbols) ) == False
then
debug flag (prlevel level ++ "[LEN COND: False] length rhs > length symbols: NOT "
++ show rhsLength ++ ">" ++ show (length symbols)) $
debug flag ("rhs: " ++ show rhs) $
debug flag ("symbols: " ++ show symbols) $
return [] -- Todo: (if null symbols then [] else [symbols])
else -- reducible
let stk1 = drop (rhsLength*2) stk in
let topState = currentState stk1 in
let toState =
case lookupGotoTable (gotoTbl automaton) topState lhs of
Just state -> state
Nothing -> error $ "[compGammasDfsForReduce] Must not happen: lhs: "
++ lhs ++ " state: " ++ show topState
in
let stk2 = push (StkNonterminal Nothing lhs) stk1 in -- ast
let stk3 = push (StkState toState) stk2 in
debug flag (prlevel level ++ " - GOTO : "
++ show topState ++ " " ++ lhs ++ " " ++ show toState) $
debug flag (prlevel level ++ " --- Stack " ++ prStack stk3) $
debug flag "" $
debug flag (prlevel level ++ "Found a gamma: " ++ show symbols) $
debug flag "" $
if isSimple && not (null symbols) -- Todo: loosley simple mode: + && not (null symbols)
then return (if null symbols then [] else [symbols])
else do listOfList <- compGammasDfs ccOption (level+1) [] toState stk3 history
return (if null symbols then listOfList else (symbols : map (symbols ++) listOfList))