yapb-0.2: src/parserlib/algo/SynCompAlgoTD.hs
module SynCompAlgoTD (compCandidates) where
import AutomatonType
import Terminal
import TokenInterface
import CommonParserUtil
import SynCompAlgoUtil
import Config
import Data.Typeable
import Data.List (nub)
-- | Computing candidates
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 "" $
-- compGammasDfs ccOption level symbols state stk []
do let symbolTrees = map candidateLeaf symbols
(candForestList,bool) <- extendedCompCandidates ccOption symbolTrees state stk
return (map leafs candForestList, bool)
--
type State = Int
type LengthOfSymbols = Int
--
extendedCompCandidates
:: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
CompCandidates token ast -> [CandidateTree] -> State -> Stack token ast -> IO ([[CandidateTree]], Bool)
extendedCompCandidates ccOption symbols state stk = do
-- check yapb.config
maybeConfig <- readConfig
case maybeConfig of
Nothing ->
do list <- extendedCompCandidates' ccOption symbols state stk
return (map (\(a,b,c)->c) list, True)
Just config ->
let r_level = config_R_LEVEL config
gs_level = config_GS_LEVEL config
debugFlag = config_DEBUG config
display = config_DISPLAY config
isSimple = config_SIMPLE config
ccOption' = ccOption { cc_debugFlag = debugFlag
, cc_r_level = r_level
, cc_gs_level = gs_level
, cc_simpleOrNested = isSimple
, cc_searchState = initSearchState r_level gs_level
}
in
do list <- extendedCompCandidates' ccOption' symbols state stk
return (map (\(a,b,c)->c) list, display)
where
-- main function
extendedCompCandidates' ccOption symbols state stk =
let
debugFlag = cc_debugFlag ccOption
isSimple = cc_simpleOrNested ccOption
r_level = cc_r_level ccOption
gs_level = cc_gs_level ccOption
in
debug debugFlag ("simple/nested(True/False): " ++ show isSimple) $
debug debugFlag ("(Max) r level: " ++ show r_level) $
debug debugFlag ("(Max) gs level: " ++ show gs_level) $
debug debugFlag "" $
-- do list <- if isSimple
-- then do repReduce ccOption symbols state stk
-- else do extendedNestedCandidates ccOption [(state, stk, symbols)]
-- return [ c | (state, stk, c) <- list, null c == False ]
do if isSimple
then do repReduce ccOption symbols state stk
else do extendedNestedCandidates ccOption [(state, stk, symbols)]
-- Extended simple candidates
-- extendedSimpleCandidates
-- :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
-- CompCandidates token ast -> State -> Stack token ast -> IO [(State, Stack token ast, [CandidateTree])]
-- extendedSimpleCandidates ccOption state stk = repReduce ccOption [] state stk
-- Extended nested candidates
extendedNestedCandidates
:: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
CompCandidates token ast -> [(State, Stack token ast, [CandidateTree])]
-> IO [(State, Stack token ast, [CandidateTree])]
extendedNestedCandidates ccOption initStateStkCandsList =
let debugFlag = cc_debugFlag ccOption
r_level = cc_r_level ccOption
level = cc_printLevel ccOption
len = length initStateStkCandsList
f ((state, stk, symbols),i) =
debug debugFlag (prlevel level ++ "[extendedNestedCandidates] : " ++ show i ++ "/" ++ show len) $
debug debugFlag (prlevel level ++ " - state " ++ show state) $
debug debugFlag (prlevel level ++ " - stack " ++ prStack stk) $
debug debugFlag (prlevel level ++ " - symbs " ++ show symbols) $
debug debugFlag "" $
do list <- repReduce ccOption{cc_simpleOrNested=True,cc_printLevel=level+1} [] state stk
return [ (state,stk,symbols++cands) | (state,stk,cands) <- list]
in
if r_level > 0
then
do stateStkCandsListList <- mapM f (zip initStateStkCandsList [1..])
-- if null stateStkCandsListList
-- then return initStateStkCandsList
-- else do nextStateStkCandsList <-
-- extendedNestedCandidates ccOption{cc_r_level=r_level-1}
-- [ (toState, toStk, {- fromCand ++ -} toCand)
-- | ((fromState, fromStk, fromCand), toList)
-- <- zip initStateStkCandsList stateStkCandsListList
-- , (toState, toStk, toCand) <- toList
-- ]
-- return $ {- initStateStkCandsList ++ -} nextStateStkCandsList
extendedNestedCandidates ccOption{cc_r_level=r_level-1} (concat stateStkCandsListList)
else
return initStateStkCandsList -- cf. []
repReduce
:: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
CompCandidates token ast -> [CandidateTree] -> State -> Stack token ast
-> IO [(State, Stack token ast, [CandidateTree])]
repReduce ccOption symbols state stk =
let flag = cc_debugFlag ccOption
level = cc_printLevel ccOption
isSimple = cc_simpleOrNested ccOption
automaton = cc_automaton ccOption
searchState = cc_searchState ccOption
actionTable = actTbl automaton
gotoTable = gotoTbl automaton
productionRules = prodRules automaton
in debug flag (prlevel level ++ "[repReduce] " ++ show (cc_searchState ccOption)) $
if null [True | ((s,lookahead),Accept) <- actionTable, state==s] == False
then
debug flag (prlevel level ++ "accept: " ++ show state) $
return []
else do
case nub [prnum | ((s,lookahead),Reduce prnum) <- actionTable
, state==s
, isReducible productionRules prnum stk] of
[] -> if isFinalReduce (cc_searchState ccOption)
then debug flag (prlevel level ++ "no Reduce (final search state): final " ++ show state) $
return []
else
repGotoOrShift False -- do not do repReduce in the beginning!
(setGotoOrShift (ccOption{cc_printLevel=level+1}))
-- (ccOption {cc_searchState =
-- SS_GotoOrShift
-- (r_level (cc_searchState ccOption))
-- (gs_level (cc_searchState ccOption)) })
symbols state stk
prnumList -> do let len = length prnumList
listOfList <-
mapM (\ (prnum, i) ->
do let searchState = cc_searchState ccOption
-- SS_InitReduces
if isInitReduces searchState then
do list2 <- repGotoOrShift True -- do repReduce since it is Init search state
(ccOption{cc_printLevel=level+1})
-- (ccOption {cc_searchState =
-- SS_GotoOrShift
-- (r_level (cc_searchState ccOption))
-- (gs_level (cc_searchState ccOption)) })
symbols state stk
list1 <- simulReduce ccOption symbols prnum len i state stk
return $ list2 ++ list1
-- SS_FinalReduce
else if isFinalReduce searchState then
do simulReduce ccOption symbols prnum len i state stk
-- SS_GotoOrShift: never reach here!
else
do error $ "repReduce: Unexpected search state: " ++ show searchState)
(zip prnumList [1..])
-- list2 <- if isFinalReduce (cc_searchState ccOption)
-- then do return []
-- else repGotoOrShift
-- (ccOption {cc_searchState =
-- SS_GotoOrShift
-- (r_level (cc_searchState ccOption))
-- (gs_level (cc_searchState ccOption)) })
-- symbols state stk
return $ concat listOfList
{- Called when Init or Final search states -}
simulReduce :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
CompCandidates token ast
-> [CandidateTree]
-> Int -- Production rule number
-> Int -- of all reducible actions
-> Int -- ith action chosen
-> State
-> Stack token ast
-> IO [(State, Stack token ast, [CandidateTree])]
simulReduce ccOption symbols prnum len i state stk =
let flag = cc_debugFlag ccOption
isSimple = cc_simpleOrNested ccOption
automaton = cc_automaton ccOption
searchState = cc_searchState ccOption
level = cc_printLevel ccOption
productionRules = prodRules automaton
prodrule = (prodRules automaton) !! prnum
lhs = fst prodrule
rhs = snd prodrule
rhsLength = length rhs
in
debug flag (prlevel level ++ "[simulReduce] " ++ show (cc_searchState ccOption)) $
debug flag (prlevel level ++ "REDUCE [" ++ show i ++ "/" ++ show len ++ "] " ++
"[" ++ show (cc_searchState ccOption) ++ "] " ++
"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 (prlevel level ++ " - Search state: " ++ show (cc_searchState ccOption)) $
debug flag "" $
if rhsLength > length symbols && length symbols > 0 -- This is the time to stop!
then
if isFinalReduce searchState
then
debug flag (prlevel level ++ "rhsLength > length symbols: final") $
debug flag "" $
do let stk1 = drop (rhsLength*2) stk
-- let children = toChildren $ reverse $ take (rhsLength*2) stk
-- [CandidateTree (NonterminalSymbol lhs) children]
let topState = currentState stk1
let toState = case lookupGotoTable (gotoTbl automaton) topState lhs of
Just state -> state
Nothing -> error $ "[simulReduce] Must not happen: lhs: "
++ lhs ++ " state: " ++ show topState
let stk2 = push (StkNonterminal Nothing lhs) stk1 -- ast
let stk3 = push (StkState toState) stk2
return [(toState, stk3, symbols)] -- Note: toState and stk3 are after the reduction, but symbols are not!!
else
repGotoOrShift False -- Todo: do not do repReduce because Reduce has just been done???
(ccOption{cc_printLevel=level+1})
-- (ccOption{cc_searchState =
-- SS_GotoOrShift
-- (r_level (cc_searchState ccOption))
-- (gs_level (cc_searchState ccOption)) })
symbols state stk
-- rhsLength <= length symbols || length symbols == 0
else do let stk1 = drop (rhsLength*2) stk
let topState = currentState stk1
let toState = case lookupGotoTable (gotoTbl automaton) topState lhs of
Just state -> state
Nothing -> error $ "[simulReduce] Must not happen: lhs: "
++ lhs ++ " state: " ++ show topState
let stk2 = push (StkNonterminal Nothing lhs) stk1 -- ast
let stk3 = push (StkState toState) stk2
let (reducedSymbols, gs) =
if rhsLength <= length symbols
then let revSymbols = reverse symbols
children = reverse (take rhsLength revSymbols)
therest = drop rhsLength $ revSymbols
in ( reverse $ (candidateNode (NonterminalSymbol lhs) children :) $ therest
, cc_gs_level ccOption + rhsLength - 1)
else (symbols, cc_gs_level ccOption)
if isSimple then -- simple mode
if isInitReduces searchState then -- reduces until symbols are found
do -- listOfList <- repReduce ccOption{cc_printLevel=level+1} reducedSymbols toState stk3
repReduce ccOption{cc_printLevel=level+1,cc_gs_level=gs} reducedSymbols toState stk3
-- let f syms0 (s, stk, syms) = (s, stk, syms0 ++ syms)
-- return (if null symbols
-- then listOfList
-- else {- (toState, stk3, symbols) : -} map (f symbols) listOfList) -- Q: symbols: 필요?
else if isFinalReduce searchState then -- Todo: isFinalReduce???
-- Todo(important): What would happen if it just returns []???
do repReduce ccOption{cc_printLevel=level+1} reducedSymbols toState stk3 -- Just copied the code above!
-- do return (if null symbols
-- then []
-- else [(toState, stk3, symbols)])
else -- SS_GotoOrShift
do error $ "simulReduce: Unexpected search state" ++ show searchState
else -- nested mode
do error $ "simulReduce: Unexpected nested mode: "
simulGoto :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
CompCandidates token ast
-> [CandidateTree]
-> Int
-> [StkElem token ast]
-> IO [(State, Stack token ast, [CandidateTree])]
simulGoto ccOption symbols state stk =
let flag = cc_debugFlag ccOption
level = cc_printLevel ccOption
isSimple = cc_simpleOrNested ccOption
automaton = cc_automaton ccOption
actionTable = actTbl automaton
gotoTable = gotoTbl automaton
productionRules = prodRules automaton
in do debug flag (prlevel level ++ "[simulGoto] " ++ show (cc_searchState ccOption)) $
case nub [ (nonterminal,toState)
| ((fromState,nonterminal),toState) <- gotoTable
, state==fromState ] of
[] -> do return []
nontermStateList ->
do
let len = length nontermStateList
listOfList <-
mapM (\ ((nonterminal,snext),i) ->
let stk1 = push (StkNonterminal Nothing nonterminal) stk in
let stk2 = push (StkState snext) stk1 in
debug flag (prlevel level ++ "GOTO [" ++ show i ++ "/" ++ show len ++ "] " ++
"[" ++ show (cc_searchState ccOption) ++ "] " ++
"at " ++ show state ++ " -> " ++ show nonterminal ++ " -> " ++ show snext) $
debug flag (prlevel level ++ " - " ++ "Stack " ++ prStack stk2) $
debug flag (prlevel level ++ " - " ++ "Symbols:" ++ show (symbols++[candidateNode (NonterminalSymbol nonterminal) []])) $
-- debug flag (prlevel level ++ " - Search state: " ++ show (cc_searchState ccOption)) $
debug flag "" $
repGotoOrShift True
(setGotoOrShift (ccOption{cc_printLevel=level+1}))
(symbols++[candidateNode (NonterminalSymbol nonterminal) []])
snext stk2)
(zip nontermStateList [1..])
return $ concat listOfList
simulShift :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
CompCandidates token ast
-> [CandidateTree]
-> Int
-> [StkElem token ast]
-> IO [(State, Stack token ast, [CandidateTree])]
simulShift ccOption symbols state stk =
let flag = cc_debugFlag ccOption
level = cc_printLevel ccOption
isSimple = cc_simpleOrNested ccOption
automaton = cc_automaton ccOption
actionTable = actTbl automaton
gotoTable = gotoTbl automaton
productionRules = prodRules automaton
in
let cand2 = nub [(terminal,snext) | ((s,terminal),Shift snext) <- actionTable, state==s]
len = length cand2
in do debug flag (prlevel level ++ "[simulShift] " ++ show (cc_searchState ccOption)) $
case cand2 of
[] -> do return []
_ -> do
listOfList <-
mapM (\ ((terminal,snext),i)->
let stk1 = push (StkTerminal (Terminal terminal 0 0 Nothing)) stk in
let stk2 = push (StkState snext) stk1 in
debug flag (prlevel level ++ "SHIFT [" ++ show i ++ "/" ++ show len ++ "] " ++
"[" ++ show (cc_searchState ccOption) ++ "] " ++
"at " ++ show state ++ " -> " ++ terminal ++ " -> " ++ show snext) $
debug flag (prlevel level ++ " - " ++ "Stack " ++ prStack stk2) $
debug flag (prlevel level ++ " - " ++ "Symbols: " ++ show (symbols++[candidateNode (TerminalSymbol terminal) []])) $
-- debug flag (prlevel level ++ " - Search state: " ++ show (cc_searchState ccOption)) $
debug flag "" $
repGotoOrShift True
(setGotoOrShift (ccOption{cc_printLevel=level+1}))
(symbols++[candidateNode (TerminalSymbol terminal) []])
snext stk2)
(zip cand2 [1..])
return $ concat listOfList
{- Search states are InitReduce or GotoOrShift! -}
repGotoOrShift
:: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
Bool -> -- True : do repReuce, False : skip repReduce!
CompCandidates token ast -> [CandidateTree] -> State -> Stack token ast -> IO [(State, Stack token ast, [CandidateTree])]
repGotoOrShift doRepReduce ccOption symbols state stk =
let flag = cc_debugFlag ccOption
level = cc_printLevel ccOption
isSimple = cc_simpleOrNested ccOption
automaton = cc_automaton ccOption
actionTable = actTbl automaton
gotoTable = gotoTbl automaton
productionRules = prodRules automaton
in
debug flag (prlevel level ++ "[repGotoOrShift] " ++ show doRepReduce ++ ":" ++ show (cc_searchState ccOption)) $
do if null [True | ((s,lookahead),Accept) <- actionTable, state==s] == False
then
debug flag (prlevel level ++ "accept: " ++ show state) $
return []
else do
listOfList1 <-
if doRepReduce
then repReduce
(ccOption{cc_printLevel = level+1,
cc_searchState=
SS_FinalReduce
(r_level (cc_searchState ccOption))
(gs_level (cc_searchState ccOption))})
symbols state stk
else return []
-- Idea: Once this is called, do Shift or Goto at least once whenever possible
-- by having the disjunct, isInitReduces (cc_searchState ccOption)!!
-- listOfList1 == [] && init reduce ==> do goto or shift
-- || listOfList1 == [] && goto or shift ==> do goto or shift
-- || listOfList1 /= [] && init reduce ==> do goto of shift (give a chance!)
-- || listOfList1 /= [] && goto or shift ==> No!!
if null listOfList1 == False && isInitReduces (cc_searchState ccOption)
|| null listOfList1 == True
then
-- let listOfList1 = []
if gs_level (cc_searchState ccOption) - 1 > 0 then
let ccOption' = ccOption{cc_searchState=
SS_GotoOrShift
(r_level (cc_searchState ccOption))
(gs_level (cc_searchState ccOption) - 1)}
-- Decrease the gs level by one!!
in
-- both goto and shift only once
if gs_level (cc_searchState ccOption) == cc_gs_level ccOption
then
do listOfList2 <- simulGoto ccOption' symbols state stk
listOfList3 <- simulShift ccOption' symbols state stk
debug flag (prlevel level ++ "[repGotoOrShift] (1) final") $
debug flag "" $
if null (listOfList1 ++ listOfList2 ++ listOfList3)
then return []
else return (listOfList1 ++ listOfList2 ++ listOfList3)
else
do listOfList2 <- simulGoto ccOption' symbols state stk
if null listOfList2
then
do listOfList3 <- simulShift ccOption' symbols state stk
debug flag (prlevel level ++ "[repGotoOrShift] (2) final") $
debug flag "" $
if null (listOfList1 ++ listOfList2 ++ listOfList3)
then return []
else return (listOfList1 ++ listOfList2 ++ listOfList3)
else
debug flag (prlevel level ++ "[repGotoOrShift] (3): final") $
debug flag "" $
if null (listOfList1 ++ listOfList2)
then return []
else return (listOfList1 ++ listOfList2)
else
debug flag (prlevel level ++ "gs_level == 0: final") $
debug flag (prlevel level) $
do return []
else
debug flag (prlevel level ++ "[repGotoOrShift] (4) final") $
debug flag "" $
do return listOfList1
-- Todo: repReduce를 하지 않고
-- Reduce 액션이 있는지 보고
-- 없으면 goto or shift 진행하고
-- 있으면 reduce한번하고 종료!
-- 현재 구현은 repReduce 결과가 널인지 검사해서 진행 또는 종료
-- Reduce 액션이 있어도 진행될 수 있음!