module SynCompAlgoBUTreeNested (compCandidates) where import AutomatonType import Terminal import TokenInterface import CommonParserUtil import SynCompAlgoUtil import Config import Data.Typeable import Data.List (nub) import Control.DeepSeq -- 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) -------------------------------------------------------------------------------- -- A new search algorithm -------------------------------------------------------------------------------- -- 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 maybeConfig <- readConfig let (newCcOption, newDisplay) = case maybeConfig of Nothing -> (ccOption, 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 (ccOption', display) let debugFlag = cc_debugFlag newCcOption let isSimple = cc_simpleOrNested newCcOption let r_level = cc_r_level newCcOption let gs_level = cc_gs_level newCcOption debug debugFlag ("simple(True)/nested(False): " ++ show isSimple) (debug debugFlag ("(Max) r level: " ++ show r_level) (debug debugFlag ("(Max) gs level: " ++ show gs_level) (debug debugFlag "" $ do (succContList,_) <- extendedNestedCandidates newCcOption [(state, stk, symbols)] return (map (\(a,b,c)->c) succContList, newDisplay) ))) -- where -- extendedCompCandidates' ccOption symbols state stk = -- let -- debugFlag = cc_debugFlag newCcOption -- isSimple = cc_simpleOrNested newCcOption -- r_level = cc_r_level newCcOption -- gs_level = cc_gs_level newCcOption -- in -- debug debugFlag ("simple(True)/nested(False): " ++ show isSimple) $ -- debug debugFlag ("(Max) r level: " ++ show r_level) $ -- debug debugFlag ("(Max) gs level: " ++ show gs_level) $ -- debug debugFlag "" $ -- do if isSimple -- then error $ "[SynCompAlgoBUTreeNested] Simple mode not supported" -- else do extendedNestedCandidates newCcOption [(state, stk, symbols)] type SuccContList token ast = [(State, Stack token ast, [CandidateTree])] type FailContList token ast = [(State, Stack token ast, [CandidateTree])] -- Extended nested candidates extendedNestedCandidates :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => CompCandidates token ast -> [(State, Stack token ast, [CandidateTree])] -> IO (SuccContList token ast, FailContList token ast) extendedNestedCandidates ccOption initStateStkCandsList = let debugFlag = cc_debugFlag ccOption r_level = cc_r_level ccOption -- simpleRepReduce (state, stk, symbols) = -- debug debugFlag "Given " $ -- debug debugFlag (" - state " ++ show state) $ -- debug debugFlag (" - stack " ++ prStack stk) $ -- debug debugFlag (" - cand " ++ show symbols) $ -- debug debugFlag (" - search " ++ show (cc_searchState ccOption)) $ -- debug debugFlag "" $ -- do repReduce ccOption{cc_simpleOrNested=True} symbols state stk in if r_level > 0 then debug debugFlag ("[Extended Nested Candidates] : " ++ show r_level) $ multiDbg (map (\(state, stk, cand) -> debug debugFlag (" - state " ++ show state) $ debug debugFlag (" - stack " ++ prStack stk) $ debug debugFlag (" - cand " ++ show cand) $ debug debugFlag "" ) initStateStkCandsList) $ do succFailContListList <- mapM (\(state, stk, symbols) -> debug debugFlag "Given " $ debug debugFlag (" - state " ++ show state) $ debug debugFlag (" - stack " ++ prStack stk) $ debug debugFlag (" - cand " ++ show symbols) $ debug debugFlag "" $ do (succContList, failContList) <- repReduce ccOption{cc_simpleOrNested=True} symbols state stk return (succContList, failContList) ) initStateStkCandsList if null succFailContListList then return ([], []) else do let succContListList = map fst succFailContListList let failContListList = map snd succFailContListList nextSuccFailContListList <- mapM (extendedNestedCandidates ccOption{cc_r_level=r_level-1}) failContListList let nextSuccContListList = map fst nextSuccFailContListList let nextFailContListList = map snd nextSuccFailContListList return ( concat succContListList ++ concat nextSuccContListList , concat nextFailContListList ) else return ([], []) repReduce :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => CompCandidates token ast -> [CandidateTree] -> State -> Stack token ast -> IO (SuccContList token ast, FailContList token ast) 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) $ debug flag (prlevel level ++ " - FOUND: " ++ show symbols) $ return ([], []) -- Todo: succCont is [(state,stk,symbols)], and failCont is [] ?? else do case nub [prnum | ((s,lookahead),Reduce prnum) <- actionTable , state==s , isReducible productionRules prnum stk] of [] -> if isFinalReduce (cc_searchState ccOption) then return ([], [(state,stk,symbols)]) else repGotoOrShift (ccOption {cc_searchState = SS_GotoOrShift (r_level (cc_searchState ccOption)) (gs_level (cc_searchState ccOption)) }) symbols state stk prnumList -> do let len = length prnumList succFailListOfList <- mapM (\ (prnum, i) -> do let searchState = cc_searchState ccOption -- SS_InitReduces if isInitReduces searchState then do (list2,failCont2) <- repGotoOrShift (ccOption {cc_searchState = SS_GotoOrShift (r_level (cc_searchState ccOption)) (gs_level (cc_searchState ccOption)) }) symbols state stk (list1,failCont1) <- simulReduce ccOption symbols prnum len i state stk return $ (list2 ++ list1, failCont2 ++ failCont1) -- 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 (concatMap fst succFailListOfList, concatMap snd succFailListOfList) 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 (SuccContList token ast, FailContList token ast) 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 len_leafs_symbols = length (leafs symbols) len_symbols = length symbols 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 ++ " - Stack " ++ prStack stk) $ debug flag (prlevel level ++ " - Symbols: " ++ show symbols) $ debug flag "" $ if isFinalReduce searchState then -- Todo: Sometime (>) is correct sometimes (>=) is correct! -- if rhsLength >= length (leafs symbols) && {- length symbols > 0 && -} length (leafs symbols) > 0 if rhsLength >= len_leafs_symbols && len_leafs_symbols > 0 -- if rhsLength >= len_symbols && len_symbols > 0 then 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) debug flag (prlevel level ++ " - FOUND: " ++ show symbols) $ debug flag "" $ -- Note: toState and stk3 are after the reduction, but symbols are not!! return ([(toState,stk3,reducedSymbols)], [(toState,stk3,reducedSymbols)]) 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) -- repReduce ccOption {cc_printLevel=level+1} reducedSymbols toState stk3 return ([], [(toState,stk3,reducedSymbols)]) -- Todo: refactoring 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, failCont) <- 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) : -} {- Todo: ??? map (f symbols) -} listOfList , failCont) -- Q: symbols: 필요? else if isFinalReduce searchState then do return ([], [(state,stk,symbols)]) -- 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 return ([],[(toState,stk3,reducedSymbols)]) -- Todo: symbols vs reducedSymbols??? simulGoto :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => CompCandidates token ast -> [CandidateTree] -> Int -> [StkElem token ast] -> IO (SuccContList token ast, FailContList token ast) 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 ([], [(state,stk,symbols)]) nontermStateList -> do let len = length nontermStateList succFailContListList <- mapM (\ ((nonterminal,snext),i) -> if null symbols -- I do not want any nonterminal to be the first symbol! then return ([], [(snext,stk,symbols)]) -- Todo: failContList ??? else 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++[candidateLeaf (NonterminalSymbol nonterminal)])) $ -- debug flag (prlevel level ++ " - Search state: " ++ show (cc_searchState ccOption)) $ debug flag "" $ repGotoOrShift ccOption{cc_printLevel=level+1} (symbols++[candidateLeaf (NonterminalSymbol nonterminal)]) snext stk2) (zip nontermStateList [1..]) let succContListList = concatMap fst succFailContListList let failContListList = concatMap snd succFailContListList return (succContListList, failContListList) simulShift :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => CompCandidates token ast -> [CandidateTree] -> Int -> [StkElem token ast] -> IO (SuccContList token ast, FailContList token ast) 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 ([], [(state, stk, symbols)]) _ -> do succFailListOfList <- 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++[candidateLeaf (TerminalSymbol terminal)])) $ -- debug flag (prlevel level ++ " - Search state: " ++ show (cc_searchState ccOption)) $ debug flag "" $ repGotoOrShift ccOption{cc_printLevel=level+1} (symbols++[candidateLeaf (TerminalSymbol terminal)]) snext stk2) (zip cand2 [1..]) return $ (concatMap fst succFailListOfList, concatMap snd succFailListOfList) repGotoOrShift :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => CompCandidates token ast -> [CandidateTree] -> State -> Stack token ast -> IO (SuccContList token ast, FailContList token ast) repGotoOrShift 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 ++ "[repGotoOrShift] " ++ show (cc_searchState ccOption) if null [True | ((s,lookahead),Accept) <- actionTable, state==s] == False then debug flag (prlevel level ++ "accept: " ++ show state) $ return ([], [(state, stk, symbols)]) else do (listOfList1, failCont1) <- repReduce (ccOption{cc_searchState= SS_FinalReduce (r_level (cc_searchState ccOption)) (gs_level (cc_searchState ccOption))}) symbols state stk if null listOfList1 -- || isInitReduces (cc_searchState ccOption) then if gs_level (cc_searchState ccOption) > 0 then -- Todo: -1 ??? let ccOption' = ccOption{cc_searchState= SS_GotoOrShift (r_level (cc_searchState ccOption)) (gs_level (cc_searchState ccOption) - 1)} 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 -- return $ listOfList1 ++ listOfList2 ++ listOfList3 -- else let isInnerMostLevel = True -- r_level (cc_searchState ccOption) == cc_r_level ccOption simulFirst = if isInnerMostLevel then simulShift else simulGoto simulSecond = if isInnerMostLevel then simulGoto else simulShift in do (listOfList2, failCont2) <- simulFirst ccOption' symbols state stk -- Shift first Goto Next! if null listOfList2 then do (listOfList3, failCont3) <- simulSecond ccOption' symbols state stk return $ ( listOfList1 ++ listOfList2 ++ listOfList3 , failCont1 ++ failCont2 ++ failCont3 ) else return $ (listOfList1 ++ listOfList2, failCont1 ++ failCont2) else return (listOfList1, failCont1) -- Q: symbols or [] else do return (listOfList1, failCont1)