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 액션이 있어도 진행될 수 있음!