-------------------------------------------------------------------------------- -- An LR Parser Table Generator -- -- Copyright(c) 2013 Kwanghoon Choi. All rights reserved. -- -- Usage: -- $ ghci GenLRParserTable -- *Main> prParseTable (calcLR1ParseTable g1) -- *Main> prLALRParseTable (calcLALRParseTable g1) -- -- * let (items,_,lkhtbl,gotos) = calcLR0ParseTable g1 -- in do { prItems items; prGtTbl gotos; prLkhTable lkhtbl } -- -- * closure g4 [Item (ProductionRule "S'" [Nonterminal "S"]) 0 [Symbol (Terminal "")]] -------------------------------------------------------------------------------- module GenLRParserTable where import Data.List import Data.Maybe import System.Environment (getArgs) import CFG import ParserTable import CmdArgs import System.IO {- 가능한 명령 인자 형식 $ main.exe rpc.grm $ main.exe rpc.grm smallbasic.grm (grm 파일이 둘 이상이면 -output 옵션을 사용 불가) $ main.exe rpc.grm -output prod_rules.txt action_table.txt goto_table.txt $ main.exe -output prod_rules.txt action_table.txt goto_table.txt rpc.grm -} _main = do args <- getArgs -- mapM_ putStrLn args let cmd = getCmd args case cmd of CmdError msg -> putStrLn msg CmdGrmFiles fileNames -> mapM_ (f stdout) fileNames CmdGrmWithOption (Just fileName) prod_rule action_tbl goto_tbl -> do writeParseTable fileName prod_rule action_tbl goto_tbl putStrLn "Done" where f h file = do grammar <- readFile file -- putStrLn grammar let cfg = read grammar :: CFG prParseTable stdout $ (\(a1,a2,a3,a4,a5)->(a1,a2,a3,a4)) (calcEfficientLALRParseTable cfg) writeParseTable file prod_rule action_tbl goto_tbl = do grammar <- readFile file let cfg = read grammar :: CFG let (items, prules, actTbl, gtTbl) = (\(a1,a2,a3,a4,a5)->(a1,a2,a3,a4)) (calcEfficientLALRParseTable cfg) h_pr <- openFile prod_rule WriteMode h_acttbl <- openFile action_tbl WriteMode h_gototbl <- openFile goto_tbl WriteMode prPrules h_pr prules prActTbl h_acttbl actTbl prGtTbl h_gototbl gtTbl hClose h_pr hClose h_acttbl hClose h_gototbl __main g = do prParseTable stdout $ (\(a1,a2,a3,a4,a5)->(a1,a2,a3,a4)) (calcEfficientLALRParseTable g) -- __mainDebug g = do -- let (_,_,_,_,(items,lkhtbl1,splk',lkhtbl2,gotos)) = calcEfficientLALRParseTable g -- let kernelitems = map (filter (isKernel (startNonterminal g))) items -- prItems items -- prGtTbl gotos -- prItems kernelitems -- putStrLn "closure with #" -- let f (i, x,y) = do { putStrLn (show i ++ " : " ++ show x); prItem y; putStrLn "" } -- mapM_ f $ [ (index, item, closure g [Item prule dot [sharpSymbol]]) -- | (index,items) <- zip [0..] kernelitems -- , item@(Item prule dot _) <- items ] -- putStrLn "Splk'" -- prSplk' splk' -- putStrLn "Splk:" -- prSpontaneous lkhtbl1 -- putStrLn "Prop:" -- prPropagate lkhtbl2 -- putStrLn "" -- prItems (computeLookaheads lkhtbl1 lkhtbl2 kernelitems) prSplk' [] = return () prSplk' ((index0,index2,item0,item0closure,item1,item2):splk') = do putStrLn "item0:" putStrLn (show index0) putStrLn (show item0) putStrLn "closure(item0,#):" prItem stdout item0closure putStrLn "item1:" putStrLn (show item1) putStrLn (show index2) putStrLn "item2:" putStrLn (show item2) ch <- getChar prSplk' splk' __mainLr1 g = do prParseTable stdout (calcLR1ParseTable g) __mainLalr1 g = do prLALRParseTable stdout (calcLALRParseTable g) -- indexPrule :: AUGCFG -> ProductionRule -> Int indexPrule augCfg prule = indexPrule' prules prule 0 where CFG _ prules = augCfg indexPrule' [] prule n = error ("indexPrule: not found " ++ show prule) indexPrule' (r:rs) prule n = if r == prule then n else indexPrule' rs prule (n+1) prPrules h ps = prPrules' h ps 0 prPrules' h [] n = return () prPrules' h (prule:prules) n = do hPutStrLn h (show n ++ ": " ++ show prule) prPrules' h prules (n+1) -------------------------------------------------------------------------------- -- Utility -------------------------------------------------------------------------------- symbols :: CFG -> [Symbol] symbols (CFG start prules) = [Nonterminal x | Nonterminal x <- syms] ++ [Terminal x | Terminal x <- syms] where f (ProductionRule x syms) = Nonterminal x:syms syms = nub (Nonterminal start : concat (map f prules)) -- first :: [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol] first tbl x = case (lookup x tbl) of Nothing -> [Symbol x] -- Nothing -> if x == Terminal "#" -- then [Symbol x] -- else error (show x ++ " not in " ++ show tbl) Just y -> y first_ :: [(Symbol, [ExtendedSymbol])] -> [Symbol] -> [ExtendedSymbol] first_ tbl [] = [] first_ tbl (z:zs) = let zRng = first tbl z in if elem Epsilon zRng then union ((\\) zRng [Epsilon]) (first_ tbl zs) else zRng extFirst :: [(Symbol, [ExtendedSymbol])] -> ExtendedSymbol -> [ExtendedSymbol] extFirst tbl (Symbol x) = first tbl x extFirst tbl (EndOfSymbol) = [EndOfSymbol] extFirst tbl (Epsilon) = error "extFirst_ : Epsilon" extFirst_ :: [(Symbol, [ExtendedSymbol])] -> [ExtendedSymbol] -> [ExtendedSymbol] extFirst_ tbl [] = [] extFirst_ tbl (z:zs) = let zRng = extFirst tbl z in if elem Epsilon zRng then union ((\\) zRng [Epsilon]) (extFirst_ tbl zs) else zRng -- calcFirst :: CFG -> [(Symbol, [ExtendedSymbol])] calcFirst cfg = calcFirst' cfg (initFirst cfg) (symbols cfg) initFirst cfg = let syms = symbols cfg CFG _ prules = cfg in [(Terminal x, [Symbol (Terminal x)]) | Terminal x <- syms] ++ [(Nonterminal x, [Epsilon | ProductionRule y [] <- prules, x == y]) | Nonterminal x <- syms] calcFirst' cfg currTbl syms = let (isChanged, nextFst) = calcFirst'' cfg currTbl syms in if isChanged then calcFirst' cfg nextFst syms else currTbl calcFirst'' cfg tbl [] = (False, []) calcFirst'' cfg tbl (Terminal x:therest) = calcFirst''' cfg tbl (False, (Terminal x, first tbl (Terminal x))) therest calcFirst'' cfg tbl (Nonterminal x:therest) = calcFirst''' cfg tbl (ischanged, (Nonterminal x, rng)) therest where CFG start prules = cfg addendum = f [zs | ProductionRule y zs <- prules, x == y] currRng = first tbl (Nonterminal x) ischanged = (\\) addendum currRng /= [] rng = union addendum currRng f [] = [] f (zs:zss) = union (first_ tbl zs) (f zss) calcFirst''' cfg tbl (bool1, oneupdated) therest = let (bool2, therestupdated) = calcFirst'' cfg tbl therest in (bool1 || bool2, oneupdated:therestupdated) -- follow :: [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol] follow tbl x = case lookup x tbl of Nothing -> error (show x ++ " : " ++ show tbl) Just z -> z -- calcFollow :: CFG -> [(Symbol, [ExtendedSymbol])] calcFollow cfg = calcFollow' (calcFirst cfg) prules (initFollow cfg) where CFG _ prules = cfg initFollow cfg = let CFG start prules = cfg in [(Nonterminal x, [EndOfSymbol | x == start]) | Nonterminal x <- symbols cfg] calcFollow' fstTbl prules currTbl = let (isChanged, nextFlw) = calcFollow'' fstTbl currTbl prules False in if isChanged then calcFollow' fstTbl prules nextFlw else currTbl calcFollow'' fstTbl flwTbl [] b = (b, flwTbl) calcFollow'' fstTbl flwTbl (ProductionRule y zs:therest) b = calcFollow'' fstTbl tbl' therest b' where (b',tbl') = f zs flwTbl b _y = Nonterminal y f [] tbl b = (b, tbl) f [Terminal z] tbl b = (b, tbl) f [Nonterminal z] tbl b = let flwZ = follow flwTbl (Nonterminal z) zRng = union flwZ (follow flwTbl _y) isChanged = (\\) zRng flwZ /= [] in (isChanged, upd (Nonterminal z) zRng tbl) f (Terminal z:zs) tbl b = f zs tbl b f (Nonterminal z:zs) tbl b = let fstZS = first_ fstTbl zs flwZ = follow flwTbl (Nonterminal z) zRng = union (follow flwTbl (Nonterminal z)) (union ((\\) fstZS [Epsilon]) (if elem Epsilon fstZS then follow flwTbl _y else [])) isChanged = (\\) zRng flwZ /= [] in f zs (upd (Nonterminal z) zRng tbl) isChanged upd z zRng tbl = [if z == x then (x, zRng) else (x,xRng) | (x,xRng) <- tbl] -- closure :: AUGCFG -> Items -> Items closure augCfg items = if isChanged then closure augCfg itemsUpdated -- loop over items else items where CFG s prules = augCfg (isChanged, itemsUpdated) = closure' (calcFirst augCfg) prules items items False closure' fstTbl prules cls [] b = (b, cls) closure' fstTbl prules cls (Item (ProductionRule x alphaBbeta) d lookahead:items) b = if _Bbeta /= [] then f cls b prules else closure' fstTbl prules cls items b where _Bbeta = drop d alphaBbeta _B = head _Bbeta beta = tail _Bbeta -- loop over production rules f cls b [] = closure' fstTbl prules cls items b f cls b (r@(ProductionRule y gamma):rs) = if _B == Nonterminal y then (if lookahead == [] then flrzero cls b r rs -- closure for LR(0) else g cls b r rs (extFirst_ fstTbl (map Symbol beta ++ lookahead))) -- closure for LR(1) else f cls b rs flrzero cls b r rs = let item = Item r 0 [] in if elem item cls then f cls b rs else f (cls ++ [item]) True rs -- loop over terminal symbols g cls b r rs [] = f cls b rs g cls b r rs (Symbol (Terminal t) : fstSyms) = let item = Item r 0 [Symbol (Terminal t)] in if elem item cls then g cls b r rs fstSyms else g (cls++[item]) True r rs fstSyms g cls b r rs (Symbol (Nonterminal t) : fstSyms) = g cls b r rs fstSyms g cls b r rs (EndOfSymbol : fstSyms) = let item = Item r 0 [EndOfSymbol] in if elem item cls then g cls b r rs fstSyms else g (cls++[item]) True r rs fstSyms g cls b r rs (Epsilon : fstSyms) = error "closure: Epsilon" -- calcLR0Items :: AUGCFG -> Itemss calcLR0Items augCfg = calcItems' augCfg syms iss0 where CFG _S prules = augCfg i0 = Item (head prules) 0 [] -- The 1st rule : S' -> S. is0 = closure augCfg [i0] iss0 = [ is0 ] syms = (\\) (symbols augCfg) [Nonterminal _S] -- syms = [ sym | sym <- symbols augCfg, sym /= Nonterminal _S] calcLR1Items :: AUGCFG -> Itemss calcLR1Items augCfg = calcItems' augCfg syms iss0 where CFG _S prules = augCfg i0 = Item (head prules) 0 [EndOfSymbol] -- The 1st rule : S' -> S. is0 = closure augCfg [i0] iss0 = [ is0 ] syms = (\\) (symbols augCfg) [Nonterminal _S] -- syms = [ sym | sym <- symbols augCfg, sym /= Nonterminal _S] calcItems' augCfg syms currIss = if isUpdated then calcItems' augCfg syms nextIss else currIss where (isUpdated, nextIss) = f currIss False currIss -- loop over sets of items f [] b currIss = (b, currIss) f (is:iss) b currIss = g is iss b currIss syms -- loop over symbols g is iss b currIss [] = f iss b currIss g is iss b currIss (x:xs) = let is' = goto augCfg is x in if is' == [] || elemItems is' currIss then g is iss b currIss xs else g is iss True (currIss ++ [is']) xs elemItems :: Items -> Itemss -> Bool elemItems is0 [] = False elemItems is0 (is:iss) = eqItems is0 is || elemItems is0 iss eqItems :: Items -> Items -> Bool eqItems is1 is2 = (\\) is1 is2 == [] && (\\) is2 is1 == [] indexItem :: String -> Itemss -> Items -> Int indexItem loc items item = indexItem' loc items item 0 indexItem' loc (item1:items) item2 n = if eqItems item1 item2 then n else indexItem' loc items item2 (n+1) indexItem' loc [] item n = error ("indexItem: not found " ++ show item ++ " at " ++ loc) goto :: AUGCFG -> Items -> Symbol -> Items goto augCfg items x = closure augCfg itemsOverX where itemsOverX = [ Item (ProductionRule z alphaXbeta) (j+1) y | Item (ProductionRule z alphaXbeta) j y <- items , let _Xbeta = drop j alphaXbeta , _Xbeta /= [] , x == head _Xbeta ] -------------------------------------------------------------------------------- -- Canonical LR Parser -------------------------------------------------------------------------------- sharp = Terminal "#" -- a special terminal symbol sharpSymbol = Symbol sharp -- calcEfficientLALRParseTable :: AUGCFG -> (Itemss, ProductionRules, ActionTable, GotoTable) calcEfficientLALRParseTable augCfg = (lr1items, prules, actionTable, gotoTable, ()) -- (lr0items, splk, splk'', prop, lr0GotoTable)) where CFG _S' prules = augCfg lr0items = calcLR0Items augCfg lr0kernelitems = map (filter (isKernel (startNonterminal augCfg))) lr0items syms = (\\) (symbols augCfg) [Nonterminal _S'] terminalSyms = [Terminal x | Terminal x <- syms] nonterminalSyms = [Nonterminal x | Nonterminal x <- syms] lr0GotoTable = calcLr0GotoTable augCfg lr0items splk = (Item (head prules) 0 [], 0, [EndOfSymbol]) : (map (\(a1,a2,a3,a4)->(a1,a2,a3)) splk') splk' = calcSplk augCfg lr0kernelitems lr0GotoTable splk'' = map (\(a1,a2,a3,a4)->a4) splk' prop = calcProp augCfg lr0kernelitems lr0GotoTable lr1kernelitems = computeLookaheads splk prop lr0kernelitems lr1items = map (closure augCfg) lr1kernelitems (actionTable, gotoTable) = calcEfficientLALRActionGotoTable augCfg lr1items calcLr0GotoTable augCfg lr0items = nub [ (from, h, to) | item1 <- lr0items , Item (ProductionRule y ys) j lookahead <- item1 , let from = indexItem "lr0GotoTable(from)" lr0items item1 , let ri = indexPrule augCfg (ProductionRule y ys) , let ys' = drop j ys , let h = head ys' , let to = indexItem "lr0GotoTable(to)" lr0items (goto augCfg item1 h) , ys' /= [] ] calcSplk augCfg lr0kernelitems lr0GotoTable = [ (Item prule2 dot2 [], toIndex, lookahead1, (fromIndex, toIndex, item0, lr1items, item1, item2)) | (fromIndex, lr0kernelitem) <- zip [0..] lr0kernelitems -- take item for each LR(0) kernels , item0@(Item prule0 dot0 _) <- lr0kernelitem , let lr1items = closure augCfg [Item prule0 dot0 [sharpSymbol]] -- Take its LR(1) closure with # , item1@(Item prule1@(ProductionRule lhs rhs) dot1 lookahead1) <- lr1items , lookahead1 /= [sharpSymbol] , let therestrhs = drop dot1 rhs , therestrhs /= [] , let symbolx = head therestrhs , let toIndexes = [t | (f,x,t) <- lr0GotoTable, f==fromIndex, x==symbolx ] , toIndexes /= [] , let toIndex = head toIndexes , let gotoIX = lr0kernelitems !! toIndex -- for each item in GoTo(I,X) , item2@(Item prule2 dot2 lookahead2) <- gotoIX , prule1 == prule2 ] calcProp augCfg lr0kernelitems lr0GotoTable = [ (Item prule0 dot0 [], fromIndex, Item prule2 dot2 [], toIndex) | (fromIndex, lr0kernelitem) <- zip [0..] lr0kernelitems -- take item for each LR(0) kernels , Item prule0 dot0 _ <- lr0kernelitem , let lr1items = closure augCfg [Item prule0 dot0 [sharpSymbol]] -- Take its LR(1) closure with # , Item prule1@(ProductionRule lhs rhs) dot1 lookahead1 <- lr1items , lookahead1 == [sharpSymbol] , let therestrhs = drop dot1 rhs , therestrhs /= [] , let symbolx = head therestrhs , let toIndexes = [t | (f,x,t) <- lr0GotoTable, f==fromIndex, x==symbolx ] , toIndexes /= [] , let toIndex = head toIndexes , let gotoIX = lr0kernelitems !! toIndex -- for each item in GoTo(I,X) , Item prule2 dot2 lookahead2 <- gotoIX , prule1 == prule2 ] calcEfficientLALRActionGotoTable augCfg items = (actionTable, gotoTable) where CFG _S' prules = augCfg -- items = calcLR1Items augCfg -- syms = (\\) (symbols augCfg) [Nonterminal _S'] -- terminalSyms = [Terminal x | Terminal x <- syms] -- nonterminalSyms = [Nonterminal x | Nonterminal x <- syms] f :: [(ActionTable,GotoTable)] -> (ActionTable, GotoTable) f l = case unzip l of (fst,snd) -> (g [] (concat fst), h [] (concat snd)) g actTbl [] = actTbl g actTbl ((i,x,a):triples) = let bs = [a' == a | (i',x',a') <- actTbl, i' == i && x' == x ] in if length bs == 0 then g (actTbl ++ [(i,x,a)]) triples else if and bs then g actTbl triples else error ("Conflict: " ++ show (i,x,a) ++ " " ++ show actTbl) h :: GotoTable -> GotoTable -> GotoTable h gtTbl [] = gtTbl h gtTbl ((i,x,j):triples) = let bs = [j' == j | (i',x',j') <- gtTbl, i' == i && x' == x ] in if length bs == 0 then h (gtTbl ++ [(i,x,j)]) triples else if and bs then h gtTbl triples else error ("Conflict: " ++ show (i,x,j) ++ " " ++ show gtTbl) mkLr0 (Item prule dot _) = Item prule dot [] itemsInLr0 = map (nub . map mkLr0) items (actionTable, gotoTable) = f [ if ys' == [] then if y == _S' && a == EndOfSymbol then ([(from, a, Accept) ], []) else ([(from, a, Reduce ri)], []) else if isTerminal h then ([(from, Symbol h, Shift to) ], []) else ([] , [(from, h, to)]) | (from,item1) <- zip [0..] items -- Optimization: (from,item1) <- zip [0..] items , Item (ProductionRule y ys) j [a] <- item1 -- , let from = indexItem "lr1ActionGotoTable(from)" items item1 , let ri = indexPrule augCfg (ProductionRule y ys) , let ys' = drop j ys , let h = head ys' , let to = indexItem "lr1ActionGotoTable(to)" itemsInLr0 (goto augCfg (nub $ map mkLr0 item1) h) ] type Lookahead = [ExtendedSymbol] type SpontaneousLookahead = [(Item, Int, Lookahead)] type PropagateLookahead = [(Item, Int, Item, Int)] computeLookaheads :: SpontaneousLookahead -> PropagateLookahead -> Itemss -> Itemss computeLookaheads splk prlk lr0kernelitemss = lr1kernelitemss where lr1kernelitemss = [ concat [ if lookaheads == [] then [Item prule dot []] else [ Item prule dot lookahead | lookahead <- lookaheads ] | (Item prule dot _, lookaheads) <- itemlks ] | itemlks <- lr1kernelitemlkss ] initLr1kernelitemlkss = init (zip [0..] lr0kernelitemss) lr1kernelitemlkss = snd (unzip (prop initLr1kernelitemlkss)) init [] = [] init ((index,items):iitemss) = (index, init' index items) : init iitemss init' index [] = [] init' index (item:items) = (item, init'' index item [] splk ) : init' index items init'' index itembase lookaheads [] = lookaheads init'' index itembase lookaheads ((splkitem,loc,lookahead):splkitems) = if index == loc && itembase == splkitem then init'' index itembase (lookaheads ++ [lookahead]) splkitems else init'' index itembase lookaheads splkitems prop ilr1kernelitemlkss = let itemToLks = collect ilr1kernelitemlkss prlk (changed, ilr1kernelitemlkss') = copy ilr1kernelitemlkss itemToLks in if changed then prop ilr1kernelitemlkss' else ilr1kernelitemlkss collect ilr1kernelitemlkss [] = [] collect ilr1kernelitemlkss (itemFromTo:itemFromTos) = let (itemFrom, fromIndex, itemTo, toIndex) = itemFromTo lookaheads = collect' itemFrom fromIndex [] ilr1kernelitemlkss in (itemTo, toIndex, lookaheads) : collect ilr1kernelitemlkss itemFromTos collect' itemFrom fromIndex lookaheads [] = lookaheads collect' itemFrom fromIndex lookaheads ((index, iitemlks):iitemlkss) = if fromIndex == index then collect' itemFrom fromIndex (collect'' itemFrom lookaheads iitemlks) iitemlkss else collect' itemFrom fromIndex lookaheads iitemlkss collect'' itemFrom lookaheads [] = lookaheads collect'' itemFrom lookaheads ((Item prule dot _, lks):itemlks) = let Item pruleFrom dotFrom _ = itemFrom lookaheads' = if pruleFrom == prule && dotFrom == dot then lks else [] in collect'' itemFrom (lookaheads ++ lookaheads') itemlks copy iitemlkss [] = (False, iitemlkss) copy iitemlkss (itemToLookahead:itemToLookaheads) = let (changed1, iitemlkss1) = copy' iitemlkss itemToLookahead (changed2, iitemlkss2) = copy iitemlkss1 itemToLookaheads in (changed1 || changed2, iitemlkss2) copy' [] itemToLookahead = (False, []) copy' ((index,itemlks):iitemlkss) itemToLookahead = let (changed1, itemlks1) = copy'' index itemlks itemToLookahead (changed2, itemlkss2) = copy' iitemlkss itemToLookahead in (changed1 || changed2, (index,itemlks1):itemlkss2) copy'' index [] itemToLookahead = (False, []) copy'' index (itemlk:itemlks) itemToLookahead = let (Item prule1 dot1 _, toIndex, lookahead1) = itemToLookahead (Item prule2 dot2 l2, lookahead2) = itemlk lookahead2' = if prule1 == prule2 && dot1 == dot2 && index == toIndex && lookahead1 \\ lookahead2 /= [] then nub (lookahead1 ++ lookahead2) else lookahead2 changed1 = lookahead2' /= lookahead2 itemlk1 = (Item prule2 dot2 l2, lookahead2') (changed2, itemlks2) = copy'' index itemlks itemToLookahead in (changed1 || changed2, itemlk1:itemlks2) prLkhTable [] = return () prLkhTable ((spontaneous, propagate):lkhTable) = do prSpontaneous spontaneous prPropagate propagate prLkhTable lkhTable prSpontaneous [] = return () prSpontaneous ((item, loc, [lookahead]):spontaneous) = do putStr (show item ++ " at " ++ show loc) putStr ", " putStrLn (show lookahead) prSpontaneous spontaneous prPropagate [] = return () prPropagate ((from, fromIndex, to, toIndex):propagate) = do putStr (show from ++ " at " ++ show fromIndex) putStr " -prop-> " putStr (show to ++ " at " ++ show toIndex) putStrLn "" prPropagate propagate ----- calcLR1ParseTable :: AUGCFG -> (Itemss, ProductionRules, ActionTable, GotoTable) calcLR1ParseTable augCfg = (items, prules, actionTable, gotoTable) where CFG _S' prules = augCfg items = calcLR1Items augCfg (actionTable, gotoTable) = calcLR1ActionGotoTable augCfg items calcLR1ActionGotoTable augCfg items = (actionTable, gotoTable) where CFG _S' prules = augCfg -- items = calcLR1Items augCfg -- syms = (\\) (symbols augCfg) [Nonterminal _S'] -- terminalSyms = [Terminal x | Terminal x <- syms] -- nonterminalSyms = [Nonterminal x | Nonterminal x <- syms] f :: [(ActionTable,GotoTable)] -> (ActionTable, GotoTable) f l = case unzip l of (fst,snd) -> (g [] (concat fst), h [] (concat snd)) g actTbl [] = actTbl g actTbl ((i,x,a):triples) = let bs = [a' == a | (i',x',a') <- actTbl, i' == i && x' == x ] in if length bs == 0 then g (actTbl ++ [(i,x,a)]) triples else if and bs then g actTbl triples else error ("Conflict: " ++ show (i,x,a) ++ " " ++ show actTbl) h :: GotoTable -> GotoTable -> GotoTable h gtTbl [] = gtTbl h gtTbl ((i,x,j):triples) = let bs = [j' == j | (i',x',j') <- gtTbl, i' == i && x' == x ] in if length bs == 0 then h (gtTbl ++ [(i,x,j)]) triples else if and bs then h gtTbl triples else error ("Conflict: " ++ show (i,x,j) ++ " " ++ show gtTbl) (actionTable, gotoTable) = f [ if ys' == [] then if y == _S' then ([(from, a, Accept) ], []) else ([(from, a, Reduce ri)], []) else if isTerminal h then ([(from, Symbol h, Shift to) ], []) else ([] , [(from, h, to)]) | item1 <- items -- Optimization: (from,item1) <- zip [0..] items , Item (ProductionRule y ys) j [a] <- item1 , let from = indexItem "lr1ActionGotoTable(from)" items item1 , let ri = indexPrule augCfg (ProductionRule y ys) -- Can be optimzied? , let ys' = drop j ys , let h = head ys' , let to = indexItem "lr1ActionGotoTable(to)" items (goto augCfg item1 h) ] prParseTable h (items, prules, actTbl, gtTbl) = do hPutStrLn h (show (length items) ++ " states") prItems h items hPutStrLn h "" prPrules h prules hPutStrLn h "" prActTbl h actTbl hPutStrLn h "" prGtTbl h gtTbl prLALRParseTable h (items, prules, iss, lalrActTbl, lalrGtTbl) = do hPutStrLn h (show (length items) ++ " states") prItems h items hPutStrLn h "" prPrules h prules hPutStrLn h "" hPutStrLn h (show (length iss) ++ " states") prStates h iss hPutStrLn h "" prActTbl h lalrActTbl hPutStrLn h "" prGtTbl h lalrGtTbl prStates h [] = return () prStates h (is:iss) = do hPutStrLn h (show is) prStates h iss -------------------------------------------------------------------------------- -- LALR Parser -------------------------------------------------------------------------------- calcLALRParseTable :: AUGCFG -> (Itemss, ProductionRules, [[Int]], LALRActionTable , LALRGotoTable) calcLALRParseTable augCfg = (itemss, prules, iss, lalrActTbl, lalrGtTbl) where (itemss, prules, actTbl, gtTbl) = calcLR1ParseTable augCfg itemss' = nubBy eqCore itemss iss = [ [i | (i, items) <- zip [0..] itemss, eqCore items items'] | items' <- itemss'] lalrActTbl = [ (is, x, lalrAct) | is <- iss , let syms = nub [ y | i <- is, (j, y, a) <- actTbl, i == j ] , x <- syms , let lalrAct = actionCheck $ nub [ toLalrAction iss a | i <- is , let r = lookupTable i x actTbl , isJust r , let Just a = r ] ] lalrGtTbl = [ (is, x, js) | is <- iss , let syms = nub [ y | i <- is, (j, y, k) <- gtTbl, i == j] , x <- syms , let js = stateCheck $ nub [ toIs iss j' | i <- is , (i', x', j') <- gtTbl , i==i' && x==x' ] ] eqCore :: Items -> Items -> Bool eqCore items1 items2 = subsetCore items1 items2 && subsetCore items2 items1 subsetCore [] items2 = True subsetCore (item1:items1) items2 = elemCore item1 items2 && subsetCore items1 items2 elemCore (Item prule1 i1 a) [] = False elemCore (Item prule1 i1 a) (Item prule2 i2 _:items) = if prule1 == prule2 && i1 == i2 then True else elemCore (Item prule1 i1 a) items toLalrAction :: [[Int]] -> Action -> LALRAction toLalrAction iss (Shift i) = LALRShift (toIs iss i) toLalrAction iss (Reduce i) = LALRReduce i toLalrAction iss (Accept) = LALRAccept toLalrAction iss (Reject) = LALRReject toIs [] i = error ("toIs: not found" ++ show i) toIs (is:iss) i = if elem i is then is else toIs iss i actionCheck :: [LALRAction] -> LALRAction actionCheck [a] = a actionCheck as = error ("LALR Action Conflict: " ++ show as) stateCheck :: [[Int]] -> [Int] stateCheck [is] = is stateCheck iss = error ("LALR State Conflict: " ++ show iss)