diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/app/ambiguous/Lexer.hs b/app/ambiguous/Lexer.hs new file mode 100644 --- /dev/null +++ b/app/ambiguous/Lexer.hs @@ -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) + ] + } diff --git a/app/ambiguous/Main.hs b/app/ambiguous/Main.hs new file mode 100644 --- /dev/null +++ b/app/ambiguous/Main.hs @@ -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) + + diff --git a/app/ambiguous/Parser.hs b/app/ambiguous/Parser.hs new file mode 100644 --- /dev/null +++ b/app/ambiguous/Parser.hs @@ -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" + } + + diff --git a/app/ambiguous/ParserSpec.hs b/app/ambiguous/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/app/ambiguous/ParserSpec.hs @@ -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))" diff --git a/app/ambiguous/Run.hs b/app/ambiguous/Run.hs new file mode 100644 --- /dev/null +++ b/app/ambiguous/Run.hs @@ -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) diff --git a/app/ambiguous/Token.hs b/app/ambiguous/Token.hs new file mode 100644 --- /dev/null +++ b/app/ambiguous/Token.hs @@ -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 + diff --git a/app/ambiguous/ast/Expr.hs b/app/ambiguous/ast/Expr.hs new file mode 100644 --- /dev/null +++ b/app/ambiguous/ast/Expr.hs @@ -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 ++ ")" diff --git a/app/conv/Main.hs b/app/conv/Main.hs --- a/app/conv/Main.hs +++ b/app/conv/Main.hs @@ -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 diff --git a/app/error/Lexer.hs b/app/error/Lexer.hs new file mode 100644 --- /dev/null +++ b/app/error/Lexer.hs @@ -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) + ] + } diff --git a/app/error/Main.hs b/app/error/Main.hs new file mode 100644 --- /dev/null +++ b/app/error/Main.hs @@ -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) + + diff --git a/app/error/Parser.hs b/app/error/Parser.hs new file mode 100644 --- /dev/null +++ b/app/error/Parser.hs @@ -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" + } + + diff --git a/app/error/ParserSpec.hs b/app/error/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/app/error/ParserSpec.hs @@ -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))" diff --git a/app/error/Run.hs b/app/error/Run.hs new file mode 100644 --- /dev/null +++ b/app/error/Run.hs @@ -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) diff --git a/app/error/Token.hs b/app/error/Token.hs new file mode 100644 --- /dev/null +++ b/app/error/Token.hs @@ -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 + diff --git a/app/error/ast/Expr.hs b/app/error/ast/Expr.hs new file mode 100644 --- /dev/null +++ b/app/error/ast/Expr.hs @@ -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 ++ ")" diff --git a/app/parser/Lexer.hs b/app/parser/Lexer.hs --- a/app/parser/Lexer.hs +++ b/app/parser/Lexer.hs @@ -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, diff --git a/app/parser/Parser.hs b/app/parser/Parser.hs --- a/app/parser/Parser.hs +++ b/app/parser/Parser.hs @@ -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" } diff --git a/app/parser/Run.hs b/app/parser/Run.hs --- a/app/parser/Run.hs +++ b/app/parser/Run.hs @@ -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) diff --git a/app/parser/Token.hs b/app/parser/Token.hs --- a/app/parser/Token.hs +++ b/app/parser/Token.hs @@ -41,3 +41,5 @@ Just str -> str + isEOT END_OF_TOKEN = True + isEOT _ = False diff --git a/app/syntaxcompletion/Lexer.hs b/app/syntaxcompletion/Lexer.hs --- a/app/syntaxcompletion/Lexer.hs +++ b/app/syntaxcompletion/Lexer.hs @@ -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, diff --git a/app/syntaxcompletion/Parser.hs b/app/syntaxcompletion/Parser.hs --- a/app/syntaxcompletion/Parser.hs +++ b/app/syntaxcompletion/Parser.hs @@ -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 = "./", diff --git a/app/syntaxcompletion/SyntaxCompletion.hs b/app/syntaxcompletion/SyntaxCompletion.hs --- a/app/syntaxcompletion/SyntaxCompletion.hs +++ b/app/syntaxcompletion/SyntaxCompletion.hs @@ -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 diff --git a/app/syntaxcompletion/SyntaxCompletionSpec.hs b/app/syntaxcompletion/SyntaxCompletionSpec.hs --- a/app/syntaxcompletion/SyntaxCompletionSpec.hs +++ b/app/syntaxcompletion/SyntaxCompletionSpec.hs @@ -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] diff --git a/app/syntaxcompletion/Token.hs b/app/syntaxcompletion/Token.hs --- a/app/syntaxcompletion/Token.hs +++ b/app/syntaxcompletion/Token.hs @@ -37,3 +37,6 @@ case findTok tok tokenStrList of Nothing -> error ("fromToken: " ++ show tok) Just str -> str + + isEOT END_OF_TOKEN = True + isEOT _ = False diff --git a/src/config/Config.hs b/src/config/Config.hs new file mode 100644 --- /dev/null +++ b/src/config/Config.hs @@ -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 + + diff --git a/src/gentable/Attrs.hs b/src/gentable/Attrs.hs new file mode 100644 --- /dev/null +++ b/src/gentable/Attrs.hs @@ -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) diff --git a/src/gentable/CFG.hs b/src/gentable/CFG.hs --- a/src/gentable/CFG.hs +++ b/src/gentable/CFG.hs @@ -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 - - diff --git a/src/gentable/CodeGenC.hs b/src/gentable/CodeGenC.hs --- a/src/gentable/CodeGenC.hs +++ b/src/gentable/CodeGenC.hs @@ -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 = diff --git a/src/gentable/GenLRParserTable.hs b/src/gentable/GenLRParserTable.hs --- a/src/gentable/GenLRParserTable.hs +++ b/src/gentable/GenLRParserTable.hs @@ -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 + 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 diff --git a/src/gentable/ParserTable.hs b/src/gentable/ParserTable.hs --- a/src/gentable/ParserTable.hs +++ b/src/gentable/ParserTable.hs @@ -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 diff --git a/src/parserlib/CommonParserUtil.hs b/src/parserlib/CommonParserUtil.hs --- a/src/parserlib/CommonParserUtil.hs +++ b/src/parserlib/CommonParserUtil.hs @@ -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 {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 +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 + diff --git a/src/parserlib/LoadAutomaton.hs b/src/parserlib/LoadAutomaton.hs --- a/src/parserlib/LoadAutomaton.hs +++ b/src/parserlib/LoadAutomaton.hs @@ -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 = diff --git a/src/parserlib/SaveProdRules.hs b/src/parserlib/SaveProdRules.hs --- a/src/parserlib/SaveProdRules.hs +++ b/src/parserlib/SaveProdRules.hs @@ -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 diff --git a/src/parserlib/Terminal.hs b/src/parserlib/Terminal.hs --- a/src/parserlib/Terminal.hs +++ b/src/parserlib/Terminal.hs @@ -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 diff --git a/src/parserlib/TokenInterface.hs b/src/parserlib/TokenInterface.hs --- a/src/parserlib/TokenInterface.hs +++ b/src/parserlib/TokenInterface.hs @@ -3,8 +3,6 @@ class TokenInterface token where -- toToken :: String -> token fromToken :: token -> String - - - + isEOT :: token -> Bool diff --git a/src/parserlib/algo/SynCompAlgoBU.hs b/src/parserlib/algo/SynCompAlgoBU.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/algo/SynCompAlgoBU.hs @@ -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 액션이 있어도 진행될 수 있음! + + + diff --git a/src/parserlib/algo/SynCompAlgoBUTree.hs b/src/parserlib/algo/SynCompAlgoBUTree.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/algo/SynCompAlgoBUTree.hs @@ -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 + + + + diff --git a/src/parserlib/algo/SynCompAlgoBUTreeNested.hs b/src/parserlib/algo/SynCompAlgoBUTreeNested.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/algo/SynCompAlgoBUTreeNested.hs @@ -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) + + + + diff --git a/src/parserlib/algo/SynCompAlgoPEPM.hs b/src/parserlib/algo/SynCompAlgoPEPM.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/algo/SynCompAlgoPEPM.hs @@ -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)) + diff --git a/src/parserlib/algo/SynCompAlgoTD.hs b/src/parserlib/algo/SynCompAlgoTD.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/algo/SynCompAlgoTD.hs @@ -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 액션이 있어도 진행될 수 있음! diff --git a/src/parserlib/algo/SynCompAlgoUtil.hs b/src/parserlib/algo/SynCompAlgoUtil.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/algo/SynCompAlgoUtil.hs @@ -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) diff --git a/src/parserlib/algo/SynCompAlgorithm.hs b/src/parserlib/algo/SynCompAlgorithm.hs new file mode 100644 --- /dev/null +++ b/src/parserlib/algo/SynCompAlgorithm.hs @@ -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 + diff --git a/src/syncomplib/EmacsServer.hs b/src/syncomplib/EmacsServer.hs --- a/src/syncomplib/EmacsServer.hs +++ b/src/syncomplib/EmacsServer.hs @@ -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 diff --git a/src/syncomplib/SynCompInterface.hs b/src/syncomplib/SynCompInterface.hs --- a/src/syncomplib/SynCompInterface.hs +++ b/src/syncomplib/SynCompInterface.hs @@ -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) diff --git a/src/util/ReadGrammar.hs b/src/util/ReadGrammar.hs --- a/src/util/ReadGrammar.hs +++ b/src/util/ReadGrammar.hs @@ -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 $ "]" + diff --git a/yapb.cabal b/yapb.cabal --- a/yapb.cabal +++ b/yapb.cabal @@ -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 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