yapb 0.1.3.2 → 0.2
raw patch · 47 files changed
+4697/−1157 lines, 47 filesdep +deepseqdep +mtldep +transformersdep ~regex-tdfanew-component:exe:ambiguous-exenew-component:exe:error-exe
Dependencies added: deepseq, mtl, transformers
Dependency ranges changed: regex-tdfa
Files
- README.md +1/−3
- app/ambiguous/Lexer.hs +30/−0
- app/ambiguous/Main.hs +43/−0
- app/ambiguous/Parser.hs +65/−0
- app/ambiguous/ParserSpec.hs +15/−0
- app/ambiguous/Run.hs +25/−0
- app/ambiguous/Token.hs +45/−0
- app/ambiguous/ast/Expr.hs +48/−0
- app/conv/Main.hs +12/−0
- app/error/Lexer.hs +30/−0
- app/error/Main.hs +43/−0
- app/error/Parser.hs +74/−0
- app/error/ParserSpec.hs +15/−0
- app/error/Run.hs +25/−0
- app/error/Token.hs +45/−0
- app/error/ast/Expr.hs +48/−0
- app/parser/Lexer.hs +5/−5
- app/parser/Parser.hs +35/−29
- app/parser/Run.hs +8/−3
- app/parser/Token.hs +2/−0
- app/syntaxcompletion/Lexer.hs +5/−5
- app/syntaxcompletion/Parser.hs +19/−12
- app/syntaxcompletion/SyntaxCompletion.hs +24/−22
- app/syntaxcompletion/SyntaxCompletionSpec.hs +15/−11
- app/syntaxcompletion/Token.hs +3/−0
- src/config/Config.hs +32/−0
- src/gentable/Attrs.hs +20/−0
- src/gentable/CFG.hs +13/−11
- src/gentable/CodeGenC.hs +5/−5
- src/gentable/GenLRParserTable.hs +382/−201
- src/gentable/ParserTable.hs +2/−0
- src/parserlib/CommonParserUtil.hs +995/−802
- src/parserlib/LoadAutomaton.hs +17/−4
- src/parserlib/SaveProdRules.hs +20/−11
- src/parserlib/Terminal.hs +17/−1
- src/parserlib/TokenInterface.hs +1/−3
- src/parserlib/algo/SynCompAlgoBU.hs +458/−0
- src/parserlib/algo/SynCompAlgoBUTree.hs +498/−0
- src/parserlib/algo/SynCompAlgoBUTreeNested.hs +553/−0
- src/parserlib/algo/SynCompAlgoPEPM.hs +193/−0
- src/parserlib/algo/SynCompAlgoTD.hs +539/−0
- src/parserlib/algo/SynCompAlgoUtil.hs +133/−0
- src/parserlib/algo/SynCompAlgorithm.hs +46/−0
- src/syncomplib/EmacsServer.hs +4/−4
- src/syncomplib/SynCompInterface.hs +1/−1
- src/util/ReadGrammar.hs +9/−22
- yapb.cabal +79/−2
README.md view
@@ -22,9 +22,7 @@ ~~~ ### Tutorial-- [How to write and run a parser](https://github.com/kwanghoon/yapb/blob/master/doc/Tutorial-parser.md)-- [How to write and run a syntax completion server for Emacs](https://github.com/kwanghoon/yapb/blob/master/doc/Tutorial-syntax-completion.md)-- [For AST and interpreter: A top-down approach to writing a compiler for arithmetic expressions](https://github.com/kwanghoon/swlab_parser_builder/blob/master/doc/tutorial_swlab_parser_builder.txt) Written in Korean.+- As a tutorial, the most up-to-date examples are available in app/{parser,ambiguous,error,syntaxcompletion}. - [For parser: Parser generators sharing LR automaton generators and accepting general purpose programming language-based specifications](http://swlab.jnu.ac.kr/paper/kiise202001.pdf) Written in Korean. - [For syntax complection with YAPB-0.1.2: A text-based syntax completion method using LR parsing (PEPM 2021)](http://swlab.jnu.ac.kr/paper/pepm2021final.pdf).
+ app/ambiguous/Lexer.hs view
@@ -0,0 +1,30 @@+module Lexer(lexerSpec) where++import Prelude hiding (EQ)+import CommonParserUtil+import Token++mkFn :: Token -> LexAction Token IO () -- (String -> Maybe Token)+mkFn tok = \text -> return (Just tok)++skip :: LexAction Token IO () -- String -> Maybe Token+skip = \text -> return Nothing++lexerSpec :: LexerSpec Token IO ()+lexerSpec = LexerSpec+ {+ endOfToken = END_OF_TOKEN,+ lexerSpecList = + [ ("[ \t\n]", skip),+ ("[0-9]+" , mkFn INTEGER_NUMBER),+ ("\\(" , mkFn OPEN_PAREN),+ ("\\)" , mkFn CLOSE_PAREN),+ ("\\+" , mkFn ADD),+ ("\\-" , mkFn SUB),+ ("\\*" , mkFn MUL),+ ("\\/" , mkFn DIV),+ ("\\=" , mkFn EQ),+ ("\\;" , mkFn SEMICOLON),+ ("[a-zA-Z][a-zA-Z0-9]*" , mkFn IDENTIFIER)+ ]+ }
+ app/ambiguous/Main.hs view
@@ -0,0 +1,43 @@+module Main where++import CommonParserUtil++import Lexer+import Terminal+import Parser+import Expr++import Run(doProcess)+import ParserSpec (spec)++import System.IO+import System.Environment (getArgs, withArgs)++main :: IO ()+main = do+ args <- getArgs+ _main args++-- Todo: Can I fix to have "test" as a command in stack exec?++_main [] = return ()+_main (fileName:args) = + case fileName of+ "test" -> withArgs [] spec+ _ -> do _ <- doProcess True fileName+ _main args++readline msg = do+ putStr msg+ hFlush stdout+ readline'++readline' = do+ ch <- getChar+ if ch == '\n' then+ return ""+ else+ do line <- readline'+ return (ch:line)++
+ app/ambiguous/Parser.hs view
@@ -0,0 +1,65 @@+module Parser where++import Attrs+import CommonParserUtil+import Token+import Expr+++-- | Utility+rule prodRule action = (prodRule, action, Nothing )+ruleWithPrec prodRule prec action = (prodRule, action, Just prec)++--+parserSpec :: ParserSpec Token AST IO ()+parserSpec = ParserSpec+ {+ startSymbol = "Expr'",++ tokenPrecAssoc =+ [ (Attrs.Nonassoc, [ "integer_number" ]) -- %token integer_number+ , (Attrs.Left, [ "+", "-" ]) -- %left "+" "-"+ , (Attrs.Left, [ "*", "/" ]) -- %left "*" "/"+ , (Attrs.Right, [ "UMINUS" ]) -- %right UMINUS+ ],++ parserSpecList =+ [+ rule "Expr' -> Expr" (\rhs -> return $ get rhs 1),++ rule "Expr -> Expr + Expr"+ (\rhs -> return $ toAstExpr (+ BinOp Expr.ADD (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ),++ rule "Expr -> Expr - Expr"+ (\rhs -> return $ toAstExpr (+ BinOp Expr.SUB (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ),++ rule "Expr -> Expr * Expr"+ (\rhs -> return $ toAstExpr (+ BinOp Expr.MUL (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ),++ rule "Expr -> Expr / Expr"+ (\rhs -> return $ toAstExpr (+ BinOp Expr.DIV (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ),++ rule "Expr -> ( Expr )" (\rhs -> return $ get rhs 2),+ + ruleWithPrec "Expr -> - Expr" "UMINUS" -- Expr -> -Expr %prec UMINUS+ (\rhs -> return $ toAstExpr (+ BinOp Expr.SUB (Lit 0) (fromAstExpr (get rhs 2))) ),+ + rule "Expr -> integer_number"+ (\rhs -> return $ toAstExpr (Lit (read (getText rhs 1))) )++ ],+ + baseDir = "./",+ actionTblFile = "action_table.txt", + gotoTblFile = "goto_table.txt",+ grammarFile = "prod_rules.txt",+ parserSpecFile = "mygrammar.grm",+ genparserexe = "yapb-exe"+ }++
+ app/ambiguous/ParserSpec.hs view
@@ -0,0 +1,15 @@+module ParserSpec where++import Run++import Test.Hspec++spec = hspec $ do+ describe "parsing yapb/app/parser" $ do+ it "one-line example" $ do+ result <- doProcess False "./app/parser/example/oneline.arith"+ result `shouldBe` "((1 + 2) - ((3 * 4) / 5))"++ it "multi-line example" $ do+ result <- doProcess False "./app/parser/example/multiline.arith"+ result `shouldBe` "(x = 123); (x = (x + 1)); (y = x); (y = (y - ((1 * 2) / 3))); (z = (y = x))"
+ app/ambiguous/Run.hs view
@@ -0,0 +1,25 @@+module Run where++import CommonParserUtil++import TokenInterface+import Lexer+import Terminal+import Parser+import Expr++import Control.Monad (when)+import System.IO++doProcess verbose fileName = do+ text <- readFile fileName+ -- when (verbose) $ putStrLn "Lexing..."+ -- terminalList <- lexing lexerSpec text+ when (verbose) $ putStrLn "Parsing..."+ exprSeqAst <- parsing False+ parserSpec ((), 1, 1, text)+ (aLexer lexerSpec) (fromToken (endOfToken lexerSpec))+ + when (verbose) $ putStrLn "Pretty Printing..."+ when (verbose) $ putStrLn (pprintAst exprSeqAst)+ return (pprintAst exprSeqAst)
+ app/ambiguous/Token.hs view
@@ -0,0 +1,45 @@+module Token(Token(..)) where++import Prelude hiding(EQ)+import TokenInterface++data Token =+ END_OF_TOKEN+ | OPEN_PAREN | CLOSE_PAREN+ | IDENTIFIER | INTEGER_NUMBER+ | ADD | SUB | MUL | DIV+ | EQ | SEMICOLON+ deriving (Eq, Show)++tokenStrList :: [(Token,String)]+tokenStrList =+ [ (END_OF_TOKEN, "$"),+ (OPEN_PAREN, "("), (CLOSE_PAREN, ")"),+ (IDENTIFIER, "identifier"), (INTEGER_NUMBER, "integer_number"),+ (ADD, "+"), (SUB, "-"), (MUL, "*"), (DIV, "/"),+ (EQ, "="), (SEMICOLON, ";") + ]++findTok tok [] = Nothing+findTok tok ((tok_,str):list)+ | tok == tok_ = Just str+ | otherwise = findTok tok list++findStr str [] = Nothing+findStr str ((tok,str_):list)+ | str == str_ = Just tok+ | otherwise = findStr str list++instance TokenInterface Token where+ -- toToken str =+ -- case findStr str tokenStrList of+ -- Nothing -> error ("toToken: " ++ str)+ -- Just tok -> tok+ fromToken tok =+ case findTok tok tokenStrList of+ Nothing -> error ("fromToken: " ++ show tok)+ Just str -> str+ + isEOT END_OF_TOKEN = True+ isEOT _ = False+
+ app/ambiguous/ast/Expr.hs view
@@ -0,0 +1,48 @@+module Expr where++data AST =+ ASTSeq { fromAstSeq :: [Expr] } -- Expr Sequence: Expr1; ... ; Exprn+ | ASTExpr { fromAstExpr :: Expr }++instance Show AST where+ showsPrec p _ = (++) "AST ..."++toAstSeq :: [Expr] -> AST+toAstSeq exprs = ASTSeq exprs++toAstExpr :: Expr -> AST+toAstExpr expr = ASTExpr expr++data Expr =+ Lit { fromLit :: Int }+ | Var { fromVar :: String }+ | BinOp { kindFromBinOp :: BinOpKind,+ leftOpFromBinOp :: Expr,+ rightOpFromBinOp :: Expr }+ | Assign { lhsFromAssign :: String,+ rhsFromAssign :: Expr }++data BinOpKind = ADD | SUB | MUL | DIV++pprintAst :: AST -> String+pprintAst (ASTSeq exprs) =+ let insSemicolon [] = ""+ insSemicolon [str] = str+ insSemicolon (str:strs) = str ++ "; " ++ insSemicolon strs+ in insSemicolon (map pprint exprs)+ +pprintAst (ASTExpr expr) = pprint expr++pprint :: Expr -> String+pprint (Lit i) = show i+pprint (Var v) = v+pprint (BinOp Expr.ADD left right) =+ "(" ++ pprint left ++ " + " ++ pprint right ++ ")"+pprint (BinOp Expr.SUB left right) =+ "(" ++ pprint left ++ " - " ++ pprint right ++ ")"+pprint (BinOp Expr.MUL left right) =+ "(" ++ pprint left ++ " * " ++ pprint right ++ ")"+pprint (BinOp Expr.DIV left right) =+ "(" ++ pprint left ++ " / " ++ pprint right ++ ")"+pprint (Assign x expr) = + "(" ++ x ++ " = " ++ pprint expr ++ ")"
app/conv/Main.hs view
@@ -1,10 +1,22 @@ module Main where +import CFG import ReadGrammar +import System.Environment (getArgs)+ -- How to run: -- $ stack exec conv-exe grm/polyrpc.lgrm main = test conversion +test fun = do+ args <- getArgs+ repTest fun args++repTest fun [] = return ()+repTest fun (arg:args) = do+ text <- readFile arg+ fun text+ repTest fun args
+ app/error/Lexer.hs view
@@ -0,0 +1,30 @@+module Lexer(lexerSpec) where++import Prelude hiding (EQ)+import CommonParserUtil+import Token++mkFn :: Token -> LexAction Token IO () -- (String -> Maybe Token)+mkFn tok = \text -> return (Just tok)++skip :: LexAction Token IO () -- String -> Maybe Token+skip = \text -> return Nothing++lexerSpec :: LexerSpec Token IO ()+lexerSpec = LexerSpec+ {+ endOfToken = END_OF_TOKEN,+ lexerSpecList = + [ ("[ \t\n]", skip),+ ("[0-9]+" , mkFn INTEGER_NUMBER),+ ("\\(" , mkFn OPEN_PAREN),+ ("\\)" , mkFn CLOSE_PAREN),+ ("\\+" , mkFn ADD),+ ("\\-" , mkFn SUB),+ ("\\*" , mkFn MUL),+ ("\\/" , mkFn DIV),+ ("\\=" , mkFn EQ),+ ("\\;" , mkFn SEMICOLON),+ ("[a-zA-Z][a-zA-Z0-9]*" , mkFn IDENTIFIER)+ ]+ }
+ app/error/Main.hs view
@@ -0,0 +1,43 @@+module Main where++import CommonParserUtil++import Lexer+import Terminal+import Parser+import Expr++import Run(doProcess)+import ParserSpec (spec)++import System.IO+import System.Environment (getArgs, withArgs)++main :: IO ()+main = do+ args <- getArgs+ _main args++-- Todo: Can I fix to have "test" as a command in stack exec?++_main [] = return ()+_main (fileName:args) = + case fileName of+ "test" -> withArgs [] spec+ _ -> do _ <- doProcess True fileName+ _main args++readline msg = do+ putStr msg+ hFlush stdout+ readline'++readline' = do+ ch <- getChar+ if ch == '\n' then+ return ""+ else+ do line <- readline'+ return (ch:line)++
+ app/error/Parser.hs view
@@ -0,0 +1,74 @@+module Parser where++import Attrs+import CommonParserUtil+import Token+import Expr++import Control.Monad.Trans (lift)+import qualified Control.Monad.Trans.State.Lazy as ST++-- | Utility+rule prodRule action = (prodRule, action, Nothing )+ruleWithPrec prodRule prec action = (prodRule, action, Just prec)++--+parserSpec :: ParserSpec Token AST IO ()+parserSpec = ParserSpec+ {+ startSymbol = "Expr'",++ tokenPrecAssoc =+ [ (Attrs.Nonassoc, [ "integer_number" ]) -- %token integer_number+ , (Attrs.Left, [ "+", "-" ]) -- %left "+" "-"+ , (Attrs.Left, [ "*", "/" ]) -- %left "*" "/"+ , (Attrs.Right, [ "UMINUS" ]) -- %right UMINUS+ ],++ parserSpecList =+ [+ rule "Expr' -> Expr" (\rhs -> return $ get rhs 1),+ + rule "Expr -> Expr + Expr"+ (\rhs -> return $ toAstExpr (+ BinOp Expr.ADD (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ),++ rule "Expr -> Expr - Expr"+ (\rhs -> return $ toAstExpr (+ BinOp Expr.SUB (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ),++ rule "Expr -> Expr * Expr"+ (\rhs -> return $ toAstExpr (+ BinOp Expr.MUL (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ),++ rule "Expr -> Expr / Expr"+ (\rhs -> return $ toAstExpr (+ BinOp Expr.DIV (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ),++ rule "Expr -> ( Expr )" (\rhs -> return $ get rhs 2),+ + ruleWithPrec "Expr -> - Expr" "UMINUS" -- Expr -> -Expr %prec UMINUS+ (\rhs -> return $ toAstExpr (+ BinOp Expr.SUB (Lit 0) (fromAstExpr (get rhs 2))) ),+ + rule "Expr -> integer_number"+ (\rhs -> return $ toAstExpr (Lit (read (getText rhs 1))) ),++ rule "Expr -> error"+ (\rhs -> do (_,line,col,text) <- ST.get+ lift $ putStrLn $ "Expr -> error" ++ " at Line "+ ++ show line ++ ", Column " ++ show col+ lift $ putStrLn $ " : " ++ take 77 text -- 80 columns+ return $ toAstExpr (Lit 0) )+ + ],+ + baseDir = "./",+ actionTblFile = "action_table.txt", + gotoTblFile = "goto_table.txt",+ grammarFile = "prod_rules.txt",+ parserSpecFile = "mygrammar.grm",+ genparserexe = "yapb-exe"+ }++
+ app/error/ParserSpec.hs view
@@ -0,0 +1,15 @@+module ParserSpec where++import Run++import Test.Hspec++spec = hspec $ do+ describe "parsing yapb/app/parser" $ do+ it "one-line example" $ do+ result <- doProcess False "./app/parser/example/oneline.arith"+ result `shouldBe` "((1 + 2) - ((3 * 4) / 5))"++ it "multi-line example" $ do+ result <- doProcess False "./app/parser/example/multiline.arith"+ result `shouldBe` "(x = 123); (x = (x + 1)); (y = x); (y = (y - ((1 * 2) / 3))); (z = (y = x))"
+ app/error/Run.hs view
@@ -0,0 +1,25 @@+module Run where++import CommonParserUtil++import TokenInterface+import Lexer+import Terminal+import Parser+import Expr++import Control.Monad (when)+import System.IO++doProcess verbose fileName = do+ text <- readFile fileName+ -- when (verbose) $ putStrLn "Lexing..."+ -- terminalList <- lexing lexerSpec text+ when (verbose) $ putStrLn "Parsing..."+ exprSeqAst <- parsing False+ parserSpec ((), 1, 1, text)+ (aLexer lexerSpec) (fromToken (endOfToken lexerSpec))+ + when (verbose) $ putStrLn "Pretty Printing..."+ when (verbose) $ putStrLn (pprintAst exprSeqAst)+ return (pprintAst exprSeqAst)
+ app/error/Token.hs view
@@ -0,0 +1,45 @@+module Token(Token(..)) where++import Prelude hiding(EQ)+import TokenInterface++data Token =+ END_OF_TOKEN+ | OPEN_PAREN | CLOSE_PAREN+ | IDENTIFIER | INTEGER_NUMBER+ | ADD | SUB | MUL | DIV+ | EQ | SEMICOLON+ deriving (Eq, Show)++tokenStrList :: [(Token,String)]+tokenStrList =+ [ (END_OF_TOKEN, "$"),+ (OPEN_PAREN, "("), (CLOSE_PAREN, ")"),+ (IDENTIFIER, "identifier"), (INTEGER_NUMBER, "integer_number"),+ (ADD, "+"), (SUB, "-"), (MUL, "*"), (DIV, "/"),+ (EQ, "="), (SEMICOLON, ";") + ]++findTok tok [] = Nothing+findTok tok ((tok_,str):list)+ | tok == tok_ = Just str+ | otherwise = findTok tok list++findStr str [] = Nothing+findStr str ((tok,str_):list)+ | str == str_ = Just tok+ | otherwise = findStr str list++instance TokenInterface Token where+ -- toToken str =+ -- case findStr str tokenStrList of+ -- Nothing -> error ("toToken: " ++ str)+ -- Just tok -> tok+ fromToken tok =+ case findTok tok tokenStrList of+ Nothing -> error ("fromToken: " ++ show tok)+ Just str -> str+ + isEOT END_OF_TOKEN = True+ isEOT _ = False+
+ app/error/ast/Expr.hs view
@@ -0,0 +1,48 @@+module Expr where++data AST =+ ASTSeq { fromAstSeq :: [Expr] } -- Expr Sequence: Expr1; ... ; Exprn+ | ASTExpr { fromAstExpr :: Expr }++instance Show AST where+ showsPrec p _ = (++) "AST ..."++toAstSeq :: [Expr] -> AST+toAstSeq exprs = ASTSeq exprs++toAstExpr :: Expr -> AST+toAstExpr expr = ASTExpr expr++data Expr =+ Lit { fromLit :: Int }+ | Var { fromVar :: String }+ | BinOp { kindFromBinOp :: BinOpKind,+ leftOpFromBinOp :: Expr,+ rightOpFromBinOp :: Expr }+ | Assign { lhsFromAssign :: String,+ rhsFromAssign :: Expr }++data BinOpKind = ADD | SUB | MUL | DIV++pprintAst :: AST -> String+pprintAst (ASTSeq exprs) =+ let insSemicolon [] = ""+ insSemicolon [str] = str+ insSemicolon (str:strs) = str ++ "; " ++ insSemicolon strs+ in insSemicolon (map pprint exprs)+ +pprintAst (ASTExpr expr) = pprint expr++pprint :: Expr -> String+pprint (Lit i) = show i+pprint (Var v) = v+pprint (BinOp Expr.ADD left right) =+ "(" ++ pprint left ++ " + " ++ pprint right ++ ")"+pprint (BinOp Expr.SUB left right) =+ "(" ++ pprint left ++ " - " ++ pprint right ++ ")"+pprint (BinOp Expr.MUL left right) =+ "(" ++ pprint left ++ " * " ++ pprint right ++ ")"+pprint (BinOp Expr.DIV left right) =+ "(" ++ pprint left ++ " / " ++ pprint right ++ ")"+pprint (Assign x expr) = + "(" ++ x ++ " = " ++ pprint expr ++ ")"
app/parser/Lexer.hs view
@@ -4,13 +4,13 @@ import CommonParserUtil import Token -mkFn :: Token -> (String -> Maybe Token)-mkFn tok = \text -> Just tok+mkFn :: Token -> LexAction Token IO () -- (String -> Maybe Token)+mkFn tok = \text -> return $ Just tok -skip :: String -> Maybe Token-skip = \text -> Nothing+skip :: LexAction Token IO () -- String -> Maybe Token+skip = \text -> return $ Nothing -lexerSpec :: LexerSpec Token+lexerSpec :: LexerSpec Token IO () lexerSpec = LexerSpec { endOfToken = END_OF_TOKEN,
app/parser/Parser.hs view
@@ -4,61 +4,67 @@ import Token import Expr +-- | Utility+rule prodRule action = (prodRule, action, Nothing )+ruleWithPrec prodRule action prec = (prodRule, action, Just prec) -parserSpec :: ParserSpec Token AST+--+parserSpec :: ParserSpec Token AST IO () parserSpec = ParserSpec { startSymbol = "SeqExpr'",- ++ tokenPrecAssoc = [],+ parserSpecList = [- ("SeqExpr' -> SeqExpr", \rhs -> get rhs 1),+ rule "SeqExpr' -> SeqExpr" (\rhs -> return $ get rhs 1), - ("SeqExpr -> SeqExpr ; AssignExpr",- \rhs -> toAstSeq (- fromAstSeq (get rhs 1) ++ [fromAstExpr (get rhs 3)]) ),+ rule "SeqExpr -> SeqExpr ; AssignExpr"+ (\rhs -> return $ toAstSeq (+ fromAstSeq (get rhs 1) ++ [fromAstExpr (get rhs 3)]) ), - ("SeqExpr -> AssignExpr", \rhs -> toAstSeq [fromAstExpr (get rhs 1)]),+ rule "SeqExpr -> AssignExpr" (\rhs -> return $ toAstSeq [fromAstExpr (get rhs 1)]), - ("AssignExpr -> identifier = AssignExpr",- \rhs -> toAstExpr (Assign (getText rhs 1) (fromAstExpr (get rhs 3))) ),+ rule "AssignExpr -> identifier = AssignExpr"+ (\rhs -> return $ toAstExpr (Assign (getText rhs 1) (fromAstExpr (get rhs 3))) ), - ("AssignExpr -> AdditiveExpr", \rhs -> get rhs 1),+ rule "AssignExpr -> AdditiveExpr" (\rhs -> return $ get rhs 1), - ("AdditiveExpr -> AdditiveExpr + MultiplicativeExpr",- \rhs -> toAstExpr (+ rule "AdditiveExpr -> AdditiveExpr + MultiplicativeExpr"+ (\rhs -> return $ toAstExpr ( BinOp Expr.ADD (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ), - ("AdditiveExpr -> AdditiveExpr - MultiplicativeExpr",- \rhs -> toAstExpr (+ rule "AdditiveExpr -> AdditiveExpr - MultiplicativeExpr"+ (\rhs -> return $ toAstExpr ( BinOp Expr.SUB (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ), - ("AdditiveExpr -> MultiplicativeExpr", \rhs -> get rhs 1),+ rule "AdditiveExpr -> MultiplicativeExpr" (\rhs -> return $ get rhs 1), - ("MultiplicativeExpr -> MultiplicativeExpr * PrimaryExpr",- \rhs -> toAstExpr (+ rule "MultiplicativeExpr -> MultiplicativeExpr * PrimaryExpr"+ (\rhs -> return $ toAstExpr ( BinOp Expr.MUL (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ), - ("MultiplicativeExpr -> MultiplicativeExpr / PrimaryExpr",- \rhs -> toAstExpr (+ rule "MultiplicativeExpr -> MultiplicativeExpr / PrimaryExpr"+ (\rhs -> return $ toAstExpr ( BinOp Expr.DIV (fromAstExpr (get rhs 1)) (fromAstExpr (get rhs 3))) ), - ("MultiplicativeExpr -> PrimaryExpr", \rhs -> get rhs 1),+ rule "MultiplicativeExpr -> PrimaryExpr" (\rhs -> return $ get rhs 1), - ("PrimaryExpr -> identifier", \rhs -> toAstExpr (Var (getText rhs 1)) ),+ rule "PrimaryExpr -> identifier" (\rhs -> return $ toAstExpr (Var (getText rhs 1)) ), - ("PrimaryExpr -> integer_number",- \rhs -> toAstExpr (Lit (read (getText rhs 1))) ),+ rule "PrimaryExpr -> integer_number"+ (\rhs -> return $ toAstExpr (Lit (read (getText rhs 1))) ), - ("PrimaryExpr -> ( AssignExpr )", \rhs -> get rhs 2)+ rule "PrimaryExpr -> ( AssignExpr )" (\rhs -> return $ get rhs 2) ], - baseDir = "./",- actionTblFile = "action_table.txt", - gotoTblFile = "goto_table.txt",- grammarFile = "prod_rules.txt",+ baseDir = "./",+ actionTblFile = "action_table.txt", + gotoTblFile = "goto_table.txt",+ grammarFile = "prod_rules.txt", parserSpecFile = "mygrammar.grm",- genparserexe = "yapb-exe"+ genparserexe = "yapb-exe" }
app/parser/Run.hs view
@@ -2,6 +2,7 @@ import CommonParserUtil +import TokenInterface import Lexer import Terminal import Parser@@ -12,10 +13,14 @@ doProcess verbose fileName = do text <- readFile fileName- when (verbose) $ putStrLn "Lexing..."- terminalList <- lexing lexerSpec text+ -- when (verbose) $ putStrLn "Lexing..."+ -- terminalList <- lexing lexerSpec text when (verbose) $ putStrLn "Parsing..."- exprSeqAst <- parsing False parserSpec terminalList+ let debugFlag = False+ + exprSeqAst <-+ parsing debugFlag parserSpec ((), 1, 1, text) (aLexer lexerSpec) (fromToken (endOfToken lexerSpec))+ when (verbose) $ putStrLn "Pretty Printing..." when (verbose) $ putStrLn (pprintAst exprSeqAst) return (pprintAst exprSeqAst)
app/parser/Token.hs view
@@ -41,3 +41,5 @@ Just str -> str + isEOT END_OF_TOKEN = True+ isEOT _ = False
app/syntaxcompletion/Lexer.hs view
@@ -4,13 +4,13 @@ import CommonParserUtil import Token -mkFn :: Token -> (String -> Maybe Token)-mkFn tok = \text -> Just tok+mkFn :: Token -> LexAction Token IO () -- (String -> Maybe Token)+mkFn tok = \text -> return (Just tok) -skip :: String -> Maybe Token-skip = \text -> Nothing+skip :: LexAction Token IO () -- String -> Maybe Token+skip = \text -> return Nothing -lexerSpec :: LexerSpec Token+lexerSpec :: LexerSpec Token IO () lexerSpec = LexerSpec { endOfToken = END_OF_TOKEN,
app/syntaxcompletion/Parser.hs view
@@ -4,34 +4,41 @@ import Token import Expr -noAction = \rhs -> ()+-- | Utility+rule prodRule action = (prodRule, action, Nothing )+ruleWithPrec prodRule action prec = (prodRule, action, Just prec) -parserSpec :: ParserSpec Token AST+noAction = \rhs -> return ()++--+parserSpec :: ParserSpec Token AST IO () parserSpec = ParserSpec { startSymbol = "Start'", + tokenPrecAssoc = [],+ parserSpecList = [- ("Start' -> Start", noAction),+ rule "Start' -> Start" noAction, - ("Start -> Exp", noAction),+ rule "Start -> Exp" noAction, - ("Exp -> AppExp", noAction),+ rule "Exp -> AppExp" noAction, - ("Exp -> fn identifier => Exp", noAction),+ rule "Exp -> fn identifier => Exp" noAction, - ("AppExp -> AtExp", noAction),+ rule "AppExp -> AtExp" noAction, - ("AppExp -> AppExp AtExp", noAction),+ rule "AppExp -> AppExp AtExp" noAction, - ("AtExp -> identifier", noAction),+ rule "AtExp -> identifier" noAction, - ("AtExp -> ( Exp )", noAction),+ rule "AtExp -> ( Exp )" noAction, - ("AtExp -> let Dec in Exp end", noAction),+ rule "AtExp -> let Dec in Exp end" noAction, - ("Dec -> val identifier = Exp", noAction)+ rule "Dec -> val identifier = Exp" noAction ], baseDir = "./",
app/syntaxcompletion/SyntaxCompletion.hs view
@@ -14,6 +14,7 @@ import SynCompInterface import Control.Exception import Data.Typeable+import SynCompAlgorithm -- Todo: The following part should be moved to the library. -- Arguments: lexerSpec, parserSpec@@ -24,28 +25,29 @@ -- | computeCand computeCand :: Bool -> String -> String -> Bool -> IO [EmacsDataItem]-computeCand debug programTextUptoCursor programTextAfterCursor isSimpleMode = (do- {- 1. Lexing -} - (line, column, terminalListUptoCursor) <-- lexingWithLineColumn lexerSpec 1 1 programTextUptoCursor+computeCand debug programTextUptoCursor programTextAfterCursor isSimpleMode = - {- 2. Parsing -}- ((do ast <- parsing debug parserSpec terminalListUptoCursor- successfullyParsed)+ (do + {- 1. Parsing -}+ ((do ast <- parsing debug+ parserSpec ((),1,1,programTextUptoCursor)+ (aLexer lexerSpec) (fromToken (endOfToken lexerSpec))+ successfullyParsed) - `catch` \parseError ->- case parseError :: ParseError Token AST of- _ ->- {- 3. Lexing the rest and computing candidates with it -}- do (_, _, terminalListAfterCursor) <-- lexingWithLineColumn lexerSpec line column programTextAfterCursor- handleParseError- (HandleParseError {- debugFlag=debug,- searchMaxLevel=maxLevel,- simpleOrNested=isSimpleMode,- postTerminalList=terminalListAfterCursor,- nonterminalToStringMaybe=Nothing})- parseError))+ `catch` \parseError ->+ case parseError :: ParseError Token AST () of+ _ ->+ {- 2. Computing candidates with it -}+ do let (_,line,column,programTextAfterCursor) = lpStateFrom parseError+ compCandidates <- chooseCompCandidatesFn+ + handleParseError compCandidates+ (defaultHandleParseError {+ debugFlag=debug,+ searchMaxLevel=maxLevel,+ simpleOrNested=isSimpleMode,+ postTerminalList=[], -- terminalListAfterCursor is set to []!+ nonterminalToStringMaybe=Nothing})+ parseError)) - `catch` \lexError -> case lexError :: LexError of _ -> handleLexError+ `catch` \lexError -> case lexError :: LexError of _ -> handleLexError
app/syntaxcompletion/SyntaxCompletionSpec.hs view
@@ -9,6 +9,7 @@ spec = hspec $ do describe "syntax complection yapb/app/syntaxcompletion" $ do let ex1_sml = "let val add = fn x =>"+ it ("[ex1.sml:simple] " ++ ex1_sml) $ do results <- computeCand False ex1_sml "" True results `shouldBe` [Candidate "white ..."]@@ -18,11 +19,11 @@ results `shouldBe` [Candidate "white ...",Candidate "white ... white in white ... white end"] let ex2_sml = "let val add = fn y"+ it ("[ex2.sml:simple] " ++ ex2_sml) $ do results <- computeCand False ex2_sml "" True results `shouldBe` [Candidate "white => white ..."] - let ex2_sml = "let val add = fn y" it ("[ex2.sml:nested] " ++ ex2_sml) $ do results <- computeCand False ex2_sml "" False results `shouldBe`@@ -30,12 +31,11 @@ let test1_sml = "let val app = fn f => fn x => f x in let val add = fn y => y in" let test1_sml_end = " end"+ it ("[test1.sml:simple] " ++ test1_sml ++ " [cursor] " ++ test1_sml_end) $ do results <- computeCand False test1_sml test1_sml_end True results `shouldBe` [Candidate "white ... gray end 1 66 "] - let test1_sml = "let val app = fn f => fn x => f x in let val add = fn y => y in"- let test1_sml_end = " end" it ("[test1.sml:nested] " ++ test1_sml ++ " [cursor] " ++ test1_sml_end) $ do results <- computeCand False test1_sml test1_sml_end False results `shouldBe`@@ -43,55 +43,59 @@ let test1_sml = "let val app = fn f => fn x => f x in let val add = fn y => y in" let test1_sml_end = " end !="+ it ("[test1.sml:simple:invalid tokens] " ++ test1_sml ++ " [cursor] " ++ test1_sml_end) $ do results <- computeCand False test1_sml test1_sml_end True results `shouldBe` [LexError] let test1_sml = "let val app = fn f => fn x => f x in let val add = fn y => y in" let test1_sml_end = " end !="+ it ("[test1.sml:nested:invalid tokens] " ++ test1_sml ++ " [cursor] " ++ test1_sml_end) $ do results <- computeCand False test1_sml test1_sml_end False results `shouldBe` [LexError] let test2_sml = "fn x => f (f (f (f x"+ it ("[test2.sml:simple] " ++ test2_sml) $ do results <- computeCand False test2_sml "" True- results `shouldBe` [Candidate "white )"]+ results `shouldBe` [Candidate "white )"] -- for loosely simple mode+ -- results `shouldBe` [] -- for strictly simple mode - let test2_sml = "fn x => f (f (f (f x" it ("[test2.sml:nested] " ++ test2_sml) $ do results <- computeCand False test2_sml "" False results `shouldBe` [Candidate "white )",Candidate "white ) white )",Candidate "white ) white ) white )"] let test3_sml = "let val add = x "+ it ("[test3.sml:simple] " ++ test3_sml) $ do results <- computeCand False test3_sml "" True- results `shouldBe` []+ results `shouldBe` [Candidate "white in white ... white end"] -- for loosely simple mode+ -- results `shouldBe` [] -- for strictly simple mode - let test3_sml = "let val add = x " it ("[test3.sml:nested] " ++ test3_sml) $ do results <- computeCand False test3_sml "" False results `shouldBe` [Candidate "white in white ... white end"] let test4_sml = "fn x y => "+ it ("[test4.sml:simple] " ++ test4_sml) $ do results <- computeCand False test4_sml "" True results `shouldBe`- [ParseError ["y at (1, 6): identifier","=> at (1, 8): =>","$ at (1, 11): $"]]+ [ParseError "y => "] - let test4_sml = "fn x y => " it ("[test4.sml:nested] " ++ test4_sml) $ do results <- computeCand False test4_sml "" False results `shouldBe`- [ParseError ["y at (1, 6): identifier","=> at (1, 8): =>","$ at (1, 11): $"]]+ [ParseError "y => "] let lexerror = "x != y "+ it ("[lex error:simple] " ++ lexerror) $ do results <- computeCand False lexerror "" True results `shouldBe` [LexError] - let lexerror = "x != y " it ("[lex error:nested] " ++ lexerror) $ do results <- computeCand False lexerror "" False results `shouldBe` [LexError]
app/syntaxcompletion/Token.hs view
@@ -37,3 +37,6 @@ case findTok tok tokenStrList of Nothing -> error ("fromToken: " ++ show tok) Just str -> str+ + isEOT END_OF_TOKEN = True+ isEOT _ = False
+ src/config/Config.hs view
@@ -0,0 +1,32 @@+module Config where++import Text.Read (readMaybe)+import Data.Maybe+import System.IO+import System.Directory++data Configuration =+ Configuration {+ config_SIMPLE :: Bool, -- Simple(True), Nested(False)+ config_R_LEVEL :: Int, -- + config_GS_LEVEL :: Int, -- + config_DEBUG :: Bool, -- True => Debugging on, False => Debugging off+ config_DISPLAY :: Bool, -- True => Display in Emacs, False => Do not display in Emacs+ config_PRESENTATION :: Int, -- 0 : default, 1 : ...+ config_ALGORITHM :: Int -- 0 : BU, 1 : TD, 2 : PEPM [, 3 : BUTree ] + }+ deriving (Read, Show)++configFileName = "yapb.config"++readConfig :: IO (Maybe Configuration)+readConfig =+ do exists <- doesFileExist configFileName+ if exists+ then do text <- readFile configFileName+ case readMaybe text :: Maybe Configuration of+ Just config_text -> return $ Just config_text+ Nothing -> error $ "readConfig: unexpected configuration\n" ++ show text+ else return Nothing++
+ src/gentable/Attrs.hs view
@@ -0,0 +1,20 @@+module Attrs where+++-- | Associativity++data Associativity = Left | Right | Nonassoc+ deriving (Show, Read, Eq)++-- Production rules+type RuleNumber = Int+type Precedence = Int++data ProdRuleAttrs = ProdRuleAttrs [(RuleNumber, (Associativity, Precedence))]+ deriving (Show, Read)++-- Tokens or placeholders+type TokenOrPlaceholder = String++data TokenAttrs = TokenAttrs [(TokenOrPlaceholder, (Associativity, Precedence))]+ deriving (Show, Read)
src/gentable/CFG.hs view
@@ -3,10 +3,12 @@ import Data.List(nub,intersperse) ----------------------------------------------------------------------------------- Context Free Grammar+-- | Context Free Grammar --------------------------------------------------------------------------------++-- | Terminals and nonterminals data Symbol = Nonterminal String | Terminal String - deriving (Eq, Read)+ deriving (Eq, Ord, Read) instance Show Symbol where showsPrec p (Nonterminal x) = (++) x@@ -15,22 +17,23 @@ isTerminal (Terminal x) = True isTerminal _ = False -data ExtendedSymbol = Symbol Symbol | Epsilon | EndOfSymbol- deriving Eq+data ExtendedSymbol = Symbol Symbol | Epsilon | EndOfSymbol String+ deriving (Eq, Ord) instance Show ExtendedSymbol where- showsPrec p (Symbol sym) = (++) (show sym)- showsPrec p (Epsilon) = (++) "epsilon"- showsPrec p (EndOfSymbol) = (++) "$"+ showsPrec p (Symbol sym) = (++) (show sym)+ showsPrec p (Epsilon) = (++) "epsilon"+ showsPrec p (EndOfSymbol eot) = (++) eot -- "$" isExtendedTerminal (Symbol (Terminal x)) = True -isExtendedTerminal (EndOfSymbol) = True +isExtendedTerminal (EndOfSymbol eot) = True isExtendedTerminal _ = False isExtendedNonterminal (Symbol (Nonterminal x)) = True isExtendedNonterminal _ = False -data ProductionRule = ProductionRule String [Symbol] +-- | Production rules+data ProductionRule = ProductionRule String [Symbol] deriving (Eq, Read) instance Show ProductionRule where@@ -42,6 +45,7 @@ show_ys [y] = (++) (show y) show_ys (y:ys) = (++) (show y) . (++) " " . show_ys ys +-- | Context-free grammar data CFG = CFG String [ProductionRule] deriving (Show, Read) @@ -59,6 +63,4 @@ symbolToStr (Nonterminal x) = "Nonterminal " ++ show x symbolToStr (Terminal x) = "Terminal " ++ show x--
src/gentable/CodeGenC.hs view
@@ -124,11 +124,11 @@ putStrLn "};" -- C array for goto_table-cgGotoTable augCfg =+cgGotoTable augCfg iss gotoTbl = do prGotoTableDim (length iss) (length nts) prGotoTableArr iss nts gotoTbl where- (_,_,iss,_,gotoTbl) = calcLALRParseTable augCfg+ -- (_,_,iss,_,gotoTbl) = calcLALRParseTable augCfg nts = nonterminals augCfg cg_noofstates = "NOOFSTATES"@@ -170,7 +170,7 @@ prGotoTableArr'' i nonterms gotoTbl -- Generate C code for an LALR action table-cgActionsInStates augCfg =+cgActionsInStates augCfg lalrActTbl = do let nTabs = 1 prTab nTabs putStrLn "switch( top() )"@@ -183,7 +183,7 @@ where CFG start prules = augCfg iprules = zip [0..] prules - (_,_,_,lalrActTbl,_) = calcLALRParseTable augCfg+ -- (_,_,_,lalrActTbl,_) = calcLALRParseTable augCfg eqState (x1,_,_) (x2,_,_) = x1 == x2 @@ -279,7 +279,7 @@ cgTerminalName extsym = case extsym of Symbol (Terminal t) -> cgTerminalName' t- EndOfSymbol -> cgNameEndOfSymbol+ EndOfSymbol eot -> cgNameEndOfSymbol _ -> error "cgTerminalName: not a terminal symbol" cgTerminalName' t =
src/gentable/GenLRParserTable.hs view
@@ -14,13 +14,15 @@ -- * closure g4 [Item (ProductionRule "S'" [Nonterminal "S"]) 0 [Symbol (Terminal "")]] -------------------------------------------------------------------------------- -module GenLRParserTable where+module GenLRParserTable (_main) where +import Text.Read (readMaybe) import Data.List import Data.Maybe import System.Environment (getArgs) import CFG+import Attrs import ParserTable import CmdArgs @@ -50,18 +52,35 @@ f h file = do grammar <- readFile file -- putStrLn grammar- let cfg = read grammar :: CFG+ let (cfg,tokenAttrs,prodRuleAttrs,eot) =+ case readMaybe grammar :: Maybe (CFG, TokenAttrs, ProdRuleAttrs,String) of+ Just ctp -> ctp+ Nothing -> error $ "[GenLRParserTable:_main:f] unexpected "+ ++ "cfg, token attrs, and prod rule attrs" - prParseTable stdout $ (\(a1,a2,a3,a4,a5)->(a1,a2,a3,a4)) (calcEfficientLALRParseTable cfg)+ (items, prules, actTbl, gtTbl, conflictsResolved)+ <- calcEfficientLALRParseTable cfg eot tokenAttrs+ (setProdRuleAttrs cfg tokenAttrs prodRuleAttrs) + prConflictsResolved conflictsResolved++ prParseTable stdout (items, prules, actTbl, gtTbl)+ 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) + let (cfg,tokenAttrs,prodRuleAttrs,eot) =+ case readMaybe grammar :: Maybe (CFG, TokenAttrs, ProdRuleAttrs,String) of+ Just cfp -> cfp+ Nothing -> error $ "[GenLRParserTable:writeParseTable] unexpected "+ ++ "cfg, token attrs, prod rule attrs, and eot"+ + (items, prules, actTbl, gtTbl, conflictsResolved)+ <- calcEfficientLALRParseTable cfg eot tokenAttrs+ (setProdRuleAttrs cfg tokenAttrs prodRuleAttrs) + prConflictsResolved conflictsResolved+ h_pr <- openFile prod_rule WriteMode h_acttbl <- openFile action_tbl WriteMode h_gototbl <- openFile goto_tbl WriteMode@@ -74,9 +93,29 @@ hClose h_acttbl hClose h_gototbl -__main g = do- prParseTable stdout $ (\(a1,a2,a3,a4,a5)->(a1,a2,a3,a4)) (calcEfficientLALRParseTable g)+setProdRuleAttrs cfg _tokenAttrs _initProdRuleAttrs =+ ProdRuleAttrs $+ concat [ getAssocPrec no rhs | (no, ProductionRule _ rhs) <- zip [0..] prodRules ]+ where+ CFG ss prodRules = cfg+ TokenAttrs tokenAttrs = _tokenAttrs+ ProdRuleAttrs initProdRuleAttrs = _initProdRuleAttrs + getAssocPrec no rhs =+ case [ (assoc,prec) | (no',(assoc,prec)) <- initProdRuleAttrs, no==no' ] of+ ((assoc,prec):_) -> [ (no, (assoc,prec)) ]+ [] -> findRightmostTerminal no (reverse rhs)++ findRightmostTerminal no [] = []+ findRightmostTerminal no (Nonterminal _ : rhs) = findRightmostTerminal no rhs+ findRightmostTerminal no (Terminal tok : rhs) =+ case [ (assoc,prec) | (tok', (assoc,prec)) <- tokenAttrs, tok==tok' ] of+ ((assoc,prec):_) -> [ (no, (assoc,prec)) ]+ [] -> [] ++-- __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@@ -112,11 +151,11 @@ ch <- getChar prSplk' splk' -__mainLr1 g = do- prParseTable stdout (calcLR1ParseTable g)+-- __mainLr1 g = do+-- prParseTable stdout (calcLR1ParseTable g) -__mainLalr1 g = do - prLALRParseTable stdout (calcLALRParseTable g)+-- __mainLalr1 g = do +-- prLALRParseTable stdout (calcLALRParseTable g) -- indexPrule :: AUGCFG -> ProductionRule -> Int@@ -163,9 +202,9 @@ 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 tbl (Symbol x) = first tbl x+extFirst tbl (EndOfSymbol eot) = [EndOfSymbol eot]+extFirst tbl (Epsilon) = error "extFirst_ : Epsilon" extFirst_ :: [(Symbol, [ExtendedSymbol])] -> [ExtendedSymbol] -> [ExtendedSymbol] extFirst_ tbl [] = []@@ -215,53 +254,53 @@ ---follow :: [(Symbol, [ExtendedSymbol])] -> Symbol -> [ExtendedSymbol]-follow tbl x = case lookup x tbl of- Nothing -> error (show x ++ " : " ++ show tbl)- Just z -> z+-- 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+-- 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]+-- 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 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+-- 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+-- _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+-- 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]+-- upd z zRng tbl = [if z == x then (x, zRng) else (x,xRng) | (x,xRng) <- tbl] -- closure :: AUGCFG -> Items -> Items@@ -307,8 +346,8 @@ 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]+ g cls b r rs (EndOfSymbol eot : fstSyms) = + let item = Item r 0 [EndOfSymbol eot] in if elem item cls then g cls b r rs fstSyms else g (cls++[item]) True r rs fstSyms@@ -326,16 +365,16 @@ 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 ]+-- 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]+-- syms = (\\) (symbols augCfg) [Nonterminal _S]+-- -- syms = [ sym | sym <- symbols augCfg, sym /= Nonterminal _S] calcItems' augCfg syms currIss = if isUpdated@@ -382,36 +421,68 @@ ----------------------------------------------------------------------------------- Canonical LR Parser+-- Efficient LALR 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))+calcEfficientLALRParseTable+ :: CFG+ -> String+ -> TokenAttrs+ -> ProdRuleAttrs+ -> IO ([Items], [ProductionRule]+ , ParserTable.ActionTable, ParserTable.GotoTable+ , ConflictsResolved)+calcEfficientLALRParseTable augCfg eot tokenAttrs prodRuleAttrs =+ do+ -- putStrLn "lr0kernelitems:"+ -- prItems stdout lr0kernelitems++ -- putStrLn "splk:"+ -- mapM_ putStrLn $ map show splk+ + -- putStrLn "prop:"+ -- mapM_ putStrLn $ map show prop++ -- putStrLn "lr1kernelitems:"+ -- prItems stdout lr1kernelitems+ + return (lr1items, prules, actionTable, gotoTable, conflictsResolved) where- CFG _S' prules = augCfg - lr0items = calcLR0Items augCfg - lr0kernelitems = map (filter (isKernel (startNonterminal augCfg))) lr0items+ CFG _S' prules = augCfg+ syms = (\\) (symbols augCfg) [Nonterminal _S'] terminalSyms = [Terminal x | Terminal x <- syms] nonterminalSyms = [Nonterminal x | Nonterminal x <- syms] + -- | 1. Construction of LR(0) items (naively)+ lr0items = calcLR0Items augCfg+ + -- | 2. Extract LR(0) kernel items+ lr0kernelitems = map (filter (isKernel (startNonterminal augCfg))) lr0items++ -- | 3. Spontaneous lookaheads in an item at a state 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'+ splk = (Item (head prules) 0 [], 0, [EndOfSymbol eot])+ : calcSplk augCfg lr0kernelitems lr0GotoTable+ + -- | 4. Lookaheads propagation from an item at a state to another item at another state prop = calcProp augCfg lr0kernelitems lr0GotoTable + -- | 5. Construction of LR(1) kernel items from splk, prop, and LR(0) kernel items lr1kernelitems = computeLookaheads splk prop lr0kernelitems + -- | 6. Construction of LR(1) items lr1items = map (closure augCfg) lr1kernelitems - (actionTable, gotoTable) = calcEfficientLALRActionGotoTable augCfg lr1items+ -- | 7. Construction of LALR(1) table+ (actionTable, gotoTable, conflictsResolved) =+ calcEfficientLALRActionGotoTable augCfg eot lr1items tokenAttrs prodRuleAttrs +calcLr0GotoTable :: CFG -> [[Item]] -> [(Int, Symbol, Int)] calcLr0GotoTable augCfg lr0items = nub [ (from, h, to) | item1 <- lr0items@@ -423,9 +494,10 @@ , let to = indexItem "lr0GotoTable(to)" lr0items (goto augCfg item1 h) , ys' /= [] ] - ++calcSplk :: CFG -> Itemss -> [(Int, Symbol, Int)] -> [(Item, Int, [ExtendedSymbol])] calcSplk augCfg lr0kernelitems lr0GotoTable = - [ (Item prule2 dot2 [], toIndex, lookahead1, (fromIndex, toIndex, item0, lr1items, item1, item2)) + [ (Item prule2 dot2 [], toIndex, lookahead1) | (fromIndex, lr0kernelitem) <- zip [0..] lr0kernelitems -- take item for each LR(0) kernels , item0@(Item prule0 dot0 _) <- lr0kernelitem @@ -445,6 +517,7 @@ , prule1 == prule2 ] +calcProp :: CFG -> Itemss -> [(Int, Symbol, Int)] -> [(Item, Int, Item, Int)] calcProp augCfg lr0kernelitems lr0GotoTable = [ (Item prule0 dot0 [], fromIndex, Item prule2 dot2 [], toIndex) | (fromIndex, lr0kernelitem) <- zip [0..] lr0kernelitems -- take item for each LR(0) kernels@@ -466,7 +539,11 @@ , prule1 == prule2 ] -calcEfficientLALRActionGotoTable augCfg items = (actionTable, gotoTable)+calcEfficientLALRActionGotoTable+ :: CFG -> String -> Itemss -> TokenAttrs -> ProdRuleAttrs+ -> (ParserTable.ActionTable, ParserTable.GotoTable, ConflictsResolved)+calcEfficientLALRActionGotoTable augCfg eot items (TokenAttrs tokenAttrs) (ProdRuleAttrs prodRuleAttrs) =+ (actionTable, gotoTable, conflictsResolved) where CFG _S' prules = augCfg -- items = calcLR1Items augCfg@@ -475,41 +552,104 @@ -- 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))+ f :: [(ActionTable,GotoTable)] -> (ActionTable, GotoTable, ConflictsResolved)+ -- f l = case unzip l of (fst,snd) -> (g [] (concat fst), h [] (concat snd))+ f l = case unzip l of (fst,snd) ->+ let (actTbl, conflictsResolved) = g1 (concat fst)+ gotoTbl = h [] (concat snd)+ in (actTbl, gotoTbl, conflictsResolved) g actTbl [] = actTbl g actTbl ((i,x,a):triples) = - let bs = [a' == a | (i',x',a') <- actTbl, i' == i && x' == x ] in+ let bs = [ (i',x',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)- + else if and [ a == a' | (_,_,a') <- bs ]+ then g actTbl triples+ else error $ "Conflict: " ++ show (i,x,a) ++ " " ++ show bs++ g1 :: ActionTable -> (ActionTable, ConflictsResolved)+ g1 actTbl = gResolve . squeeze . groupBy eqStateLookahead . sortBy cmpStateLookahead $ actTbl+ where+ squeeze xss = map (nubBy (\(_,_,a1) (_,_,a2) -> a1==a2)) xss+ + gResolve :: [ActionTable] -> (ActionTable, ConflictsResolved)+ gResolve [] = ([], [])+ gResolve ([]:theRest) = error "gResolve: empty group" -- Will never happen+ gResolve ([(i,x,a)]:theRest) =+ let (actTbl',conflictsResolved) = gResolve theRest + in ((i,x,a) : actTbl', conflictsResolved)+ gResolve ([t1,t2]:theRest) = -- conflict resolution+ let (ixa, conflictResolved) = resolve t1 t2+ (actTbl', conflictsResolved) = gResolve theRest+ in (ixa : actTbl', conflictResolved : conflictsResolved)+ gResolve ixaList = error $ "Conflict: " ++ show (head ixaList)++ eqStateLookahead (i1,x1,a1) (i2,x2,a2) = i1==i2 && x1==x2++ cmpStateLookahead (i1,x1,a1) (i2,x2,a2) =+ if i1<i2 || i1==i2 && x1<x2 then LT+ else if i1==i2 && x1==x2 then EQ+ else GT++ -- Precondition: i1==i2 && x1==x2+ resolve t1@(i1,x1,Reduce p1) t2@(i2,x2,Reduce p2) =+ if p1 < p2+ then (t1, (i1,x1,Reduce p1, Reduce p2))+ else (t2, (i2,x2,Reduce p2, Reduce p1))+ + resolve t1@(i1,x1,Shift tk) t2@(i2,x2,Reduce p) =+ case (getAssocPrecToken x1, getAssocPrecProdRule p) of+ -- By the extended resolution+ (Just (assoc1, p1), Just (assoc2, p2)) -> + if p2 > p1 -- if prec(rule) is higher than prec(lookahead)+ then (t2, (i2,x2,Reduce p, Shift tk)) -- then do reduce+ else if p2 == p1 && assoc2 == Attrs.Left -- else if the same prec && assoc(rule) is Left+ then (t2, (i2,x2,Reduce p, Shift tk)) -- then do reduce+ else (t1, (i1,x1,Shift tk, Reduce p)) -- else do shift++ -- By the default resolution+ _ -> + (t1, (i1,x1,Shift tk, Reduce p))+ + resolve t1@(i1,x1,Reduce p) t2@(i2,x2,Shift tk) = resolve t2 t1+ + resolve t1@(i1,x1,a1) t2@(i2,x2,a2) =+ error $ "Conflict: unexpected actions: state "+ ++ show i1 ++ show " token " ++ show x1 ++ " : "+ ++ show a1 ++ " vs " ++ show a2++ getAssocPrecProdRule p1 =+ case [ (assoc,prec) | (p,(assoc,prec)) <- prodRuleAttrs, p==p1 ] of+ [] -> Nothing+ ((assoc,p1'):_) -> Just (assoc,p1')++ getAssocPrecToken (Symbol (Terminal s)) =+ case [ (assoc,prec) | (tok,(assoc,prec)) <- tokenAttrs, tok==s ] of+ [] -> Nothing+ ((assoc,prec):_) -> Just (assoc,prec)+ + getAssocPrecToken (Epsilon) = Nothing+ + getAssocPrecToken (EndOfSymbol _) = Nothing+ 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+ let bs = [ (i',x',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+ else if and [ j' == j | (_,_,j') <- bs] then h gtTbl triples- else error ("Conflict: "- ++ show (i,x,j)- ++ " "- ++ show gtTbl)+ else error $ "Conflict: " ++ show (i,x,j) ++ " " ++ show bs - mkLr0 (Item prule dot _) = Item prule dot [] + mkLr0 (Item prule dot _) = Item prule dot [] itemsInLr0 = map (nub . map mkLr0) items - (actionTable, gotoTable) = f+ (actionTable, gotoTable, conflictsResolved) = f [ if ys' == []- then if y == _S' && a == EndOfSymbol+ then if y == _S' && a == EndOfSymbol eot then ([(from, a, Accept) ], []) else ([(from, a, Reduce ri)], []) else if isTerminal h @@ -525,87 +665,114 @@ ] type Lookahead = [ExtendedSymbol] +type Lookaheads = [Lookahead] type SpontaneousLookahead = [(Item, Int, Lookahead)] type PropagateLookahead = [(Item, Int, Item, Int)] computeLookaheads :: SpontaneousLookahead -> PropagateLookahead -> Itemss -> Itemss computeLookaheads splk prlk lr0kernelitemss = lr1kernelitemss where++ -- | initial LR(1) kernel item lookaheads+ initLr1kernelitemlkss =+ initLr1Kernel splk (zip [0..length lr0kernelitemss] lr0kernelitemss)+ + lr1kernelitemlkss = snd (unzip (prop prlk initLr1kernelitemlkss))+ 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+-- | inintial LR(1) items+initLr1Kernel :: SpontaneousLookahead -> [(Int, Items)] -> [(Int, [(Item, Lookaheads)])]+initLr1Kernel splk [] = []+initLr1Kernel splk ((index,items):iitemss) =+ (index, init' splk index items) : initLr1Kernel splk iitemss - 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 +-- | For each item at state index+init' :: SpontaneousLookahead -> Int -> Items -> [(Item, Lookaheads)]+init' splk index [] = []+init' splk index (item:items) = (item, init'' index item [] splk ) : init' splk index items - prop ilr1kernelitemlkss = - let itemToLks = collect ilr1kernelitemlkss prlk - (changed, ilr1kernelitemlkss') = - copy ilr1kernelitemlkss itemToLks- in if changed then prop ilr1kernelitemlkss'- else ilr1kernelitemlkss+-- | For each spontaneous lookahead, add it to the item when matched.+init'' :: Int -> Item -> Lookaheads -> [(Item, Int, Lookahead)] -> Lookaheads+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 - collect ilr1kernelitemlkss [] = []- collect ilr1kernelitemlkss (itemFromTo:itemFromTos) = - let (itemFrom, fromIndex, itemTo, toIndex) = itemFromTo - lookaheads = collect' itemFrom fromIndex [] ilr1kernelitemlkss - in (itemTo, toIndex, lookaheads) : collect ilr1kernelitemlkss itemFromTos+-- | Propagating lookaheads until no change+prop :: PropagateLookahead -> [(Int, [(Item, Lookaheads)])] -> [(Int, [(Item, Lookaheads)])]+prop prlk ilr1kernelitemlkss = + let itemToLks = collect ilr1kernelitemlkss prlk+ (changed, ilr1kernelitemlkss') = + copy ilr1kernelitemlkss itemToLks+ in if changed then prop prlk ilr1kernelitemlkss'+ else ilr1kernelitemlkss - 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 :: [(Int, [(Item, Lookaheads)])] -> PropagateLookahead -> [(Item, Int, Lookaheads)]+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 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) +collect' :: Item -> Int -> Lookaheads -> [(Int, [(Item, Lookaheads)])] -> Lookaheads+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 - 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)+collect'' :: Item -> Lookaheads -> [(Item, Lookaheads)] -> Lookaheads+collect'' itemFrom lookaheads [] = lookaheads+collect'' itemFrom lookaheads ((Item prule dot _, lks):itemlks) = + let Item pruleFrom dotFrom _ = itemFrom+ lookaheads' = if pruleFrom == prule && dotFrom == dot+ then accumLks lks lookaheads else lookaheads+ in collect'' itemFrom lookaheads' itemlks - 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) +-- | Eliminating space leak!+accumLks [] lookaheads = lookaheads+accumLks (lk:lks) lookaheads+ | lk `elem` lookaheads = accumLks lks lookaheads+ | otherwise = accumLks lks (lk : lookaheads) +copy :: [(Int, [(Item, Lookaheads)])] -> [(Item, Int, Lookaheads)] -> (Bool, [(Int, [(Item, Lookaheads)])])+copy iitemlkss [] = (False, iitemlkss)+copy iitemlkss (itemToLookahead:itemToLookaheads) = + let (changed1, iitemlkss1) = copy' iitemlkss itemToLookahead+ (changed2, iitemlkss2) = copy iitemlkss1 itemToLookaheads + in (changed1 || changed2, iitemlkss2) +copy' :: [(Int, [(Item, Lookaheads)])] -> (Item, Int, Lookaheads) -> (Bool, [(Int, [(Item, Lookaheads)])])+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'' :: Int -> [(Item, Lookaheads)] -> (Item, Int, Lookaheads) -> (Bool, [(Item, Lookaheads)])+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@@ -628,12 +795,12 @@ 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 +-- 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@@ -649,28 +816,28 @@ g actTbl [] = actTbl g actTbl ((i,x,a):triples) = - let bs = [a' == a | (i',x',a') <- actTbl, i' == i && x' == x ] in+ let bs = [ (i',x',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 + else if and [ a' == a | (_,_,a') <- bs ] then g actTbl triples else error ("Conflict: " ++ show (i,x,a) ++ " " - ++ show actTbl)+ ++ show bs) 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+ let bs = [ (i',x',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+ else if and [ j' == j | (_,_,j') <- bs] then h gtTbl triples else error ("Conflict: " ++ show (i,x,j) ++ " "- ++ show gtTbl)+ ++ show bs) (actionTable, gotoTable) = f [ if ys' == []@@ -688,7 +855,9 @@ , let h = head ys' , let to = indexItem "lr1ActionGotoTable(to)" items (goto augCfg item1 h) ]- ++prParseTable+ :: Handle -> (Itemss, ProductionRules, ParserTable.ActionTable,ParserTable.GotoTable) -> IO () prParseTable h (items, prules, actTbl, gtTbl) = do hPutStrLn h (show (length items) ++ " states") prItems h items@@ -698,7 +867,9 @@ prActTbl h actTbl hPutStrLn h "" prGtTbl h gtTbl- ++prLALRParseTable+ :: Handle -> (Itemss, ProductionRules, [[Int]], LALRActionTable, LALRGotoTable) -> IO () prLALRParseTable h (items, prules, iss, lalrActTbl, lalrGtTbl) = do hPutStrLn h (show (length items) ++ " states") prItems h items@@ -716,41 +887,51 @@ prStates h (is:iss) = do hPutStrLn h (show is) prStates h iss++prConflictsResolved conflictsResolved =+ do mapM_ (\(s,l,a1,a2) ->+ do putStr "Conflict resolved:"+ putStr $ " State " ++ show s+ putStr $ " on " ++ show l+ putStr $ " : " ++ show a1+ putStrLn $ " > " ++ show a2+ ) conflictsResolved+ ----------------------------------------------------------------------------------- LALR Parser +-- LALR Parser (See an efficient one abover) -------------------------------------------------------------------------------- -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'] +-- 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 ] ]+-- 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' ] ]+-- 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
src/gentable/ParserTable.hs view
@@ -61,6 +61,8 @@ type ActionTable = [(Int, ExtendedSymbol, Action)] -- state, terminal, action type GotoTable = [(Int, Symbol, Int)] -- state, nonterminal, state +type ConflictsResolved = [(Int, ExtendedSymbol, Action, Action)]+ lookupTable :: (Eq a, Eq b) => a -> b -> [(a,b,c)] -> Maybe c lookupTable i x [] = Nothing
src/parserlib/CommonParserUtil.hs view
@@ -1,804 +1,997 @@ {-# LANGUAGE GADTs #-} module CommonParserUtil- ( LexerSpec(..), ParserSpec(..), AutomatonSpec(..), HandleParseError(..)- , lexing, lexingWithLineColumn, parsing, runAutomaton, parsingHaskell, runAutomatonHaskell- , get, getText- , LexError(..), ParseError(..)- , successfullyParsed, handleLexError, handleParseError) where--import Terminal-import TokenInterface--import Text.Regex.TDFA-import System.Exit-import System.Process-import Control.Monad--import Data.Typeable-import Control.Exception--import SaveProdRules-import AutomatonType-import LoadAutomaton--import Data.List (nub)-import Data.Maybe--import SynCompInterface--import Prelude hiding (catch)-import System.Directory-import Control.Exception-import System.IO.Error hiding (catch)---- Lexer Specification-type RegExpStr = String-type LexFun token = String -> Maybe token --type LexerSpecList token = [(RegExpStr, LexFun token)]-data LexerSpec token =- LexerSpec { endOfToken :: token,- lexerSpecList :: LexerSpecList token- }---- Parser Specification-type ProdRuleStr = String-type ParseFun token ast = Stack token ast -> ast--type ParserSpecList token ast = [(ProdRuleStr, ParseFun token ast)]-data ParserSpec token ast =- ParserSpec { startSymbol :: String,- parserSpecList :: ParserSpecList token ast,- baseDir :: String, -- ex) ./- actionTblFile :: String, -- ex) actiontable.txt- gotoTblFile :: String, -- ex) gototable.txt- grammarFile :: String, -- ex) grammar.txt- parserSpecFile :: String, -- ex) mygrammar.grm- genparserexe :: String -- ex) genlrparse-exe- }---- Specification-data Spec token ast =- Spec (LexerSpec token) (ParserSpec token ast)---------------------------------------------------------------------------------- --- The lexing machine--------------------------------------------------------------------------------- -type Line = Int-type Column = Int-----data LexError = LexError Int Int String -- Line, Col, Text- deriving (Typeable, Show)--instance Exception LexError---- prLexError (CommonParserUtil.LexError line col text) = do--- putStr $ "No matching lexer spec at "--- putStr $ "Line " ++ show line--- putStr $ "Column " ++ show col--- putStr $ " : "--- putStr $ take 10 text-----lexing :: TokenInterface token =>- LexerSpec token -> String -> IO [Terminal token]-lexing lexerspec text = do- (line, col, terminalList) <- lexingWithLineColumn lexerspec 1 1 text- return terminalList--lexingWithLineColumn :: TokenInterface token =>- LexerSpec token -> Line -> Column -> String -> IO (Line, Column, [Terminal token])-lexingWithLineColumn lexerspec line col [] = do- let eot = endOfToken lexerspec - return (line, col, [Terminal (fromToken eot) line col (Just eot)])- -lexingWithLineColumn lexerspec line col text = do --Todo: make it tail-recursive!- (matchedText, theRestText, maybeTok) <-- matchLexSpec line col (lexerSpecList lexerspec) text- let (line_, col_) = moveLineCol line col matchedText- (line__, col__, terminalList) <- lexingWithLineColumn lexerspec line_ col_ theRestText- case maybeTok of- Nothing -> return (line__, col__, terminalList)- Just tok -> do- let terminal = Terminal matchedText line col (Just tok)- return (line__, col__, terminal:terminalList)--matchLexSpec :: TokenInterface token =>- Line -> Column -> LexerSpecList token -> String- -> IO (String, String, Maybe token)-matchLexSpec line col [] text = do- throw (CommonParserUtil.LexError line col text)- -- putStr $ "No matching lexer spec at "- -- putStr $ "Line " ++ show line- -- putStr $ "Column " ++ show col- -- putStr $ " : "- -- putStr $ take 10 text- -- exitWith (ExitFailure (-1))--matchLexSpec line col ((aSpec,tokenBuilder):lexerspec) text = do- let (pre, matched, post) = text =~ aSpec :: (String,String,String)- case pre of- "" -> return (matched, post, tokenBuilder matched)- _ -> matchLexSpec line col lexerspec text---moveLineCol :: Line -> Column -> String -> (Line, Column)-moveLineCol line col "" = (line, col)-moveLineCol line col ('\n':text) = moveLineCol (line+1) 1 text-moveLineCol line col (ch:text) = moveLineCol line (col+1) text- --------------------------------------------------------------------------------- --- The parsing machine-----------------------------------------------------------------------------------type CurrentState = Int-type StateOnStackTop = Int-type LhsSymbol = String--type AutomatonSnapshot token ast = -- TODO: Refactoring- (Stack token ast, ActionTable, GotoTable, ProdRules)-----data ParseError token ast where- -- teminal, state, stack actiontbl, gototbl- NotFoundAction :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>- (Terminal token) -> CurrentState -> (Stack token ast) -> ActionTable -> GotoTable -> ProdRules -> [Terminal token] -> ParseError token ast- - -- topState, lhs, stack, actiontbl, gototbl,- NotFoundGoto :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>- StateOnStackTop -> LhsSymbol -> (Stack token ast) -> ActionTable -> GotoTable -> ProdRules -> [Terminal token] -> ParseError token ast-- deriving (Typeable)--instance (Show token, Show ast) => Show (ParseError token ast) where- showsPrec p (NotFoundAction terminal state stack _ _ _ _) =- (++) "NotFoundAction: " . (++) (show state) . (++) " " . (++) (terminalToString terminal) -- (++) (show $ length stack)- showsPrec p (NotFoundGoto topstate lhs stack _ _ _ _) =- (++) "NotFoundGoto: " . (++) (show topstate) . (++) " " . (++) lhs -- . (++) (show stack)--instance (TokenInterface token, Typeable token, Show token, Typeable ast, Show ast)- => Exception (ParseError token ast)---- prParseError (NotFoundAction terminal state stack actiontbl gototbl prodRules terminalList) = do--- putStrLn $--- ("Not found in the action table: "--- ++ terminalToString terminal)--- ++ " : "--- ++ show (state, tokenTextFromTerminal terminal)--- ++ " (" ++ show (length terminalList) ++ ")"--- ++ "\n" ++ prStack stack ++ "\n"- --- prParseError (NotFoundGoto topState lhs stack actiontbl gototbl prodRules terminalList) = do--- putStrLn $--- ("Not found in the goto table: ")--- ++ " : "--- ++ show (topState,lhs) ++ "\n"--- ++ " (" ++ show (length terminalList) ++ ")"--- ++ prStack stack ++ "\n"-----parsing flag parserSpec terminalList =- parsingHaskell flag parserSpec terminalList Nothing- -parsingHaskell :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>- Bool -> ParserSpec token ast -> [Terminal token] -> Maybe token -> IO ast-parsingHaskell flag parserSpec terminalList haskellOption = do- -- 1. Save the production rules in the parser spec (Parser.hs).- writtenBool <- saveProdRules specFileName sSym pSpecList-- -- 2. If the grammar file is written,- -- run the following command to generate prod_rules/action_table/goto_table files.- -- stack exec -- yapb-exe mygrammar.grm -output prod_rules.txt action_table.txt goto_table.txt- when writtenBool generateAutomaton-- -- 3. Load automaton files (prod_rules/action_table/goto_table.txt)- (actionTbl, gotoTbl, prodRules) <-- loadAutomaton grammarFileName actionTblFileName gotoTblFileName-- -- 4. Run the automaton- if null actionTbl || null gotoTbl || null prodRules- then do let hashFile = getHashFileName specFileName- putStrLn $ "Delete " ++ hashFile- removeIfExists hashFile- error $ "Error: Empty automation: please rerun"- else do ast <- runAutomatonHaskell flag- (AutomatonSpec {- am_initState=initState,- am_actionTbl=actionTbl,- am_gotoTbl=gotoTbl,- am_prodRules=prodRules,- am_parseFuns=pFunList })- terminalList haskellOption- -- putStrLn "done." -- It was for the interafce with Java-version RPC calculus interpreter.- return ast-- where- specFileName = parserSpecFile parserSpec- grammarFileName = grammarFile parserSpec- actionTblFileName = actionTblFile parserSpec- gotoTblFileName = gotoTblFile parserSpec- - sSym = startSymbol parserSpec- pSpecList = map fst (parserSpecList parserSpec)- pFunList = map snd (parserSpecList parserSpec)-- generateAutomaton = do- exitCode <- rawSystem "stack"- [ "exec", "--",- "yapb-exe", specFileName, "-output",- grammarFileName, actionTblFileName, gotoTblFileName- ]- case exitCode of- ExitFailure code -> exitWith exitCode- ExitSuccess -> putStrLn ("Successfully generated: " ++- actionTblFileName ++ ", " ++- gotoTblFileName ++ ", " ++- grammarFileName);----removeIfExists :: FilePath -> IO ()-removeIfExists fileName = removeFile fileName `catch` handleExists- where handleExists e- | isDoesNotExistError e = return ()- | otherwise = throwIO e---- Stack--data StkElem token ast =- StkState Int- | StkTerminal (Terminal token)- | StkNonterminal (Maybe ast) String -- String for printing Nonterminal instead of ast--instance TokenInterface token => Eq (StkElem token ast) where- (StkState i) == (StkState j) = i == j- (StkTerminal termi) == (StkTerminal termj) = tokenTextFromTerminal termi == tokenTextFromTerminal termj- (StkNonterminal _ si) == (StkNonterminal _ sj) = si == sj--type Stack token ast = [StkElem token ast]--emptyStack = []--get :: Stack token ast -> Int -> ast-get stack i =- case stack !! (i-1) of- StkNonterminal (Just ast) _ -> ast- StkNonterminal Nothing _ -> error $ "get: empty ast in the nonterminal at stack"- _ -> error $ "get: out of bound: " ++ show i--getText :: Stack token ast -> Int -> String-getText stack i = - case stack !! (i-1) of- StkTerminal (Terminal text _ _ _) -> text- _ -> error $ "getText: out of bound: " ++ show i--push :: a -> [a] -> [a]-push elem stack = elem:stack--pop :: [a] -> (a, [a])-pop (elem:stack) = (elem, stack)-pop [] = error "Attempt to pop from the empty stack"--prStack :: TokenInterface token => Stack token ast -> String-prStack [] = "STACK END"-prStack (StkState i : stack) = "S" ++ show i ++ " : " ++ prStack stack-prStack (StkTerminal (Terminal text _ _ (Just token)) : stack) =- let str_token = fromToken token in- (if str_token == text then str_token else (fromToken token ++ " i.e. " ++ text))- ++ " : " ++ prStack stack-prStack (StkTerminal (Terminal text _ _ Nothing) : stack) =- (token_na ++ " " ++ text) ++ " : " ++ prStack stack-prStack (StkNonterminal _ str : stack) = str ++ " : " ++ prStack stack---- Utility for Automation-currentState :: Stack token ast -> Int-currentState (StkState i : stack) = i-currentState _ = error "No state found in the stack top"--tokenTextFromTerminal :: TokenInterface token => Terminal token -> String-tokenTextFromTerminal (Terminal _ _ _ (Just token)) = fromToken token-tokenTextFromTerminal (Terminal _ _ _ Nothing) = token_na--lookupActionTable :: TokenInterface token => ActionTable -> Int -> (Terminal token) -> Maybe Action-lookupActionTable actionTbl state terminal =- lookupTable actionTbl (state,tokenTextFromTerminal terminal)- ("Not found in the action table: " ++ terminalToString terminal) --lookupGotoTable :: GotoTable -> Int -> String -> Maybe Int-lookupGotoTable gotoTbl state nonterminalStr =- lookupTable gotoTbl (state,nonterminalStr)- ("Not found in the goto table: ")--lookupTable :: (Eq a, Show a) => [(a,b)] -> a -> String -> Maybe b-lookupTable tbl key msg = - case [ val | (key', val) <- tbl, key==key' ] of- [] -> Nothing -- error $ msg ++ " : " ++ show key- (h:_) -> Just h----- Note: take 1th, 3rd, 5th, ... of 2*len elements from stack and reverse it!--- example) revTakeRhs 2 [a1,a2,a3,a4,a5,a6,...]--- = [a4, a2]-revTakeRhs :: Int -> [a] -> [a]-revTakeRhs 0 stack = []-revTakeRhs n (_:nt:stack) = revTakeRhs (n-1) stack ++ [nt]---- Automaton--data AutomatonSpec token ast =- AutomatonSpec {- am_actionTbl :: ActionTable,- am_gotoTbl :: GotoTable,- am_prodRules :: ProdRules,- am_parseFuns :: ParseFunList token ast,- am_initState :: Int- }--initState = 0--type ParseFunList token ast = [ParseFun token ast]--runAutomaton flag amSpec terminalList =- runAutomatonHaskell flag amSpec {- initState actionTbl gotoTbl prodRules pFunList-} terminalList Nothing--runAutomatonHaskell :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>- Bool -> - {- static part ActionTable -> GotoTable -> ProdRules -> ParseFunList token ast -> -}- AutomatonSpec token ast -> - {- dynamic part -}- [Terminal token] ->- {- haskell parser specific option -}- Maybe token ->- {- AST -}- IO ast-runAutomatonHaskell flag (rm_spec @ AutomatonSpec {- am_initState=initState,- am_actionTbl=actionTbl,- am_gotoTbl=gotoTbl,- am_prodRules=prodRules,- am_parseFuns=pFunList- }) terminalList haskellOption = do- let initStack = push (StkState initState) emptyStack- run terminalList initStack- - where- {- run :: TokenInterface token => [Terminal token] -> Stack token ast -> IO ast -}- run terminalList stack = do- let state = currentState stack- let terminal = head terminalList- case lookupActionTable actionTbl state terminal of- Just action -> do- -- putStrLn $ terminalToString terminal {- debug -}- runAction state terminal action terminalList stack- - Nothing -> do- putStrLn $ "lookActionTable failed (1st) with: " ++ show (terminalToString terminal)- case haskellOption of- Just extraToken -> do- let terminal_close_brace = Terminal- (fromToken extraToken)- (terminalToLine terminal)- (terminalToCol terminal)- (Just extraToken)- case lookupActionTable actionTbl state terminal_close_brace of- Just action -> do- -- putStrLn $ terminalToString terminal_close_brace {- debug -}- putStrLn $ "lookActionTable succeeded (2nd) with: " ++ terminalToString terminal_close_brace- runAction state terminal_close_brace action (terminal_close_brace : terminalList) stack- - Nothing -> do- putStrLn $ "lookActionTable failed (2nd) with: " ++ terminalToString terminal_close_brace- throw (NotFoundAction terminal state stack actionTbl gotoTbl prodRules terminalList)- -- Nothing -> throw (NotFoundAction terminal_close_brace state stack actionTbl gotoTbl prodRules- -- (terminal_close_brace : terminalList))- - Nothing -> throw (NotFoundAction terminal state stack actionTbl gotoTbl prodRules terminalList)-- -- separated to support the haskell layout rule- runAction state terminal action terminalList stack = do - debug flag ("\nState " ++ show state)- debug flag ("Token " ++ tokenTextFromTerminal terminal)- debug flag ("Stack " ++ prStack stack)- - case action of- Accept -> do- debug flag "Accept"- debug flag $ terminalToString terminal {- debug -}- - case stack !! 1 of- StkNonterminal (Just ast) _ -> return ast- StkNonterminal Nothing _ -> fail "Empty ast in the stack nonterminal"- _ -> fail "Not Stknontermianl on Accept"- - Shift toState -> do- debug flag ("Shift " ++ show toState)- debug flag $ terminalToString terminal {- debug -}- - let stack1 = push (StkTerminal (head terminalList)) stack- let stack2 = push (StkState toState) stack1- run (tail terminalList) stack2- - Reduce n -> do- debug flag ("Reduce " ++ show n)- - let prodrule = prodRules !! n- - debug flag ("\t" ++ show prodrule)- - let builderFun = pFunList !! n- let lhs = fst prodrule- let rhsLength = length (snd prodrule)- let rhsAst = revTakeRhs rhsLength stack- let ast = builderFun rhsAst- let stack1 = drop (rhsLength*2) stack- let topState = currentState stack1- let toState =- case lookupGotoTable gotoTbl topState lhs of- Just state -> state- Nothing -> throw (NotFoundGoto topState lhs stack actionTbl gotoTbl prodRules terminalList)- - let stack2 = push (StkNonterminal (Just ast) lhs) stack1- let stack3 = push (StkState toState) stack2- run terminalList stack3--debug :: Bool -> String -> IO ()-debug flag msg = if flag then putStrLn msg else return ()--prlevel n = take n (let spaces = ' ' : spaces in spaces)---- | Computing candidates--data Candidate = -- Todo: data Candidate vs. data EmacsDataItem = ... | Candidate String - TerminalSymbol String- | NonterminalSymbol String- deriving Eq--instance Show Candidate where- showsPrec p (TerminalSymbol s) = (++) $ "Terminal " ++ s- showsPrec p (NonterminalSymbol s) = (++) $ "Nonterminal " ++ s--data Automaton token ast =- Automaton {- actTbl :: ActionTable,- gotoTbl :: GotoTable,- prodRules :: ProdRules- }--data CompCandidates token ast = CompCandidates {- cc_debugFlag :: Bool,- cc_searchMaxLevel :: Int,- cc_simpleOrNested :: Bool,- cc_automaton :: Automaton token ast- }- -compCandidates- :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>- CompCandidates token ast- -> Int- -> [Candidate]- -> Int- -> Stack token ast- -> IO [[Candidate]]--compCandidates ccOption level symbols state stk = do- compGammasDfs ccOption level symbols state stk []--- gammas <- compGammasDfs isSimple level symbols state automaton stk []--- if isSimple--- then return gammas--- else return $ tail $ scanl (++) [] (filter (not . null) gammas)--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_searchMaxLevel ccOption- isSimple = cc_simpleOrNested ccOption- automaton = cc_automaton ccOption- - actionTable = actTbl automaton- gotoTable = gotoTbl automaton- productionRules = prodRules automaton- in- if level > maxLevel then- return (if null symbols then [] else [symbols])- else- checkCycle flag False level state stk "" history- (\history ->- {- 1. Reduce -}- case nub [prnum | ((s,lookahead),Reduce prnum) <- actionTable, state==s] of- [] ->- {- 2. Goto table -}- case nub [(nonterminal,toState) | ((fromState,nonterminal),toState) <- gotoTable, state==fromState] of- [] ->- {- 3. Accept -}- if length [True | ((s,lookahead),Accept) <- actionTable, state==s] >= 1- then do - 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- [] -> return []- - _ -> do listOfList <-- mapM (\ ((terminal,snext),i)->- let stk1 = push (StkTerminal (Terminal terminal 0 0 Nothing)) stk -- Todo: ??? (toToken terminal)- stk2 = push (StkState snext) stk1- in - -- checkCycle False level snext stk2 ("SHIFT " ++ show snext ++ " " ++ terminal) history- -- checkCycle True level state stk terminal history- checkCycle flag True level snext stk2 terminal history- - (\history1 -> do- debug flag $ prlevel level ++ "SHIFT [" ++ show i ++ "/" ++ show len ++ "]: "- ++ show state ++ " -> " ++ terminal ++ " -> " ++ show snext- debug flag $ prlevel level ++ "Goto/Shift symbols: " ++ show (symbols++[TerminalSymbol terminal])- debug flag $ prlevel level ++ "Stack " ++ prStack stk2- debug flag $ ""- 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 -> do- debug flag $ prlevel level ++ "GOTO [" ++ show i ++ "/" ++ show len ++ "] at "- ++ show state ++ " -> " ++ show nonterminal ++ " -> " ++ show snext- debug flag $ prlevel level ++ "Goto/Shift symbols:" ++ show (symbols++[NonterminalSymbol nonterminal])- debug flag $ prlevel level ++ "Stack " ++ prStack stk2- debug flag $ ""- - compGammasDfs ccOption (level+1) (symbols++[NonterminalSymbol nonterminal]) snext stk2 history1) )- (zip nontermStateList [1..])- return $ concat listOfList-- prnumList -> do- let len = length prnumList- - debug flag $ prlevel level ++ "# of prNumList to reduce: " ++ show len ++ " at State " ++ show state- debug flag $ prlevel (level+1) ++ show [ productionRules !! prnum | prnum <- prnumList ]- - -- let aCandidate = if null symbols then [] else [symbols]- -- if isSimple- -- then return aCandidate- -- else do listOfList <-- do listOfList <-- mapM (\ (prnum,i) -> (- -- checkCycle False level state stk ("REDUCE " ++ show prnum) history- checkCycle flag True level state stk (show prnum) history- (\history1 -> do- debug flag $ prlevel level ++ "State " ++ show state ++ "[" ++ show i ++ "/" ++ show len ++ "]" - debug flag $ prlevel level ++ "REDUCE" ++ " prod #" ++ show prnum- debug flag $ prlevel level ++ show (productionRules !! prnum)- debug flag $ prlevel level ++ "Goto/Shift symbols: " ++ show symbols- debug flag $ prlevel level ++ "Stack " ++ prStack stk- 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- maxLevel = cc_searchMaxLevel ccOption- isSimple = cc_simpleOrNested ccOption- automaton = cc_automaton ccOption- - actionTable = actTbl automaton- gotoTable = gotoTbl automaton- productionRules = prodRules automaton- in- let prodrule = productionRules !! prnum- lhs = fst prodrule- rhs = snd prodrule- - rhsLength = length rhs- in - if ( {- rhsLength == 0 || -} (rhsLength > length symbols) ) == False- then do- debug flag $ prlevel level ++ "[LEN COND: False] length rhs > length symbols: NOT "- ++ show rhsLength ++ ">" ++ show (length symbols)- debug flag $ prlevel (level+1) ++ show symbols- debug flag $ prlevel level- return [] -- Todo: (if null symbols then [] else [symbols])- else do- let stk1 = drop (rhsLength*2) stk- let topState = currentState stk1- let toState =- case lookupGotoTable gotoTable topState lhs of- Just state -> state- Nothing -> error $ "[compGammasDfsForReduce] Must not happen: lhs: "- ++ lhs ++ " state: " ++ show topState- let stk2 = push (StkNonterminal Nothing lhs) stk1 -- ast- let stk3 = push (StkState toState) stk2- debug flag $ prlevel level ++ "GOTO after REDUCE: "- ++ show topState ++ " " ++ lhs ++ " " ++ show toState- debug flag $ prlevel level ++ "Goto/Shift symbols: " ++ "[]"- debug flag $ prlevel level ++ "Stack " ++ prStack stk3- debug flag $ ""-- debug flag $ prlevel level ++ "Found a gamma: " ++ show symbols- debug flag $ ""-- if isSimple- 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))---- | Cycle checking-noCycleCheck :: Bool-noCycleCheck = True--checkCycle debugflag flag level state stk action history cont =- if flag && (state,stk,action) `elem` history- then do- debug debugflag $ prlevel level ++ "CYCLE is detected !!"- debug debugflag $ prlevel level ++ show state ++ " " ++ action- debug debugflag $ prlevel level ++ prStack stk- debug debugflag $ ""- return []- else cont ( (state,stk,action) : history )---- | Parsing programming interfaces---- | successfullyParsed-successfullyParsed :: IO [EmacsDataItem]-successfullyParsed = return [SynCompInterface.SuccessfullyParsed]---- | handleLexError-handleLexError :: IO [EmacsDataItem]-handleLexError = return [SynCompInterface.LexError]--data HandleParseError token = HandleParseError {- debugFlag :: Bool,- searchMaxLevel :: Int,- simpleOrNested :: Bool,- postTerminalList :: [Terminal token],- nonterminalToStringMaybe :: Maybe (String->String)- }---- | handleParseError--- handleParseError :: TokenInterface token => Bool -> Int -> Bool -> [Terminal token] -> ParseError token ast -> IO [EmacsDataItem]--- handleParseError flag maxLevel isSimple terminalListAfterCursor parseError =--- unwrapParseError flag maxLevel isSimple terminalListAfterCursor parseError- -handleParseError :: TokenInterface token => HandleParseError token -> ParseError token ast -> IO [EmacsDataItem]-handleParseError hpeOption parseError = unwrapParseError hpeOption parseError- -unwrapParseError hpeOption (NotFoundAction _ state stk _actTbl _gotoTbl _prodRules terminalList) = do- let automaton = Automaton {actTbl=_actTbl, gotoTbl=_gotoTbl, prodRules=_prodRules}- arrivedAtTheEndOfSymbol hpeOption state stk automaton terminalList-unwrapParseError hpeOption (NotFoundGoto state _ stk _actTbl _gotoTbl _prodRules terminalList) = do- let automaton = Automaton {actTbl=_actTbl, gotoTbl=_gotoTbl, prodRules=_prodRules}- arrivedAtTheEndOfSymbol hpeOption state stk automaton terminalList--arrivedAtTheEndOfSymbol hpeOption state stk automaton terminalList = do- if length terminalList == 1 then do -- [$]- _handleParseError hpeOption state stk automaton- else do- putStrLn $ "length terminalList /= 1 : " ++ show (length terminalList)- mapM_ (\t -> putStrLn $ terminalToString $ t) terminalList- return [SynCompInterface.ParseError (map terminalToString terminalList)]--_handleParseError- (hpeOption @ HandleParseError {- debugFlag=flag,- searchMaxLevel=maxLevel,- simpleOrNested=isSimple,- postTerminalList=terminalListAfterCursor,- nonterminalToStringMaybe=_nonterminalToStringMaybe})- state stk automaton = do- let ccOption = CompCandidates {- cc_debugFlag=flag,- cc_searchMaxLevel=maxLevel,- cc_simpleOrNested=isSimple,- cc_automaton=automaton }- candidateListList <- compCandidates ccOption 0 [] state stk- let colorListList_symbols =- [ filterCandidates candidateList terminalListAfterCursor- | candidateList <- candidateListList ]- let convFun =- case _nonterminalToStringMaybe of- Nothing -> \s -> "..."- Just fn -> fn- let colorListList_ = map (stringfyCandidates convFun) colorListList_symbols- let colorListList = map collapseCandidates colorListList_- let strList = nub [ concatStrList strList | strList <- map (map showEmacsColor) colorListList ]- let rawStrListList = nub [ strList | strList <- map (map showRawEmacsColor) colorListList ]- debug flag $ showConcat $ map (\x -> (show x ++ "\n")) colorListList_symbols- debug flag $ showConcat $ map (\x -> (show x ++ "\n")) rawStrListList -- mapM_ (putStrLn . show) rawStrListList- return $ map Candidate strList- - where- showConcat [] = ""- showConcat (s:ss) = s ++ " " ++ showConcat ss- --- | Filter the given candidates with the following texts-data EmacsColor =- Gray String Line Column -- Overlapping with some in the following text- | White String -- Not overlapping- deriving (Show, Eq)---- for debugging EmacsColor in terms of symbols before they are stringfied-data EmacsColorCandidate =- GrayCandidate Candidate Line Column -- Overlapping with some in the following text- | WhiteCandidate Candidate -- Not overlapping- deriving Eq--instance Show EmacsColorCandidate where- showsPrec p (GrayCandidate c lin col) = (++) $ "Gray " ++ show c- showsPrec p (WhiteCandidate c) = (++) $ "White " ++ show c--filterCandidates :: (TokenInterface token) => [Candidate] -> [Terminal token] -> [EmacsColorCandidate]-filterCandidates candidates terminalListAfterCursor =- f candidates terminalListAfterCursor []- where- f (a:alpha) (b:beta) accm- | equal a b = f alpha beta (GrayCandidate a (terminalToLine b) (terminalToCol b) : accm)- | otherwise = f alpha (b:beta) (WhiteCandidate a : accm)- f [] beta accm = reverse accm- f (a:alpha) [] accm = f alpha [] (WhiteCandidate a : accm)-- equal (TerminalSymbol s1) (Terminal s2 _ _ _) = s1==s2- equal (NonterminalSymbol s1) _ = False--stringfyCandidates :: (String -> String) -> [EmacsColorCandidate] -> [EmacsColor]-stringfyCandidates convFun candidates = map stringfyCandidate candidates- where- stringfyCandidate (GrayCandidate sym line col) = Gray (strCandidate sym) line col- stringfyCandidate (WhiteCandidate sym) = White (strCandidate sym)-- strCandidate (TerminalSymbol s) = s- strCandidate (NonterminalSymbol s) = convFun s -- "..." -- ++ s ++ "..."--collapseCandidates [] = []-collapseCandidates [a] = [a]-collapseCandidates ((Gray "..." l1 c1) : (Gray "..." l2 c2) : cs) =- collapseCandidates ((Gray "..." l2 c2) : cs)-collapseCandidates ((White "...") : (White "...") : cs) =- collapseCandidates ((White "...") : cs) -collapseCandidates (a:b:cs) = a : collapseCandidates (b:cs)---- | Utilities-showSymbol (TerminalSymbol s) = s-showSymbol (NonterminalSymbol _) = "..."--showRawSymbol (TerminalSymbol s) = s-showRawSymbol (NonterminalSymbol s) = s--showEmacsColor (Gray s line col) = "gray " ++ s ++ " " ++ show line ++ " " ++ show col ++ " "-showEmacsColor (White s) = "white " ++ s--showRawEmacsColor (Gray s line col) = s ++ "@" ++ show line ++ "," ++ show col ++ " "-showRawEmacsColor (White s) = s--concatStrList [] = "" -- error "The empty candidate?"-concatStrList [str] = str-concatStrList (str:strs) = str ++ " " ++ concatStrList strs---- Q. Can we make it be typed???------ computeCandWith :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast)--- => LexerSpec token -> ParserSpec token ast--- -> String -> Bool -> Int -> IO [EmacsDataItem]--- computeCandWith lexerSpec parserSpec str isSimple cursorPos = ((do--- terminalList <- lexing lexerSpec str --- ast <- parsing parserSpec terminalList --- successfullyParsed)--- `catch` \e -> case e :: LexError of _ -> handleLexError--- `catch` \e -> case e :: ParseError token ast of _ -> handleParseError isSimple e) + ( LexerSpec(..), ParserSpec(..), AutomatonSpec(..)+ , LexerParserState, Line, Column+ , ProdRuleStr, ParseAction, ProdRulePrec+ , Stack, StkElem(..), push, pop, prStack+ , currentState, lookupGotoTable, lookupActionTable, lookupActionTableWithError+ , isReducible+ , toChildren+ , checkCycle -- SynCompAlgoPEPM only+ , HandleParseError(..), defaultHandleParseError+ , matchLexSpec, LexAction, aLexer+ , lexing, lexingWithLineColumn, _lexingWithLineColumn+ , parsing+ , initState, runAutomaton+ , get, getText+ , LexError(..), ParseError(..), lpStateFrom+ , successfullyParsed, handleLexError, handleParseError)+where++import Attrs+import Terminal+import TokenInterface++import Text.Regex.TDFA+import System.Exit+import System.Process+import Control.Monad+import qualified Control.Monad.Trans.State.Lazy as ST+import Control.Monad.Trans.Class++import Data.Typeable+import Control.Exception++import SaveProdRules+import AutomatonType+import LoadAutomaton++import Data.List (nub)+import Data.Maybe++import SynCompAlgoUtil+import SynCompInterface++import Config++import Prelude hiding (catch)+import Debug.Trace (trace)+import System.Directory+import Control.Exception+import System.IO.Error hiding (catch)++-- | Common parser utilities:+-- |+-- | 1. A parser(and lexer) specification interface to the parser generator+-- | 2. An automation executor+-- | 3. A generator for syntax completion candidates+-- | +-- | (TODO: Need to modularize these utilities)++-- | A Lexer and Parser Monad+-- |+-- | - Common elements : line, column, text+-- | - Extended elements : a (E.g., what the lexer and the parser want to share)+-- | - Extended effects : m (E.g., typically, IO)++type Line = Int+type Column = Int+type LexerParserState a = (a, Line, Column, String) -- Lexer and parser states++type LexerParserMonad m a = ST.StateT (LexerParserState a) m++--------------------------------------------------------------------------------+-- | Lexer Specification+--------------------------------------------------------------------------------++type RegExpStr = String+type LexAction token m a = String -> LexerParserMonad m a (Maybe token)++type RegexprActionList token m a = [(RegExpStr, LexAction token m a)]++data LexerSpec token m a =+ LexerSpec+ { endOfToken :: token,+ lexerSpecList :: RegexprActionList token m a }++-- | Token precedence and associativity: TokenPrecAssoc token+-- |+-- | e.g., [ (Nonassoc, [ "integer_number" ])+-- | , (Left, [ "+", "-" ])+-- | , (Left, [ "*", "/" ])+-- | , (Right, [ "UMINUS" ]) -- placeholder+-- | ]++type TokenPrecAssoc = [(Associativity, [TokenOrPlaceholder])]++--------------------------------------------------------------------------------+-- | Parser Specification+-- | A -> rhs %prec <token> {action}+--------------------------------------------------------------------------------++type ProdRuleStr = String -- A -> rhs+type ParseAction token ast m a = -- {action}+ Stack token ast -> LexerParserMonad m a ast+type ProdRulePrec = Maybe TokenOrPlaceholder -- %prec <token>+type ProdRulePrecs = [ProdRulePrec]++type ParserSpecList token ast m a = [(ProdRuleStr, ParseAction token ast m a, ProdRulePrec)]++data ParserSpec token ast m a =+ ParserSpec { startSymbol :: String,+ tokenPrecAssoc :: TokenPrecAssoc,+ parserSpecList :: ParserSpecList token ast m a,+ baseDir :: String, -- ex) ./+ actionTblFile :: String, -- ex) actiontable.txt+ gotoTblFile :: String, -- ex) gototable.txt+ grammarFile :: String, -- ex) grammar.txt+ parserSpecFile :: String, -- ex) mygrammar.grm+ genparserexe :: String -- ex) genlrparse-exe+ }++--------------------------------------------------------------------------------+-- | Stack+--------------------------------------------------------------------------------++data StkElem token ast =+ StkState Int+ | StkTerminal (Terminal token)+ | StkNonterminal (Maybe ast) String -- String for printing Nonterminal instead of ast++instance TokenInterface token => Eq (StkElem token ast) where+ (StkState i) == (StkState j) = i == j+ (StkTerminal termi) == (StkTerminal termj) =+ tokenTextFromTerminal termi == tokenTextFromTerminal termj+ (StkNonterminal _ si) == (StkNonterminal _ sj) = si == sj+ leftStkElm == rightStkElm = False++type Stack token ast = [StkElem token ast]++get :: TokenInterface token => Stack token ast -> Int -> ast+get stack i =+ case stack !! (i-1) of+ StkNonterminal (Just ast) _ -> ast+ StkNonterminal Nothing _ -> error $ "get: empty ast in the nonterminal at stack"+ StkState s -> error $ "get: out of bound: " ++ show i ++ " : state " ++ show s+ StkTerminal terminal -> error $ "get: out of bound: " ++ show i ++ " : terminal " ++ terminalToSymbol terminal++getText :: Stack token ast -> Int -> String+getText stack i = + case stack !! (i-1) of+ StkTerminal (Terminal text _ _ _) -> text+ _ -> error $ "getText: out of bound: " ++ show i++emptyStack = []++push :: a -> [a] -> [a]+push elem stack = elem:stack++pop :: [a] -> (a, [a])+pop (elem:stack) = (elem, stack)+pop [] = error "Attempt to pop from the empty stack"++prStack :: TokenInterface token => Stack token ast -> String+prStack [] = "STACK END"+prStack (StkState i : stack) = "S" ++ show i ++ " : " ++ prStack stack+prStack (StkTerminal (Terminal text _ _ (Just token)) : stack) =+ let str_token = fromToken token in+ (if str_token == text then str_token else (fromToken token ++ " i.e. " ++ text))+ ++ " : " ++ prStack stack+prStack (StkTerminal (Terminal text _ _ Nothing) : stack) =+ (token_na ++ " " ++ text) ++ " : " ++ prStack stack+prStack (StkNonterminal _ str : stack) = str ++ " : " ++ prStack stack++-- -- Specification+-- data Spec token ast =+-- Spec (LexerSpec token) (ParserSpec token ast)++-------------------------------------------------------------------------------- +-- | The lexing machine+-------------------------------------------------------------------------------- ++data LexError = LexError Int Int String -- Line, Col, Text+ deriving (Typeable, Show)++instance Exception LexError++-- LexError line col text+-- - "No matching lexer spec at "+-- - "Line " ++ show line+-- - "Column " ++ show col+-- - " : "+-- - take 10 text++-- | Matched token = (text, optional token, spec)+type MatchedSpec = String+type MatchedToken token = (String, Maybe token, MatchedSpec)+++--------------------------------------------------------------------------------+-- | [Core] A demand-driven lexer+--------------------------------------------------------------------------------++matchLexSpec :: (Monad m, TokenInterface token) =>+ Bool -> token -> RegexprActionList token m a -- token => End Of token!+ -> LexerParserMonad m a (MatchedToken token)++matchLexSpec debugFlag eot lexerspec =+ mls debugFlag eot lexerspec++ where+ mls+ :: (Monad m, TokenInterface token) =>+ Bool+ -> token+ -> RegexprActionList token m a+ -> ST.StateT (LexerParserState a) m (MatchedToken token)+ mls debugFlag eot lexerspec =+ do (state_parm, line, col, text) <- ST.get+ mlsSub debugFlag eot lexerspec (state_parm, line, col, text)++ mlsSub+ :: (Monad m, TokenInterface token) =>+ Bool+ -> token+ -> RegexprActionList token m a+ -> (LexerParserState a)+ -> ST.StateT (LexerParserState a) m (MatchedToken token)+ mlsSub debugFlag eot lexerspec (state_parm, line, col, []) =+ do ST.put (state_parm, line+1, 1, []) -- EOT at (line+1,1)?+ return (fromToken eot, Just eot, fromToken eot)++ mlsSub debugFlag eot [] (state_parm, line, col, text) = do+ throw (CommonParserUtil.LexError line col (takeRet 0 text))++ mlsSub debugFlag eot ((aSpec,tokenBuilder):lexerspec) (state_parm, line, col, text) = do+ let (pre, matched, post) = text =~ aSpec :: (String,String,String)+ case pre of+ "" -> let (line_, col_) = moveLineCol line col matched in+ if line==line_ && col==col_+ then+ throw (CommonParserUtil.LexError line col ("Found RegExp for \"\"? " ++ aSpec))++ else+ do maybeTok <- tokenBuilder matched++ let str_maybeTok =+ if isNothing maybeTok+ then "Nothing"+ else (fromToken (fromJust maybeTok))++ (state_parm_, _, _, _) <- ST.get+ ST.put (state_parm_, line_, col_, post)++ debug debugFlag "" $ ++ debug debugFlag ("Lexer: - " ++ show aSpec ++ " " ++ matched ++ " at " ++ show (line, col)) $+ debug debugFlag (" - returns: " ++ if isNothing maybeTok then "Nothing" else str_maybeTok) $++ return (matched, maybeTok, aSpec)++ _ -> mlsSub debugFlag eot lexerspec (state_parm, line, col, text)++takeRet n [] = ""+takeRet 0 ('\n':text) = '\n' : takeRet 0 text+takeRet n ('\n':text) = ""+takeRet n (c:text) = c : (takeRet (n+1) text)++moveLineCol :: Line -> Column -> String -> (Line, Column)+moveLineCol line col "" = (line, col)+moveLineCol line col ('\n':text) = moveLineCol (line+1) 1 text+moveLineCol line col (ch:text) = moveLineCol line (col+1) text+++-- | Repeat matchLexSpec until all tokens are retrieved+repMatchLexSpec :: (Monad m, TokenInterface token) =>+ Bool -> token -> RegexprActionList token m a -> -- token => End Of token!+ LexerParserMonad m a [Terminal token]+repMatchLexSpec debugFlag eot lexerspec =+ repMLS debugFlag eot lexerspec []+ + where+ repMLS debugFlag eot lexerspec terminalList =+ do (_, line, col, _) <- ST.get++ (text, maybeToken, lexSpec) <-+ matchLexSpec debugFlag eot lexerspec++ case maybeToken of+ Just token ->+ if isEOT token+ then return (reverse terminalList)+ else do repMLS debugFlag eot lexerspec+ (Terminal text line col maybeToken : terminalList)++ Nothing -> repMLS debugFlag eot lexerspec terminalList++-- | Getting the next token++type Lexer m a token = LexerParserMonad m a (Terminal token)+type BoolToLexer m a token = Bool -> LexerParserMonad m a (Terminal token)++aLexer+ :: (Monad m, TokenInterface token) =>+ LexerSpec token m a -> + Bool -> LexerParserMonad m a (Terminal token)+aLexer lexerSpec =+ let eot = endOfToken lexerSpec+ regexprActionList = lexerSpecList lexerSpec++ boolToLexer flag = + do (_, line, col, _) <- ST.get++ (matchedText, maybeTok, _) <- matchLexSpec flag eot regexprActionList++ case maybeTok of+ Nothing -> boolToLexer flag + Just tok -> return (Terminal matchedText line col maybeTok)+ + in boolToLexer++-- | Lexing only intefaces+lexing :: (Monad m, TokenInterface token) =>+ LexerSpec token m a -> a -> String -> m [Terminal token]+lexing lexerspec state_parm text = do+ lexingWithLineColumn lexerspec state_parm 1 1 text+++lexingWithLineColumn :: (Monad m, TokenInterface token) =>+ LexerSpec token m a -> a -> Line -> Column -> String -> m [Terminal token]+lexingWithLineColumn lexerspec state_parm line col text =+ _lexingWithLineColumn False lexerspec state_parm line col text+++_lexingWithLineColumn :: (Monad m, TokenInterface token) =>+ Bool -> LexerSpec token m a -> a -> Line -> Column -> String -> m [Terminal token]+_lexingWithLineColumn debugFlag lexerspec state_parm line col text =+ do terminalList <-+ ST.evalStateT+ (repMatchLexSpec debugFlag (endOfToken lexerspec) (lexerSpecList lexerspec))+ (state_parm, line, col, text)++ return terminalList+++-------------------------------------------------------------------------------- +-- The parsing machine with parse/lex errors+--------------------------------------------------------------------------------++type CurrentState = Int+type StateOnStackTop = Int+type LhsSymbol = String++type AutomatonSnapshot token ast = -- TODO: Refactoring+ (Stack token ast, ActionTable, GotoTable, ProdRules)++--+data ParseError token ast a where+ -- teminal, state, stack actiontbl, gototbl+ NotFoundAction ::+ (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ (Terminal token) -> CurrentState -> (Stack token ast) ->+ ActionTable -> GotoTable -> ProdRules ->+ LexerParserState a -> -- [Terminal token]+ Maybe [StkElem token ast] ->+ ParseError token ast a+ + -- topState, lhs, stack, actiontbl, gototbl,+ NotFoundGoto ::+ (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ StateOnStackTop -> LhsSymbol -> (Stack token ast) ->+ ActionTable -> GotoTable -> ProdRules ->+ LexerParserState a -> -- [Terminal token]+ Maybe [StkElem token ast] ->+ ParseError token ast a++ deriving (Typeable)++instance (Show token, Show ast) => Show (ParseError token ast a) where+ showsPrec p (NotFoundAction terminal state stack _ _ _ (_,line,col,text) _ ) =+ (++) "NotFoundAction: State " .+ (++) (show state) . (++) " : " .+ (++) (terminalToString terminal) . (++) " " . -- (++) (show $ length stack)+ (++) "Line " . (++) (show line) . (++) " " .+ (++) "Column " . (++) (show col) . (++) " : " .+ (++) (takeRet 80 text)+ + showsPrec p (NotFoundGoto topstate lhs stack _ _ _ (_,line,col,text) _) =+ (++) "NotFoundGoto: State " .+ (++) (show topstate) . (++) " ; " .+ (++) lhs . (++) " " . -- . (++) (show stack)+ (++) "Line " . (++) (show line) . (++) " " .+ (++) "Column " . (++) (show col) . (++) " : " .+ (++) (takeRet 80 text)++instance (TokenInterface token, Typeable token, Show token, Typeable ast, Show ast, Typeable a)+ => Exception (ParseError token ast a)++lpStateFrom (NotFoundAction _ _ _ _ _ _ lpstate _) = lpstate+lpStateFrom (NotFoundGoto _ _ _ _ _ _ lpstate _) = lpstate++--------------------------------------------------------------------------------+-- | Automation specification+--------------------------------------------------------------------------------++data AutomatonSpec token ast m a =+ AutomatonSpec {+ am_actionTbl :: ActionTable,+ am_gotoTbl :: GotoTable,+ am_prodRules :: ProdRules,+ am_parseFuns :: ParseActionList token ast m a,+ am_initState :: Int+ }++initState = 0++type ParseActionList token ast m a = [ParseAction token ast m a]+++--------------------------------------------------------------------------------+-- | Automaton +--------------------------------------------------------------------------------++-- Utility for Automation+currentState :: Stack token ast -> Int+currentState (StkState i : stack) = i+currentState _ = error "No state found in the stack top"++lookupTable :: (Eq a, Show a) => [(a,b)] -> a -> Maybe b+lookupTable tbl key = + case [val | (key', val) <- tbl, key==key'] of+ [] -> Nothing+ (h:_) -> Just h++lookupActionTable :: TokenInterface token => ActionTable -> Int -> (Terminal token) -> Maybe Action+lookupActionTable actionTbl state terminal =+ lookupTable actionTbl (state,tokenTextFromTerminal terminal)++lookupGotoTable :: GotoTable -> Int -> String -> Maybe Int+lookupGotoTable gotoTbl state nonterminalStr =+ lookupTable gotoTbl (state,nonterminalStr)++errorKeyword :: String -- A reserved terminal name : A -> error+errorKeyword = "error"++lookupActionTableWithError :: ActionTable -> Int -> Maybe Action+lookupActionTableWithError actionTbl state =+ case lookupTable actionTbl (state,errorKeyword) of+ Just action -> Just action -- This can be either Shift or Reduce!+ + Nothing -> Nothing+++-- Note: take 1th, 3rd, 5th, ... of 2*len elements from stack and reverse it!+-- example) revTakeRhs 2 [a1,a2,a3,a4,a5,a6,...]+-- = [a4, a2]+revTakeRhs :: Int -> [a] -> [a]+revTakeRhs 0 stack = []+revTakeRhs n (_:nt:stack) = revTakeRhs (n-1) stack ++ [nt]+revTakeRhs n stack = error "[revTakeRhs] something wrong happened"++-- Automaton++runAutomaton+ :: (TokenInterface token,+ Typeable token, Typeable ast, Typeable a,+ Show token, Show ast) =>+ Bool -> AutomatonSpec token ast IO a ->+ LexerParserState a -> BoolToLexer IO a token -> IO ast+runAutomaton flag amSpec init_lp_state lexer =+ do maybeConfig <- readConfig+ + flag <- case maybeConfig of+ Nothing -> return flag+ Just config -> return $ config_DEBUG config++ ST.evalStateT (runYapbAutomaton flag amSpec (lexer flag)) init_lp_state+ +runYapbAutomaton+ :: (Monad m,+ TokenInterface token,+ Typeable token, Typeable ast, Typeable a,+ Show token, Show ast) =>+ -- debug flag+ Bool ->+ + -- static part ActionTable,GotoTable,ProdRules,ParseActionList token ast ->+ AutomatonSpec token ast m a ->+ + -- dynamic part+ ST.StateT (LexerParserState a) m (Terminal token) ->+ + -- AST+ ST.StateT (LexerParserState a) m ast+ +runYapbAutomaton flag (rm_spec @ AutomatonSpec {+ am_initState=initState,+ am_actionTbl=actionTbl,+ am_gotoTbl=gotoTbl,+ am_prodRules=prodRules,+ am_parseFuns=pFunList+ }) nextTerminal =++ do let initStack = push (StkState initState) emptyStack+ run Nothing initStack Nothing+ + where+ {- run :: TokenInterface token => [Terminal token] -> Stack token ast -> IO ast -}+ run maybeTerminal stack _maybeStatus = do+ let state = currentState stack+ -- let terminal = head terminalList++ -- Save the current state in case of going back+ prevState <- ST.get+ + terminal <-+ case maybeTerminal of+ Nothing -> nextTerminal+ Just t -> return t -- Use a terminal multiple times+ -- when reducing multiple production rules++ maybeStatus <- + -- if isNothing _maybeStatus && length terminalList == 1 -- if terminal == "$"+ if isNothing _maybeStatus+ && isJust (terminalToMaybeToken terminal)+ && isEOT (fromJust (terminalToMaybeToken terminal))+ then debug flag "" $+ debug flag ("Saving: " ++ prStack stack) $+ do return (Just stack)+ else do return _maybeStatus+ + case lookupActionTable actionTbl state terminal of+ Just action -> do+ -- putStrLn $ terminalToString terminal {- debug -}+ runAction state terminal action stack maybeStatus++ Nothing -> + debug flag ("lookActionTable failed (1st) with: " ++ show (terminalToString terminal)) $+ + case lookupActionTableWithError actionTbl state of+ Just action -> do+ -- errorTerminal intended to share the same (line,col) as terminal+ let (_, line, col, _) = prevState+ let errorTerminal = Terminal errorKeyword line col Nothing+ + -- Restore the current state+ ST.put prevState+ + -- run this action (Shift toState)+ runAction state errorTerminal action stack maybeStatus++ Nothing ->+ -- No more way to proceed now!+ do lp_state <- ST.get+ throw (NotFoundAction terminal state stack actionTbl gotoTbl prodRules lp_state maybeStatus)++ -- separated to support the haskell layout rule+ runAction state terminal action stack maybeStatus =+ debug flag ("\nState " ++ show state) $+ debug flag ("Token " ++ tokenTextFromTerminal terminal) $+ debug flag ("Stack " ++ prStack stack) $+ + case action of+ Accept -> + debug flag "Accept" $+ debug flag (terminalToString terminal) $ {- debug -}+ + case stack !! 1 of+ StkNonterminal (Just ast) _ -> return ast+ StkNonterminal Nothing _ -> error "Empty ast in the stack nonterminal"+ _ -> error "Not Stknontermianl on Accept"+ + Shift toState ->+ debug flag ("Shift " ++ show toState) $+ debug flag (terminalToString terminal) $ {- debug -}++ let stack1 = push (StkTerminal terminal) stack in+ let stack2 = push (StkState toState) stack1 in+ do run Nothing stack2 maybeStatus -- Nothing means consuming the terminal!+ + Reduce n ->+ debug flag ("Reduce " ++ show n) $++ let prodrule = prodRules !! n in++ debug flag ("\t" ++ show prodrule) $++ let builderFun = pFunList !! n in+ let lhs = fst prodrule in+ let rhsLength = length (snd prodrule) in+ let rhsAst = revTakeRhs rhsLength stack in+ do ast <- builderFun rhsAst + let stack1 = drop (rhsLength*2) stack+ let topState = currentState stack1+ + toState <-+ case lookupGotoTable gotoTbl topState lhs of+ Just state -> return state+ Nothing -> do lp_state <- ST.get+ throw (NotFoundGoto topState lhs stack+ actionTbl gotoTbl prodRules+ lp_state maybeStatus)++ let stack2 = push (StkNonterminal (Just ast) lhs) stack1 + let stack3 = push (StkState toState) stack2+ run (Just terminal) stack3 maybeStatus -- Use the terminal again the next time!++-- prlevel :: Int -> String+-- prlevel n = take n (let spaces = ' ' : spaces in spaces)+++--------------------------------------------------------------------------------+-- | Parsing interfaces+--------------------------------------------------------------------------------++parsing :: (TokenInterface token, Typeable token, Typeable ast, Typeable a, Show token, Show ast) =>+ Bool -> ParserSpec token ast IO a -> LexerParserState a -> BoolToLexer IO a token -> String -> IO ast++parsing flag parserSpec init_lp_state lexer eot = do+ -- 1. Save production rules (in the parser spec, e.g., Parser.hs)+ -- to a grammar file.+ writtenBool <- saveProdRules specFileName sSym pSpecList tokenAttrsStr prodRuleAttrsStr eot++ -- 2. Given a grammar file,+ -- run the following command to generate prod_rules/action_table/goto_table files.+ --+ -- $ stack exec -- yapb-exe mygrammar.grm \+ -- -output prod_rules.txt action_table.txt goto_table.txt+ --+ when writtenBool generateAutomaton++ -- 3. Load automaton files (prod_rules/action_table/goto_table.txt)+ (actionTbl, gotoTbl, prodRules) <-+ loadAutomaton grammarFileName actionTblFileName gotoTblFileName++ -- 4. Run the automaton+ if null actionTbl || null gotoTbl || null prodRules+ then do let hashFile = getHashFileName specFileName+ putStrLn $ "Delete " ++ hashFile+ removeIfExists hashFile+ error $ "Error: Empty automation: please rerun"+ else do ast <- runAutomaton flag+ (AutomatonSpec {+ am_initState=initState,+ am_actionTbl=actionTbl,+ am_gotoTbl=gotoTbl,+ am_prodRules=prodRules,+ am_parseFuns=pFunList})+ init_lp_state lexer+ -- putStrLn "done." -- for the interafce with Java-version RPC calculus interpreter.+ return ast++ where+ specFileName = parserSpecFile parserSpec -- e.g., mygrammar.grm+ grammarFileName = grammarFile parserSpec -- prod_rules.txt+ actionTblFileName = actionTblFile parserSpec -- action_table.txt+ gotoTblFileName = gotoTblFile parserSpec -- goto_table.txt + + sSym = startSymbol parserSpec+ tokenAttrList = tokenPrecAssoc parserSpec++ tokenAttrs = toTokenAttrs tokenAttrList+ tokenAttrsStr = show tokenAttrs+ + pSpecList = map (\(f,s,t)->f) (parserSpecList parserSpec)+ pFunList = map (\(f,s,t)->s) (parserSpecList parserSpec)+ pPrecList = map (\(f,s,t)->t) (parserSpecList parserSpec)++ prodRuleAttrs = toProdRuleAttrs tokenAttrs pPrecList+ prodRuleAttrsStr = show prodRuleAttrs++ generateAutomaton = do+ exitCode <- rawSystem "stack"+ [ "exec", "--",+ "yapb-exe", specFileName, "-output",+ grammarFileName, actionTblFileName, gotoTblFileName+ ]+ case exitCode of+ ExitFailure code -> exitWith exitCode+ ExitSuccess -> putStrLn ("Successfully generated: " +++ actionTblFileName ++ ", " +++ gotoTblFileName ++ ", " +++ grammarFileName);++-- | Utitility for parsing++toTokenAttrs :: TokenPrecAssoc -> TokenAttrs+toTokenAttrs tokenSpec = TokenAttrs (toTokenAttrs' tokenSpec 1)+ where+ toTokenAttrs' [] n = []+ toTokenAttrs' ((assoc, tokenPlaceholderList):tokenSpec) n =+ [ (tokenOrPlaceholder, (assoc, n)) | tokenOrPlaceholder <- tokenPlaceholderList ]+ ++ toTokenAttrs' tokenSpec (n+1)++toProdRuleAttrs :: TokenAttrs -> ProdRulePrecs -> ProdRuleAttrs+toProdRuleAttrs tokenAttrs prodRulePrecs = ProdRuleAttrs (toProdRuleAttrs' prodRulePrecs 0)+ where+ TokenAttrs tokenAttrs' = tokenAttrs+ + toProdRuleAttrs' [] n = []+ + toProdRuleAttrs' (Nothing:prodRulePrecs) n =+ toProdRuleAttrs' prodRulePrecs (n+1)+ + toProdRuleAttrs' ((Just tokenOrPlaceholder):prodRulePrecs) n =+ case [ (assoc, prec)+ | (tokenOrPlaceholder', (assoc, prec)) <- tokenAttrs'+ , tokenOrPlaceholder==tokenOrPlaceholder' ] of+ [] -> error $ "The production rule #" ++ show n ++ " refers to "+ ++ tokenOrPlaceholder ++ " but not found"+ ((assoc,prec):_) -> (n,(assoc,prec)) : toProdRuleAttrs' prodRulePrecs (n+1)+++--+removeIfExists :: FilePath -> IO ()+removeIfExists fileName = removeFile fileName `catch` handleExists+ where handleExists e+ | isDoesNotExistError e = return ()+ | otherwise = throwIO e++--------------------------------------------------------------------------------+-- | Computing candidates+--------------------------------------------------------------------------------++toChildren [] = []+toChildren (StkState i:stk) = toChildren stk+toChildren (StkTerminal term:stk) =+ (Leaf (TerminalSymbol (terminalToSymbol term))) : toChildren stk+toChildren (StkNonterminal ast nt:stk) =+ (Leaf (NonterminalSymbol nt)) : toChildren stk+++-- --+isReducible :: TokenInterface token =>+ [(a, [String])] -> Int -> [StkElem token ast] -> Bool+isReducible productionRules prnum stk =+ let + prodrule = productionRules !! prnum+ rhs = snd prodrule+ + rhsLength = length rhs+ + prefix_stk = take (rhsLength*2) stk+ reducible =+ isMatched rhs+ (reverse [elem | (i,elem) <- zip [1..] prefix_stk, i `mod` 2 == 0])+ in+ reducible+ +isMatched :: TokenInterface token => [String] -> [StkElem token ast] -> Bool+isMatched [] [] = True+isMatched (s:rhs) (StkTerminal terminal:stk) = + let maybeToken = terminalToMaybeToken terminal in+ ( isJust maybeToken && s == fromToken (fromJust maybeToken) -- Todo: A bit hard-coded!!+ || isNothing maybeToken && s == terminalToSymbol terminal)+ && isMatched rhs stk+isMatched (s:rhs) (StkNonterminal _ nonterminal:stk) =+ s == nonterminal && isMatched rhs stk+isMatched _ _ = False ++-- | Cycle checking+noCycleCheck :: Bool+noCycleCheck = True++checkCycle debugflag flag level state stk action history cont =+ if flag && (state,stk,action) `elem` history+ then + debug debugflag (prlevel level ++ "CYCLE is detected !!") $ + debug debugflag (prlevel level ++ " - " ++ show state ++ " " ++ action) $ + debug debugflag (prlevel level ++ " - " ++ prStack stk) $ + debug debugflag "" $ + return []+ else cont ( (state,stk,action) : history )++-- | Parsing programming interfaces++-- | successfullyParsed+successfullyParsed :: IO [EmacsDataItem]+successfullyParsed = return [SynCompInterface.SuccessfullyParsed]++-- | handleLexError+handleLexError :: IO [EmacsDataItem]+handleLexError = return [SynCompInterface.LexError]++data HandleParseError token = HandleParseError {+ debugFlag :: Bool,+ searchMaxLevel :: Int,+ simpleOrNested :: Bool,+ postTerminalList :: [Terminal token],+ nonterminalToStringMaybe :: Maybe (String->String),+ presentation :: Int -- 0: default, no transformation. 1: a list of the first symbols+ }++defaultHandleParseError = HandleParseError {+ debugFlag = False,+ searchMaxLevel = 1,+ simpleOrNested = True,+ postTerminalList = [],+ nonterminalToStringMaybe = Nothing,+ presentation = 0+ }++-- | handleParseError+ +handleParseError :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ ( CompCandidates token ast+ -> Int+ -> [Candidate]+ -> Int+ -> Stack token ast+ -> IO ([[Candidate]], Bool) ) ->+ HandleParseError token -> ParseError token ast a -> IO [EmacsDataItem]+handleParseError compCandidatesFn hpeOption parseError =+ do maybeConfig <- readConfig+ + let hpeOption' =+ case maybeConfig of+ Nothing -> hpeOption+ Just config -> hpeOption{debugFlag = config_DEBUG config+ ,presentation = config_PRESENTATION config}++ unwrapParseError compCandidatesFn hpeOption' parseError++ --+unwrapParseError compCandidatesFn hpeOption (NotFoundAction _ state stk _actTbl _gotoTbl _prodRules lp_state maybeStatus) = do+ let automaton = Automaton {actTbl=_actTbl, gotoTbl=_gotoTbl, prodRules=_prodRules}+ arrivedAtTheEndOfSymbol compCandidatesFn hpeOption state stk automaton lp_state maybeStatus+ +unwrapParseError compCandidatesFn hpeOption (NotFoundGoto state _ stk _actTbl _gotoTbl _prodRules lp_state maybeStatus) = do+ let automaton = Automaton {actTbl=_actTbl, gotoTbl=_gotoTbl, prodRules=_prodRules}+ arrivedAtTheEndOfSymbol compCandidatesFn hpeOption state stk automaton lp_state maybeStatus++--+arrivedAtTheEndOfSymbol compCandidatesFn hpeOption state stk automaton lp_state@(_,_,_,"") maybeStatus = -- [$]+ case maybeStatus of+ Nothing ->+ debug (debugFlag hpeOption) "No saved stack" $ + _handleParseError compCandidatesFn hpeOption state stk automaton+ Just savedStk ->+ let savedStk = fromJust maybeStatus+ savedState = currentState savedStk+ in + debug (debugFlag hpeOption) "Restored stack" $ + debug (debugFlag hpeOption) (" - state: " ++ show savedState) $ + debug (debugFlag hpeOption) (" - stack: " ++ prStack savedStk) $ + _handleParseError compCandidatesFn hpeOption savedState savedStk automaton+ +arrivedAtTheEndOfSymbol compCandidatesFn hpeOption state stk automaton lp_state@(_,_,_,text) maybeStatus =+ -- debug (debugFlag hpeOption) $ "length terminalList /= 1 : " ++ show (length terminalList)+ -- debug (debugFlag hpeOption) $ map (\t -> terminalToString $ t) terminalList+ return [SynCompInterface.ParseError text]++_handleParseError+ compCandidatesFn + (hpeOption @ HandleParseError {+ debugFlag=flag,+ searchMaxLevel=maxLevel,+ simpleOrNested=isSimple,+ postTerminalList=terminalListAfterCursor,+ nonterminalToStringMaybe=_nonterminalToStringMaybe,+ presentation=howtopresent})+ state stk automaton = + let ccOption = CompCandidates {+ cc_debugFlag=flag,+ cc_printLevel=0,+ cc_maxLevel=maxLevel,+ cc_simpleOrNested=isSimple,+ cc_automaton=automaton,+ cc_searchState = initSearchState init_r_level init_gs_level,+ cc_r_level = init_r_level, + cc_gs_level = init_gs_level}+ in+ let convFun =+ case _nonterminalToStringMaybe of+ Nothing -> \s -> "..."+ Just fn -> fn+ in+ do (candidateListList, emacsDisplay) <- compCandidatesFn ccOption 0 [] state stk+ let colorListList_symbols =+ [ filterCandidates candidateList terminalListAfterCursor+ | candidateList <- candidateListList ]+ + let colorListList_ = map (stringfyCandidates convFun) colorListList_symbols + let colorListList = map collapseCandidates colorListList_ + let emacsColorListList = map (map showEmacsColor) colorListList + let strList = nub [ concatStrList strList | strList <- emacsColorListList ] + let rawStrListList = nub [ strList | strList <- map (map showRawEmacsColor) colorListList ]++ debug (flag || True) "" $ + multiDbg (map (debug (flag || True)) (map show colorListList_symbols)) $ ++ debug (flag || True) "" $ + multiDbg (map (debug (flag || True)) (map show rawStrListList)) $ ++ debug (flag || True) "" $ ++ -- debug (flag || True) $ showConcat $ map (\x -> (show x ++ "\n")) colorListList_symbols+ -- debug (flag || True) $ showConcat $ map (\x -> (show x ++ "\n")) rawStrListList -- mapM_ (putStrLn . show) rawStrListList++ let formattedStrList =+ case howtopresent of+ 0 -> strList+ 1 -> nub [ if null strList then "" else head strList | strList <- emacsColorListList ]+ _ -> error ("Does not support prsentation method: " ++ show howtopresent)++ in+ + if emacsDisplay+ then return (map Candidate formattedStrList)+ else return [] + + where+ showConcat [] = ""+ showConcat (s:ss) = s ++ " " ++ showConcat ss++--+-- multiDbg [] = \x -> x+-- multiDbg (f:fs) = f . multiDbg fs+ +-- | Filter the given candidates with the following texts+data EmacsColor =+ Gray String Line Column -- Overlapping with some in the following text+ | White String -- Not overlapping+ deriving (Show, Eq)++-- for debugging EmacsColor in terms of symbols before they are stringfied+data EmacsColorCandidate =+ GrayCandidate Candidate Line Column -- Overlapping with some in the following text+ | WhiteCandidate Candidate -- Not overlapping+ deriving Eq++instance Show EmacsColorCandidate where+ showsPrec p (GrayCandidate c lin col) = (++) $ "Gray " ++ show c+ showsPrec p (WhiteCandidate c) = (++) $ "White " ++ show c++filterCandidates :: (TokenInterface token) => [Candidate] -> [Terminal token] -> [EmacsColorCandidate]+filterCandidates candidates terminalListAfterCursor =+ f candidates terminalListAfterCursor []+ where+ f (a:alpha) (b:beta) accm+ | equal a b = f alpha beta (GrayCandidate a (terminalToLine b) (terminalToCol b) : accm)+ | otherwise = f alpha (b:beta) (WhiteCandidate a : accm)+ f [] beta accm = reverse accm+ f (a:alpha) [] accm = f alpha [] (WhiteCandidate a : accm)++ equal (TerminalSymbol s1) (Terminal s2 _ _ _) = s1==s2+ equal (NonterminalSymbol s1) _ = False++stringfyCandidates :: (String -> String) -> [EmacsColorCandidate] -> [EmacsColor]+stringfyCandidates convFun candidates = map stringfyCandidate candidates+ where+ stringfyCandidate (GrayCandidate sym line col) = Gray (strCandidate sym) line col+ stringfyCandidate (WhiteCandidate sym) = White (strCandidate sym)++ strCandidate (TerminalSymbol s) = s+ strCandidate (NonterminalSymbol s) = convFun s -- "..." -- ++ s ++ "..."++collapseCandidates [] = []+collapseCandidates [a] = [a]+collapseCandidates ((Gray "..." l1 c1) : (Gray "..." l2 c2) : cs) =+ collapseCandidates ((Gray "..." l2 c2) : cs)+collapseCandidates ((White "...") : (White "...") : cs) =+ collapseCandidates ((White "...") : cs) +collapseCandidates (a:b:cs) = a : collapseCandidates (b:cs)++-- | Utilities+showSymbol (TerminalSymbol s) = s+showSymbol (NonterminalSymbol _) = "..."++showRawSymbol (TerminalSymbol s) = s+showRawSymbol (NonterminalSymbol s) = s++showEmacsColor (Gray s line col) = "gray " ++ s ++ " " ++ show line ++ " " ++ show col ++ " "+showEmacsColor (White s) = "white " ++ s++showRawEmacsColor (Gray s line col) = s ++ "@" ++ show line ++ "," ++ show col ++ " "+showRawEmacsColor (White s) = s++concatStrList [] = "" -- error "The empty candidate?"+concatStrList [str] = str+concatStrList (str:strs) = str ++ " " ++ concatStrList strs++-- Q. Can we make it be typed???+--+-- computeCandWith :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast)+-- => LexerSpec token -> ParserSpec token ast+-- -> String -> Bool -> Int -> IO [EmacsDataItem]+-- computeCandWith lexerSpec parserSpec str isSimple cursorPos = ((do+-- terminalList <- lexing lexerSpec str +-- ast <- parsing parserSpec terminalList +-- successfullyParsed)+-- `catch` \e -> case e :: LexError of _ -> handleLexError+-- `catch` \e -> case e :: ParseError token ast of _ -> handleParseError isSimple e) ++-- Utilities+-- debug :: Bool -> String -> a -> a+-- debug flag msg x = if flag then trace msg x else x+
src/parserlib/LoadAutomaton.hs view
@@ -3,6 +3,7 @@ import AutomatonType import SaveProdRules(tokenizeLhs) import System.IO+import Text.Read (readMaybe) loadAutomaton :: String -> String -> String -> IO (ActionTable, GotoTable, ProdRules)@@ -28,7 +29,9 @@ [("", therest)] -> return [] [(stateNum, therest)] -> do (terminal, action, actTbl) <- tokenizeTerminalInAction therest- return $ ((read stateNum :: Int, terminal), action) : actTbl+ case readMaybe stateNum :: Maybe Int of+ Just stateNum_i -> return $ ((stateNum_i, terminal), action) : actTbl+ Nothing -> error $ "[tokenizeStateNumInAction] Unexpected state number\n" ++ stateNum tokenizeTerminalInAction :: String -> IO (String, Action, ActionTable) tokenizeTerminalInAction str =@@ -62,7 +65,11 @@ [("", therest)] -> fail "No shift/reduce state number found (2)" [(stateNum, therest)] -> do actTbl <- tokenizeStateNumInAction therest- return (fn (read stateNum :: Int), actTbl)+ case readMaybe stateNum :: Maybe Int of+ Just stateNum_i -> return (fn stateNum_i, actTbl)+ Nothing ->+ error $ "[tokenizeShiftReduceStateNumInAction] unexpected state number:"+ ++ stateNum -- Load goto table@@ -76,7 +83,10 @@ [("", therest)] -> return [] [(stateNum, therest)] -> do (nonterminal, toStateNum, actTbl) <- tokenizeNonterminalInGoto therest- return $ ((read stateNum :: Int, nonterminal), read toStateNum :: Int) : actTbl+ case (readMaybe stateNum :: Maybe Int, readMaybe toStateNum :: Maybe Int) of+ (Just stateNum_i, Just toStateNum_i) -> return $ ((stateNum_i, nonterminal), toStateNum_i) : actTbl+ (_,_) -> error $ "[tokenizeStateNumInGoto] Unexpected state numbers: "+ ++ stateNum ++ " or " ++ toStateNum tokenizeNonterminalInGoto :: String -> IO (String, String, GotoTable) tokenizeNonterminalInGoto str =@@ -109,7 +119,10 @@ [("", therest)] -> fail "No rule number found (2)" [(ruleNumStr, therest)] -> do (lhs, rhs) <- tokenizeColonInProdRules therest- return (read ruleNumStr :: Int, lhs, rhs)+ case readMaybe ruleNumStr :: Maybe Int of+ Just ruleNumStr_i -> return (ruleNumStr_i, lhs, rhs)+ Nothing -> error $ "[tokenizeNumInProdRules] Unexpected rule number: "+ ++ ruleNumStr tokenizeColonInProdRules :: String -> IO (String, [String]) tokenizeColonInProdRules str =
src/parserlib/SaveProdRules.hs view
@@ -1,13 +1,18 @@ module SaveProdRules where +import Text.Read (readMaybe) import Data.Hashable import System.IO import System.Directory import CFG -saveProdRules :: String -> String -> [String] -> IO Bool-saveProdRules fileName startSymbol prodRuleStrs = do- writeOnceWithHash fileName grmStrLn+saveProdRules :: String -> String -> [String] -> String -> String -> String -> IO Bool+saveProdRules fileName startSymbol prodRuleStrs tokenAttrs prodRuleAttrs eot = do+ writeOnceWithHash fileName+ ("(" ++ grmStrLn ++ ",\n" +++ tokenAttrs ++ ",\n" +++ prodRuleAttrs ++ ",\n" +++ show eot ++ ")\n") -- show eot to have double quotes where grmStr = toCFG startSymbol prodRuleStrs grmStrLn = grmStr ++ "\n"@@ -80,11 +85,15 @@ True -> do existingHashStr <- readFile hashFileName- - case newHash == (read existingHashStr :: Int) of- True -> return False- False -> do- writeFile fileName text- writeFile hashFileName (show newHash)- return True- ++ case readMaybe existingHashStr :: Maybe Int of+ Just existingHashStr_i ->+ + case newHash == existingHashStr_i of+ True -> return False+ False -> do+ writeFile fileName text+ writeFile hashFileName (show newHash)+ return True++ Nothing -> error $ "[writeOnceWithHash] unexpected hash: " ++ existingHashStr
src/parserlib/Terminal.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE GADTs #-}-module Terminal(Terminal(..), terminalToString, terminalToLine, terminalToCol, token_na) where+module Terminal(Terminal(..),+ terminalToString, terminalToLine, terminalToCol, terminalToSymbol,+ terminalToMaybeToken, token_na, tokenTextFromTerminal) where import TokenInterface @@ -26,3 +28,17 @@ terminalToCol :: TokenInterface token => Terminal token -> Int terminalToCol (Terminal text line col tok) = col++terminalToSymbol :: TokenInterface token => Terminal token -> String+terminalToSymbol (Terminal text _ _ _) = text++terminalToMaybeToken :: TokenInterface token => Terminal token -> Maybe token+terminalToMaybeToken (Terminal text line col maybetok) = maybetok++-- | Utilities++tokenTextFromTerminal :: TokenInterface token => Terminal token -> String+tokenTextFromTerminal terminal =+ case terminalToMaybeToken terminal of+ Just token -> fromToken token+ Nothing -> token_na
src/parserlib/TokenInterface.hs view
@@ -3,8 +3,6 @@ class TokenInterface token where -- toToken :: String -> token fromToken :: token -> String--- + isEOT :: token -> Bool
+ src/parserlib/algo/SynCompAlgoBU.hs view
@@ -0,0 +1,458 @@+module SynCompAlgoBU (compCandidates) where++import AutomatonType+import Terminal+import TokenInterface+import CommonParserUtil+import SynCompAlgoUtil+import Config++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 "" $ + -- compGammasDfs ccOption level symbols state stk []+ do extendedCompCandidates ccOption symbols state stk+++--------------------------------------------------------------------------------+-- A new search algorithm+--------------------------------------------------------------------------------+--+type State = Int+type LengthOfSymbols = Int+ +--+extendedCompCandidates+ :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ CompCandidates token ast -> [Candidate] -> State -> Stack token ast -> IO ([[Candidate]], Bool)+extendedCompCandidates ccOption symbols state stk = do+ maybeConfig <- readConfig+ case maybeConfig of+ Nothing ->+ do list <- extendedCompCandidates' ccOption symbols state stk+ return (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 (list, display)++ where+ 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(True)/nested(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 repReduce ccOption symbols state stk + else do extendedNestedCandidates ccOption [(state, stk, symbols)]++ return [ c | (state, stk, c) <- list, null c == False ]+++-- 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, [Candidate])]+ +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, [Candidate])]+ -> IO [(State, Stack token ast, [Candidate])]+ +extendedNestedCandidates ccOption initStateStkCandsList =+ let f (state, stk, symbols) =+ debug debugFlag "Given " $ + debug debugFlag (" - state " ++ show state) $ + debug debugFlag (" - stack " ++ prStack stk) $ + debug debugFlag (" - cand " ++ show symbols) $ + debug debugFlag "" $ ++ do repReduce ccOption{cc_simpleOrNested=True} {- symbols -} [] state stk++ debugFlag = cc_debugFlag ccOption+ r_level = cc_r_level ccOption+ in+ if r_level > 0+ then+ debug debugFlag "[extendedNestedCandidates] :" $ + multiDbg (map (\(state, stk, cand) ->+ debug debugFlag (" - state " ++ show state) $+ debug debugFlag (" - stack " ++ prStack stk) $+ debug debugFlag (" - cand " ++ show cand) $+ debug debugFlag ("")+ ) initStateStkCandsList) $++ do stateStkCandsListList <- mapM f initStateStkCandsList++ 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++ else+ return []++repReduce+ :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ CompCandidates token ast -> [Candidate] -> State -> Stack token ast+ -> IO [(State, Stack token ast, [Candidate])]++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 -- do 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 return []++ 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++ listOfList <-+ mapM (\ (prnum, i) ->+ do let searchState = cc_searchState ccOption+ + -- SS_InitReduces+ if isInitReduces searchState then+ do list2 <- repGotoOrShift+ (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++simulReduce :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ CompCandidates token ast+ -> [Candidate]+ -> Int -- Production rule number+ -> Int -- of all reducible actions+ -> Int -- ith action chosen+ -> State+ -> Stack token ast+ -> IO [(State, Stack token ast, [Candidate])]+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) == False && False -- Q: 필요? False for the moment!+ then do return []++ 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++ if isSimple then -- simple mode++ if isInitReduces searchState then -- reduces until symbols are found+ do listOfList <- repReduce ccOption{cc_printLevel=level+1} [] 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+ if null symbols+ then return []+ else debug flag (prlevel level ++ " - FOUND: " ++ show symbols) $+ debug flag "" $+ return [(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+ -> [Candidate]+ -> Int+ -> [StkElem token ast]+ -> IO [(State, Stack token ast, [Candidate])]+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++[NonterminalSymbol nonterminal])) $ + -- debug flag (prlevel level ++ " - Search state: " ++ show (cc_searchState ccOption)) $ + debug flag "" $ ++ repGotoOrShift + ccOption{cc_printLevel=level+1}+ (symbols++[NonterminalSymbol nonterminal])+ snext stk2)+ (zip nontermStateList [1..])++ return $ concat listOfList++simulShift :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ CompCandidates token ast+ -> [Candidate]+ -> Int+ -> [StkElem token ast]+ -> IO [(State, Stack token ast, [Candidate])]+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++[TerminalSymbol terminal])) $ + -- debug flag (prlevel level ++ " - Search state: " ++ show (cc_searchState ccOption)) $ + debug flag "" $ ++ repGotoOrShift+ ccOption{cc_printLevel=level+1}+ (symbols++[TerminalSymbol terminal])+ snext stk2)+ (zip cand2 [1..])++ return $ concat listOfList++repGotoOrShift+ :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ CompCandidates token ast -> [Candidate] -> State -> Stack token ast -> IO [(State, Stack token ast, [Candidate])]++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 []++ else do+ listOfList1 <- 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) - 1 > 0 then+ 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++ do listOfList2 <- simulGoto ccOption' symbols state stk++ if null listOfList2+ then++ do listOfList3 <- simulShift ccOption' symbols state stk+ return $ listOfList1 ++ listOfList2 ++ listOfList3++ else+ return $ listOfList1 ++ listOfList2++ else+ return listOfList1 -- Q: symbols or []++ else do return listOfList1++-- Todo: repReduce를 하지 않고+-- Reduce 액션이 있는지 보고+-- 없으면 goto or shift 진행하고+-- 있으면 reduce한번하고 종료!++-- 현재 구현은 repReduce 결과가 널인지 검사해서 진행 또는 종료+-- Reduce 액션이 있어도 진행될 수 있음!+++
+ src/parserlib/algo/SynCompAlgoBUTree.hs view
@@ -0,0 +1,498 @@+module SynCompAlgoBUTree (compCandidates) where++import AutomatonType+import Terminal+import TokenInterface+import CommonParserUtil+import SynCompAlgoUtil+import Config++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 "" $ + -- 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+ 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+ 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(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 repReduce ccOption symbols state stk + else do extendedNestedCandidates ccOption [(state, stk, symbols)]+++-- 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 =+ error "extendedNestedCandidates: should not be called"+ -- let debugFlag = cc_debugFlag ccOption+ -- r_level = cc_r_level ccOption+ + -- f (state, stk, symbols) =+ -- debug debugFlag "Given " $ + -- debug debugFlag (" - state " ++ show state) $ + -- debug debugFlag (" - stack " ++ prStack stk) $ + -- debug debugFlag (" - cand " ++ show symbols) $ + -- debug debugFlag "" $ ++ -- do repReduce ccOption{cc_simpleOrNested=True} {- symbols -} [] state stk++ -- in+ -- if r_level > 0+ -- then+ -- debug debugFlag "[extendedNestedCandidates] :" $ + -- multiDbg (map (\(state, stk, cand) ->+ -- debug debugFlag (" - state " ++ show state) $+ -- debug debugFlag (" - stack " ++ prStack stk) $+ -- debug debugFlag (" - cand " ++ show cand) $+ -- debug debugFlag ("")+ -- ) initStateStkCandsList) $++ -- do stateStkCandsListList <- mapM f initStateStkCandsList++ -- 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++ -- else+ -- return []++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 -- do 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 return []++ 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++ listOfList <-+ mapM (\ (prnum, i) ->+ do let searchState = cc_searchState ccOption+ + -- SS_InitReduces+ if isInitReduces searchState then+ do list2 <- repGotoOrShift+ (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++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++ len_leafs_symbols = length (leafs 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 ++ " - 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 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+ 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++ debug flag (prlevel level ++ " - FOUND: " ++ show symbols) $+ debug flag "" $+ return [(toState,stk3,symbols)] -- Note: toState and stk3 are after the reduction, but symbols are not!!+ + 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 []++ 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,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+ do return []+ -- 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) ->+ + if null symbols -- I do not want any nonterminal to be the first symbol!+ then return []+ + 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..])++ 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++[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 $ concat listOfList++repGotoOrShift+ :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ CompCandidates token ast -> [CandidateTree] -> State -> Stack token ast -> IO [(State, Stack token ast, [CandidateTree])]++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 []++ else do+ listOfList1 <- 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: deleted - 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++ do listOfList2 <- simulShift ccOption' symbols state stk -- Shift first Goto Next!++ if null listOfList2+ then++ do listOfList3 <- simulGoto ccOption' symbols state stk+ return $ listOfList1 ++ listOfList2 ++ listOfList3++ else+ return $ listOfList1 ++ listOfList2++ else+ return listOfList1 -- Q: symbols or []++ else do return listOfList1++++
+ src/parserlib/algo/SynCompAlgoBUTreeNested.hs view
@@ -0,0 +1,553 @@+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)++++
+ src/parserlib/algo/SynCompAlgoPEPM.hs view
@@ -0,0 +1,193 @@+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))+
+ src/parserlib/algo/SynCompAlgoTD.hs view
@@ -0,0 +1,539 @@+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 액션이 있어도 진행될 수 있음!
+ src/parserlib/algo/SynCompAlgoUtil.hs view
@@ -0,0 +1,133 @@+module SynCompAlgoUtil where++import AutomatonType+import Debug.Trace (trace)++-- | Candidates+data Candidate = -- data Candidate vs. data EmacsDataItem = ... | Candidate String + TerminalSymbol !String+ | NonterminalSymbol !String+ deriving Eq++-- | Candidate tree++-- data CandidateTree = CandidateTree Candidate [CandidateTree] deriving (Eq,Show)++{-+-- ( CandidateTree cand [] )^* ===> Leaf cand+-- ( CandidateTree cand [t1,...,tn] )^* ===> Node cand [t1^*, ..., tn^*]+--+-- A -> ===> Node (Nonterminal "A") []+-- is not equal to Leaf (Nonterminal "A").+-}++data CandidateTree =+ Leaf !Candidate + | Node !Candidate ![CandidateTree]+ deriving (Eq,Show)++type CandidateForest = [CandidateTree]++instance Show Candidate where+ showsPrec p (TerminalSymbol s) = (++) $ "Terminal " ++ s+ showsPrec p (NonterminalSymbol s) = (++) $ "Nonterminal " ++ s++-- leaf :: Candidate -> CandidateTree+-- leaf cand = CandidateTree cand []+-- leaf cand = Leaf cand++leafs :: CandidateForest -> [Candidate]+leafs [] = []+-- leafs (CandidateTree leaf [] : forest) = leaf : leafs forest+-- leafs (CandidateTree leaf subtrees : forest) =+leafs (Leaf leaf : forest) = leaf : leafs forest+leafs (Node leaf subtrees : forest) =+ leafs subtrees ++ leafs forest -- The leaf is not included as a candidate!+ -- i.e., leafs (Node leaf []) = []++--+candidateLeaf :: Candidate -> CandidateTree+candidateLeaf cand = Leaf cand++candidateNode :: Candidate -> CandidateForest -> CandidateTree+candidateNode nonterminal_lhs children = Node nonterminal_lhs children++-- | Automation information+data Automaton token ast =+ Automaton {+ actTbl :: ActionTable,+ gotoTbl :: GotoTable,+ prodRules :: ProdRules+ }++-- | Computing candidates+data CompCandidates token ast = CompCandidates {+ cc_debugFlag :: !Bool,+ cc_printLevel :: !Int, + cc_maxLevel :: !Int, + + cc_r_level :: !Int, -- for new algorithm+ cc_gs_level :: !Int, --+ + cc_simpleOrNested :: !Bool,+ cc_automaton :: !(Automaton token ast),+ cc_searchState :: !SearchState+ }+++-- | Search states used in the algorithms++type R_Level = Int+type GS_Level = Int++data SearchState =+ SS_InitReduces !R_Level !GS_Level -- Reduce^*+ | SS_GotoOrShift !R_Level !GS_Level -- (Goto | Shift)+ | SS_FinalReduce !R_Level !GS_Level -- Reduce++instance Show SearchState where+ showsPrec p (SS_InitReduces r gs) = (++) $ "I:" ++ show r ++ ":" ++ show gs+ showsPrec p (SS_GotoOrShift r gs) = (++) $ "M:" ++ show r ++ ":" ++ show gs+ showsPrec p (SS_FinalReduce r gs) = (++) $ "F:" ++ show r ++ ":" ++ show gs++init_r_level :: R_Level+init_r_level = 1++init_gs_level :: GS_Level+init_gs_level = 5++initSearchState r gs = SS_InitReduces r gs++isInitReduces (SS_InitReduces _ _) = True+isInitReduces _ = False++isFinalReduce (SS_FinalReduce _ _) = True+isFinalReduce _ = False++setGotoOrShift ccOption =+ case cc_searchState ccOption of+ SS_InitReduces r gs -> ccOption{cc_searchState=SS_GotoOrShift r gs}+ SS_GotoOrShift r gs -> ccOption{cc_searchState=SS_GotoOrShift r gs}+ SS_FinalReduce r gs -> ccOption{cc_searchState=SS_GotoOrShift r gs} -- Todo: ??? error $ "[setGotoOrShift] expected SS_InitReduces or SS_GotoOrShift"+ +r_level (SS_InitReduces r gs) = r+r_level (SS_GotoOrShift r gs) = r+r_level (SS_FinalReduce r gs) = r++gs_level (SS_InitReduces r gs) = gs+gs_level (SS_GotoOrShift r gs) = gs+gs_level (SS_FinalReduce r gs) = gs++-- | Utilities+debug :: Bool -> String -> a -> a+debug flag msg x = if flag then trace msg x else x++multiDbg [] = \x -> x+multiDbg (f:fs) = f . multiDbg fs++prlevel :: Int -> String+prlevel n = take n (let spaces = ' ' : spaces in spaces)++showProductionRule :: (String,[String]) -> String+showProductionRule (lhs,rhss) =+ lhs ++ " -> " ++ concat (map (\rhs -> rhs ++ " ") rhss)
+ src/parserlib/algo/SynCompAlgorithm.hs view
@@ -0,0 +1,46 @@+module SynCompAlgorithm(chooseCompCandidatesFn, defaultCompCandidatesFn) where++import qualified SynCompAlgoBU as BU+import qualified SynCompAlgoTD as TD+import qualified SynCompAlgoPEPM as PEPM++-- For experiment+import qualified SynCompAlgoBUTree as BUTree+import qualified SynCompAlgoBUTreeNested as BUTreeNested++import TokenInterface+import Config+import SynCompAlgoUtil+import CommonParserUtil++import Data.Typeable++chooseCompCandidatesFn :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ IO ( CompCandidates token ast+ -> Int+ -> [Candidate]+ -> Int+ -> Stack token ast+ -> IO ([[Candidate]], Bool) )+chooseCompCandidatesFn =+ do maybeConfig <- readConfig+ case maybeConfig of+ Nothing -> return defaultCompCandidatesFn+ Just config -> return (choose (config_ALGORITHM config) (config_SIMPLE config))+ where+ choose 0 _ = BU.compCandidates+ choose 1 _ = TD.compCandidates+ choose 2 _ = PEPM.compCandidates+ choose 3 True = BUTree.compCandidates -- 3 and Simple+ choose 3 False = BUTreeNested.compCandidates -- 3 and Nested+ choose _ _ = defaultCompCandidatesFn -- by default !++defaultCompCandidatesFn :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+ CompCandidates token ast+ -> Int+ -> [Candidate]+ -> Int+ -> Stack token ast+ -> IO ([[Candidate]], Bool)+defaultCompCandidatesFn = BU.compCandidates+
src/syncomplib/EmacsServer.hs view
@@ -22,17 +22,17 @@ acceptLoop computeCand sock = forever $ do (conn, _) <- accept sock (cursorPos, isSimple) <- getCursorPos_and_isSimple conn - print (cursorPos, isSimple) + -- print (cursorPos, isSimple) close conn (conn, _) <- accept sock str <- getSource conn - print str + -- print str close conn (conn, _) <- accept sock strAfterCursor <- getSource conn - print strAfterCursor + -- print strAfterCursor candidateList <- computeCand str strAfterCursor isSimple - print (Prelude.map show candidateList) + -- print (Prelude.map show candidateList) close conn (conn, _) <- accept sock sendCandidateList conn candidateList
src/syncomplib/SynCompInterface.hs view
@@ -2,7 +2,7 @@ data EmacsDataItem = LexError -- Lex error at some terminal (not $)- | ParseError [String] -- Parse error at some terminal (not $)+ | ParseError String -- Parse error at the text (not $) | Candidate String -- Parse error at the cursor position returning a candidate string | SuccessfullyParsed -- Successfully parsed until the cursor position deriving (Eq, Show)
src/util/ReadGrammar.hs view
@@ -1,11 +1,11 @@-module ReadGrammar where+module ReadGrammar(readGrammar, conversion) where import CFG- import Data.List(intersperse)+ import System.IO-import System.Environment (getArgs) + data LitGrm = LitGrm { start :: Maybe String, rules :: [(String, [[String]])], rhss :: [[String]] } readGrammar :: Monad m => [String] -> m (Maybe String, [ProductionRule])@@ -93,25 +93,11 @@ in return startLhsRhsPairList { rules=(lhs,rhss_):rules_, rhss=[] } (StartSymbol s, Rhs rhss) -> error $ "rep: StartSymbol " ++ s ++ " can't change to Rule" -------- For testing with grm/polyrpc.lgrm--- --test fun = do- args <- getArgs- repTest fun args--repTest fun [] = return ()-repTest fun (arg:args) = do- text <- readFile arg- fun text- repTest fun args--parsing text = do- startLhsRhssPairList <- rep NoState (lines text)- let startsymbol = start startLhsRhssPairList- let lhsRhssPairList = rules startLhsRhssPairList- mapM_ (\(lhs,rhss) -> prLhsRhss lhs rhss) lhsRhssPairList+-- parsing text = do+-- startLhsRhssPairList <- rep NoState (lines text)+-- let startsymbol = start startLhsRhssPairList+-- let lhsRhssPairList = rules startLhsRhssPairList+-- mapM_ (\(lhs,rhss) -> prLhsRhss lhs rhss) lhsRhssPairList prLhsRhss :: String -> [[String]] -> IO () prLhsRhss lhs rhss = do@@ -134,4 +120,5 @@ -- May replace prodRuleToStr with show putStrLn $ concat (intersperse ",\n " (map prodRuleToStr prodrules)) putStrLn $ "]"+
yapb.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 83066d4d451ae0ff04c47672b47198ec2dd5f553401ce0104962f9ff1409446e+-- hash: 14a727bdc5e1411df0e55e6e3e8773c45508eef14b581150e5bfd37fd8d6a367 name: yapb-version: 0.1.3.2+version: 0.2 synopsis: Yet Another Parser Builder (YAPB) description: A programmable LALR(1) parser builder system. Please see the README on GitHub at <https://github.com/kwanghoon/yapb#readme> category: parser builder@@ -30,6 +30,7 @@ library exposed-modules: CFG+ Attrs CmdArgs ParserTable GenLRParserTable@@ -44,24 +45,61 @@ ReadGrammar EmacsServer SynCompInterface+ Config+ SynCompAlgoBU+ SynCompAlgoBUTree+ SynCompAlgoBUTreeNested+ SynCompAlgoTD+ SynCompAlgoPEPM+ SynCompAlgoUtil+ SynCompAlgorithm other-modules: Paths_yapb hs-source-dirs: src/gentable/ src/parserlib/+ src/parserlib/algo src/syncomplib src/util/+ src/config/ build-depends: base >=4.7 && <5 , bytestring >=0.10.8 && <0.11+ , deepseq >=1.4.4.0 , directory >=1.3.3 && <1.4 , hashable >=1.3.0 && <1.4 , hspec+ , mtl , network >=3.1.1 && <3.2 , process >=1.6.5 && <1.7 , regex-tdfa >=1.3.1 && <1.4+ , transformers default-language: Haskell2010 +executable ambiguous-exe+ main-is: Main.hs+ other-modules:+ Lexer+ Parser+ ParserSpec+ Run+ Token+ Expr+ Paths_yapb+ hs-source-dirs:+ app/ambiguous+ app/ambiguous/ast+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , deepseq >=1.4.4.0+ , hspec+ , mtl+ , regex-tdfa+ , transformers+ , yapb+ default-language: Haskell2010+ executable conv-exe main-is: Main.hs other-modules:@@ -71,10 +109,37 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5+ , deepseq >=1.4.4.0 , hspec+ , mtl+ , transformers , yapb default-language: Haskell2010 +executable error-exe+ main-is: Main.hs+ other-modules:+ Lexer+ Parser+ ParserSpec+ Run+ Token+ Expr+ Paths_yapb+ hs-source-dirs:+ app/error+ app/error/ast+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , deepseq >=1.4.4.0+ , hspec+ , mtl+ , regex-tdfa+ , transformers+ , yapb+ default-language: Haskell2010+ executable parser-exe main-is: Main.hs other-modules:@@ -91,8 +156,11 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5+ , deepseq >=1.4.4.0 , hspec+ , mtl , regex-tdfa+ , transformers , yapb default-language: Haskell2010 @@ -112,8 +180,11 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5+ , deepseq >=1.4.4.0 , hspec+ , mtl , regex-tdfa+ , transformers , yapb default-language: Haskell2010 @@ -126,7 +197,10 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5+ , deepseq >=1.4.4.0 , hspec+ , mtl+ , transformers , yapb default-language: Haskell2010 @@ -140,7 +214,10 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5+ , deepseq >=1.4.4.0 , hspec+ , mtl , process+ , transformers , yapb default-language: Haskell2010