{-# LANGUAGE GADTs #-}
module CommonParserUtil
  ( LexerSpec(..), ParserSpec(..)
  , lexing, lexingWithLineColumn, parsing, runAutomaton
  , 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 { LexerSpec token -> token
endOfToken    :: token,
              LexerSpec token -> LexerSpecList 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 { ParserSpec token ast -> String
startSymbol    :: String,
               ParserSpec token ast -> ParserSpecList token ast
parserSpecList :: ParserSpecList token ast,
               ParserSpec token ast -> String
baseDir        :: String,   -- ex) ./
               ParserSpec token ast -> String
actionTblFile  :: String,   -- ex) actiontable.txt
               ParserSpec token ast -> String
gotoTblFile    :: String,   -- ex) gototable.txt
               ParserSpec token ast -> String
grammarFile    :: String,   -- ex) grammar.txt
               ParserSpec token ast -> String
parserSpecFile :: String,   -- ex) mygrammar.grm
               ParserSpec token ast -> String
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, Int -> LexError -> ShowS
[LexError] -> ShowS
LexError -> String
(Int -> LexError -> ShowS)
-> (LexError -> String) -> ([LexError] -> ShowS) -> Show LexError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LexError] -> ShowS
$cshowList :: [LexError] -> ShowS
show :: LexError -> String
$cshow :: LexError -> String
showsPrec :: Int -> LexError -> ShowS
$cshowsPrec :: Int -> LexError -> ShowS
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 token -> String -> IO [Terminal token]
lexing LexerSpec token
lexerspec String
text = do
  (Int
line, Int
col, [Terminal token]
terminalList) <- LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
forall token.
TokenInterface token =>
LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
lexingWithLineColumn LexerSpec token
lexerspec Int
1 Int
1 String
text
  [Terminal token] -> IO [Terminal token]
forall (m :: * -> *) a. Monad m => a -> m a
return [Terminal token]
terminalList

lexingWithLineColumn :: TokenInterface token =>
           LexerSpec token -> Line -> Column -> String -> IO (Line, Column, [Terminal token])
lexingWithLineColumn :: LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
lexingWithLineColumn LexerSpec token
lexerspec Int
line Int
col [] = do
  let eot :: token
eot = LexerSpec token -> token
forall token. LexerSpec token -> token
endOfToken LexerSpec token
lexerspec 
  (Int, Int, [Terminal token]) -> IO (Int, Int, [Terminal token])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
line, Int
col, [String -> Int -> Int -> Maybe token -> Terminal token
forall token.
TokenInterface token =>
String -> Int -> Int -> Maybe token -> Terminal token
Terminal (token -> String
forall token. TokenInterface token => token -> String
fromToken token
eot) Int
line Int
col (token -> Maybe token
forall a. a -> Maybe a
Just token
eot)])
   
lexingWithLineColumn LexerSpec token
lexerspec Int
line Int
col String
text = do  --Todo: make it tail-recursive!
  (String
matchedText, String
theRestText, Maybe token
maybeTok) <-
    Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
forall token.
TokenInterface token =>
Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
matchLexSpec Int
line Int
col (LexerSpec token -> LexerSpecList token
forall token. LexerSpec token -> LexerSpecList token
lexerSpecList LexerSpec token
lexerspec) String
text
  let (Int
line_, Int
col_) = Int -> Int -> String -> (Int, Int)
moveLineCol Int
line Int
col String
matchedText
  (Int
line__, Int
col__, [Terminal token]
terminalList) <- LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
forall token.
TokenInterface token =>
LexerSpec token
-> Int -> Int -> String -> IO (Int, Int, [Terminal token])
lexingWithLineColumn LexerSpec token
lexerspec Int
line_ Int
col_ String
theRestText
  case Maybe token
maybeTok of
    Maybe token
Nothing  -> (Int, Int, [Terminal token]) -> IO (Int, Int, [Terminal token])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
line__, Int
col__, [Terminal token]
terminalList)
    Just token
tok -> do
      let terminal :: Terminal token
terminal = String -> Int -> Int -> Maybe token -> Terminal token
forall token.
TokenInterface token =>
String -> Int -> Int -> Maybe token -> Terminal token
Terminal String
matchedText Int
line Int
col (token -> Maybe token
forall a. a -> Maybe a
Just token
tok)
      (Int, Int, [Terminal token]) -> IO (Int, Int, [Terminal token])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
line__, Int
col__, Terminal token
terminalTerminal token -> [Terminal token] -> [Terminal token]
forall a. a -> [a] -> [a]
:[Terminal token]
terminalList)

matchLexSpec :: TokenInterface token =>
                Line -> Column -> LexerSpecList token -> String
             -> IO (String, String, Maybe token)
matchLexSpec :: Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
matchLexSpec Int
line Int
col [] String
text = do
  LexError -> IO (String, String, Maybe token)
forall a e. Exception e => e -> a
throw (Int -> Int -> String -> LexError
CommonParserUtil.LexError Int
line Int
col String
text)
  -- putStr $ "No matching lexer spec at "
  -- putStr $ "Line " ++ show line
  -- putStr $ "Column " ++ show col
  -- putStr $ " : "
  -- putStr $ take 10 text
  -- exitWith (ExitFailure (-1))

matchLexSpec Int
line Int
col ((String
aSpec,LexFun token
tokenBuilder):LexerSpecList token
lexerspec) String
text = do
  let (String
pre, String
matched, String
post) = String
text String -> String -> (String, String, String)
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
aSpec :: (String,String,String)
  case String
pre of
    String
"" -> (String, String, Maybe token) -> IO (String, String, Maybe token)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
matched, String
post, LexFun token
tokenBuilder String
matched)
    String
_  -> Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
forall token.
TokenInterface token =>
Int
-> Int
-> LexerSpecList token
-> String
-> IO (String, String, Maybe token)
matchLexSpec Int
line Int
col LexerSpecList token
lexerspec String
text


moveLineCol :: Line -> Column -> String -> (Line, Column)
moveLineCol :: Int -> Int -> String -> (Int, Int)
moveLineCol Int
line Int
col String
""          = (Int
line, Int
col)
moveLineCol Int
line Int
col (Char
'\n':String
text) = Int -> Int -> String -> (Int, Int)
moveLineCol (Int
lineInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
1 String
text
moveLineCol Int
line Int
col (Char
ch:String
text)   = Int -> Int -> String -> (Int, Int)
moveLineCol Int
line (Int
colInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
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 :: Int -> ParseError token ast -> ShowS
showsPrec Int
p (NotFoundAction Terminal token
terminal Int
state Stack token ast
stack ActionTable
_ GotoTable
_ ProdRules
_ [Terminal token]
_) =
    String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"NotFoundAction: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (Int -> String
forall a. Show a => a -> String
show Int
state) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal) -- (++) (show $ length stack)
  showsPrec Int
p (NotFoundGoto Int
topstate String
lhs Stack token ast
stack ActionTable
_ GotoTable
_ ProdRules
_ [Terminal token]
_) =
    String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
"NotFoundGoto: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (Int -> String
forall a. Show a => a -> String
show Int
topstate) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
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 :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
           Bool -> ParserSpec token ast -> [Terminal token] -> IO ast
parsing :: Bool -> ParserSpec token ast -> [Terminal token] -> IO ast
parsing Bool
flag ParserSpec token ast
parserSpec [Terminal token]
terminalList = do
  -- 1. Save the production rules in the parser spec (Parser.hs).
  Bool
writtenBool <- String -> String -> [String] -> IO Bool
saveProdRules String
specFileName String
sSym [String]
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
writtenBool IO ()
generateAutomaton

  -- 3. Load automaton files (prod_rules/action_table/goto_table.txt)
  (ActionTable
actionTbl, GotoTable
gotoTbl, ProdRules
prodRules) <-
    String
-> String -> String -> IO (ActionTable, GotoTable, ProdRules)
loadAutomaton String
grammarFileName String
actionTblFileName String
gotoTblFileName

  -- 4. Run the automaton
  if ActionTable -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ActionTable
actionTbl Bool -> Bool -> Bool
|| GotoTable -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null GotoTable
gotoTbl Bool -> Bool -> Bool
|| ProdRules -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProdRules
prodRules
    then do let hashFile :: String
hashFile = ShowS
getHashFileName String
specFileName
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Delete " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hashFile
            String -> IO ()
removeIfExists String
hashFile
            String -> IO ast
forall a. HasCallStack => String -> a
error (String -> IO ast) -> String -> IO ast
forall a b. (a -> b) -> a -> b
$ String
"Error: Empty automation: please rerun"
    else do ast
ast <- Bool
-> Int
-> ActionTable
-> GotoTable
-> ProdRules
-> ParseFunList token ast
-> [Terminal token]
-> IO ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> Int
-> ActionTable
-> GotoTable
-> ProdRules
-> ParseFunList token ast
-> [Terminal token]
-> IO ast
runAutomaton Bool
flag Int
initState ActionTable
actionTbl GotoTable
gotoTbl ProdRules
prodRules ParseFunList token ast
pFunList [Terminal token]
terminalList
            -- putStrLn "done." -- It was for the interafce with Java-version RPC calculus interpreter.
            ast -> IO ast
forall (m :: * -> *) a. Monad m => a -> m a
return ast
ast

  where
    specFileName :: String
specFileName      = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
parserSpecFile ParserSpec token ast
parserSpec
    grammarFileName :: String
grammarFileName   = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
grammarFile    ParserSpec token ast
parserSpec
    actionTblFileName :: String
actionTblFileName = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
actionTblFile  ParserSpec token ast
parserSpec
    gotoTblFileName :: String
gotoTblFileName   = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
gotoTblFile    ParserSpec token ast
parserSpec
    
    sSym :: String
sSym      = ParserSpec token ast -> String
forall token ast. ParserSpec token ast -> String
startSymbol ParserSpec token ast
parserSpec
    pSpecList :: [String]
pSpecList = ((String, ParseFun token ast) -> String)
-> [(String, ParseFun token ast)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, ParseFun token ast) -> String
forall a b. (a, b) -> a
fst (ParserSpec token ast -> [(String, ParseFun token ast)]
forall token ast. ParserSpec token ast -> ParserSpecList token ast
parserSpecList ParserSpec token ast
parserSpec)
    pFunList :: ParseFunList token ast
pFunList  = ((String, ParseFun token ast) -> ParseFun token ast)
-> [(String, ParseFun token ast)] -> ParseFunList token ast
forall a b. (a -> b) -> [a] -> [b]
map (String, ParseFun token ast) -> ParseFun token ast
forall a b. (a, b) -> b
snd (ParserSpec token ast -> [(String, ParseFun token ast)]
forall token ast. ParserSpec token ast -> ParserSpecList token ast
parserSpecList ParserSpec token ast
parserSpec)

    generateAutomaton :: IO ()
generateAutomaton = do
      ExitCode
exitCode <- String -> [String] -> IO ExitCode
rawSystem String
"stack"
                  [ String
"exec", String
"--",
                    String
"yapb-exe", String
specFileName, String
"-output",
                    String
grammarFileName, String
actionTblFileName, String
gotoTblFileName
                  ]
      case ExitCode
exitCode of
        ExitFailure Int
code -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
exitCode
        ExitCode
ExitSuccess -> String -> IO ()
putStrLn (String
"Successfully generated: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                 String
actionTblFileName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", "  String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                 String
gotoTblFileName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                 String
grammarFileName);
--
removeIfExists :: FilePath -> IO ()
removeIfExists :: String -> IO ()
removeIfExists String
fileName = String -> IO ()
removeFile String
fileName IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO ()
handleExists
  where handleExists :: IOError -> IO ()
handleExists IOError
e
          | IOError -> Bool
isDoesNotExistError IOError
e = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          | Bool
otherwise = IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
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 Int
i)          == :: StkElem token ast -> StkElem token ast -> Bool
== (StkState Int
j)          = Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j
  (StkTerminal Terminal token
termi)   == (StkTerminal Terminal token
termj)   = Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
tokenTextFromTerminal Terminal token
termi String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
tokenTextFromTerminal Terminal token
termj
  (StkNonterminal Maybe ast
_ String
si) == (StkNonterminal Maybe ast
_ String
sj) = String
si String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
sj

type Stack token ast = [StkElem token ast]

emptyStack :: [a]
emptyStack = []

get :: Stack token ast -> Int -> ast
get :: Stack token ast -> Int -> ast
get Stack token ast
stack Int
i =
  case Stack token ast
stack Stack token ast -> Int -> StkElem token ast
forall a. [a] -> Int -> a
!! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) of
    StkNonterminal (Just ast
ast) String
_ -> ast
ast
    StkNonterminal Maybe ast
Nothing String
_ -> String -> ast
forall a. HasCallStack => String -> a
error (String -> ast) -> String -> ast
forall a b. (a -> b) -> a -> b
$ String
"get: empty ast in the nonterminal at stack"
    StkElem token ast
_ -> String -> ast
forall a. HasCallStack => String -> a
error (String -> ast) -> String -> ast
forall a b. (a -> b) -> a -> b
$ String
"get: out of bound: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

getText :: Stack token ast -> Int -> String
getText :: Stack token ast -> Int -> String
getText Stack token ast
stack Int
i = 
  case Stack token ast
stack Stack token ast -> Int -> StkElem token ast
forall a. [a] -> Int -> a
!! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) of
    StkTerminal (Terminal String
text Int
_ Int
_ Maybe token
_) -> String
text
    StkElem token ast
_ -> ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"getText: out of bound: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

push :: a -> [a] -> [a]
push :: a -> [a] -> [a]
push a
elem [a]
stack = a
elema -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
stack

pop :: [a] -> (a, [a])
pop :: [a] -> (a, [a])
pop (a
elem:[a]
stack) = (a
elem, [a]
stack)
pop []           = String -> (a, [a])
forall a. HasCallStack => String -> a
error String
"Attempt to pop from the empty stack"

prStack :: TokenInterface token => Stack token ast -> String
prStack :: Stack token ast -> String
prStack [] = String
"STACK END"
prStack (StkState Int
i : Stack token ast
stack) = String
"S" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stack
prStack (StkTerminal (Terminal String
text Int
_ Int
_ (Just token
token)) : Stack token ast
stack) =
  let str_token :: String
str_token = token -> String
forall token. TokenInterface token => token -> String
fromToken token
token in
  (if String
str_token String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
text then String
str_token else (token -> String
forall token. TokenInterface token => token -> String
fromToken token
token String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" i.e. " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
text))
    String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stack
prStack (StkTerminal (Terminal String
text Int
_ Int
_ Maybe token
Nothing) : Stack token ast
stack) =
  (String
token_na String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
text) String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stack
prStack (StkNonterminal Maybe ast
_ String
str : Stack token ast
stack) = String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stack

-- Utility for Automation
currentState :: Stack token ast -> Int
currentState :: Stack token ast -> Int
currentState (StkState Int
i : Stack token ast
stack) = Int
i
currentState Stack token ast
_                    = String -> Int
forall a. HasCallStack => String -> a
error String
"No state found in the stack top"

tokenTextFromTerminal :: TokenInterface token => Terminal token -> String
tokenTextFromTerminal :: Terminal token -> String
tokenTextFromTerminal (Terminal String
_ Int
_ Int
_ (Just token
token)) = token -> String
forall token. TokenInterface token => token -> String
fromToken token
token
tokenTextFromTerminal (Terminal String
_ Int
_ Int
_ Maybe token
Nothing) = String
token_na

lookupActionTable :: TokenInterface token => ActionTable -> Int -> (Terminal token) -> Maybe Action
lookupActionTable :: ActionTable -> Int -> Terminal token -> Maybe Action
lookupActionTable ActionTable
actionTbl Int
state Terminal token
terminal =
  ActionTable -> (Int, String) -> String -> Maybe Action
forall a b. (Eq a, Show a) => [(a, b)] -> a -> String -> Maybe b
lookupTable ActionTable
actionTbl (Int
state,Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
tokenTextFromTerminal Terminal token
terminal)
     (String
"Not found in the action table: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal) 

lookupGotoTable :: GotoTable -> Int -> String -> Maybe Int
lookupGotoTable :: GotoTable -> Int -> String -> Maybe Int
lookupGotoTable GotoTable
gotoTbl Int
state String
nonterminalStr =
  GotoTable -> (Int, String) -> String -> Maybe Int
forall a b. (Eq a, Show a) => [(a, b)] -> a -> String -> Maybe b
lookupTable GotoTable
gotoTbl (Int
state,String
nonterminalStr)
     (String
"Not found in the goto table: ")

lookupTable :: (Eq a, Show a) => [(a,b)] -> a -> String -> Maybe b
lookupTable :: [(a, b)] -> a -> String -> Maybe b
lookupTable [(a, b)]
tbl a
key String
msg =   
  case [ b
val | (a
key', b
val) <- [(a, b)]
tbl, a
keya -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
key' ] of
    [] -> Maybe b
forall a. Maybe a
Nothing -- error $ msg ++ " : " ++ show key
    (b
h:[b]
_) -> b -> Maybe b
forall a. a -> Maybe a
Just b
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 :: Int -> [a] -> [a]
revTakeRhs Int
0 [a]
stack = []
revTakeRhs Int
n (a
_:a
nt:[a]
stack) = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
revTakeRhs (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [a]
stack [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
nt]

-- Automaton

initState :: Int
initState = Int
0

type ParseFunList token ast = [ParseFun token ast]

runAutomaton :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
  Bool -> Int -> 
  {- static part -}
  ActionTable -> GotoTable -> ProdRules -> ParseFunList token ast -> 
  {- dynamic part -}
  [Terminal token] ->
  {- AST -}
  IO ast
runAutomaton :: Bool
-> Int
-> ActionTable
-> GotoTable
-> ProdRules
-> ParseFunList token ast
-> [Terminal token]
-> IO ast
runAutomaton Bool
flag Int
initState ActionTable
actionTbl GotoTable
gotoTbl ProdRules
prodRules ParseFunList token ast
pFunList [Terminal token]
terminalList = do
  let initStack :: [StkElem token ast]
initStack = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
initState) [StkElem token ast]
forall a. [a]
emptyStack
  [Terminal token] -> [StkElem token ast] -> IO ast
run [Terminal token]
terminalList [StkElem token ast]
initStack
  
  where
    {- run :: TokenInterface token => [Terminal token] -> Stack token ast -> IO ast -}
    run :: [Terminal token] -> [StkElem token ast] -> IO ast
run [Terminal token]
terminalList [StkElem token ast]
stack = do
      let state :: Int
state = [StkElem token ast] -> Int
forall token ast. Stack token ast -> Int
currentState [StkElem token ast]
stack
      let terminal :: Terminal token
terminal = [Terminal token] -> Terminal token
forall a. [a] -> a
head [Terminal token]
terminalList
      let text :: String
text  = Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
tokenTextFromTerminal Terminal token
terminal
      let action :: Action
action =
           case ActionTable -> Int -> Terminal token -> Maybe Action
forall token.
TokenInterface token =>
ActionTable -> Int -> Terminal token -> Maybe Action
lookupActionTable ActionTable
actionTbl Int
state Terminal token
terminal of
             Just Action
action -> Action
action
             Maybe Action
Nothing -> ParseError token ast -> Action
forall a e. Exception e => e -> a
throw (Terminal token
-> Int
-> [StkElem token ast]
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Terminal token
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
NotFoundAction Terminal token
terminal Int
state [StkElem token ast]
stack ActionTable
actionTbl GotoTable
gotoTbl ProdRules
prodRules [Terminal token]
terminalList)
                        -- error $ ("Not found in the action table: "
                        --          ++ terminalToString terminal)
                        --          ++ " : "
                        --          ++ show (state, tokenTextFromTerminal terminal)
                        --          ++ "\n" ++ prStack stack ++ "\n"
      
      Bool -> String -> IO ()
debug Bool
flag (String
"\nState " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state)
      Bool -> String -> IO ()
debug Bool
flag (String
"Token " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
text)
      Bool -> String -> IO ()
debug Bool
flag (String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [StkElem token ast] -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack [StkElem token ast]
stack)
      
      case Action
action of
        Action
Accept -> do
          Bool -> String -> IO ()
debug Bool
flag String
"Accept"
          
          case [StkElem token ast]
stack [StkElem token ast] -> Int -> StkElem token ast
forall a. [a] -> Int -> a
!! Int
1 of
            StkNonterminal (Just ast
ast) String
_ -> ast -> IO ast
forall (m :: * -> *) a. Monad m => a -> m a
return ast
ast
            StkNonterminal Maybe ast
Nothing String
_ -> String -> IO ast
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty ast in the stack nonterminal"
            StkElem token ast
_ -> String -> IO ast
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not Stknontermianl on Accept"
        
        Shift Int
toState -> do
          Bool -> String -> IO ()
debug Bool
flag (String
"Shift " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
toState)
          
          let stack1 :: [StkElem token ast]
stack1 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Terminal token -> StkElem token ast
forall token ast. Terminal token -> StkElem token ast
StkTerminal ([Terminal token] -> Terminal token
forall a. [a] -> a
head [Terminal token]
terminalList)) [StkElem token ast]
stack
          let stack2 :: [StkElem token ast]
stack2 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
toState) [StkElem token ast]
stack1
          [Terminal token] -> [StkElem token ast] -> IO ast
run ([Terminal token] -> [Terminal token]
forall a. [a] -> [a]
tail [Terminal token]
terminalList) [StkElem token ast]
stack2
          
        Reduce Int
n -> do
          Bool -> String -> IO ()
debug Bool
flag (String
"Reduce " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
          
          let prodrule :: (String, [String])
prodrule   = ProdRules
prodRules ProdRules -> Int -> (String, [String])
forall a. [a] -> Int -> a
!! Int
n
          
          Bool -> String -> IO ()
debug Bool
flag (String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String, [String]) -> String
forall a. Show a => a -> String
show (String, [String])
prodrule)
          
          let builderFun :: ParseFun token ast
builderFun = ParseFunList token ast
pFunList  ParseFunList token ast -> Int -> ParseFun token ast
forall a. [a] -> Int -> a
!! Int
n
          let lhs :: String
lhs        = (String, [String]) -> String
forall a b. (a, b) -> a
fst (String, [String])
prodrule
          let rhsLength :: Int
rhsLength  = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((String, [String]) -> [String]
forall a b. (a, b) -> b
snd (String, [String])
prodrule)
          let rhsAst :: [StkElem token ast]
rhsAst = Int -> [StkElem token ast] -> [StkElem token ast]
forall a. Int -> [a] -> [a]
revTakeRhs Int
rhsLength [StkElem token ast]
stack
          let ast :: ast
ast = ParseFun token ast
builderFun [StkElem token ast]
rhsAst
          let stack1 :: [StkElem token ast]
stack1 = Int -> [StkElem token ast] -> [StkElem token ast]
forall a. Int -> [a] -> [a]
drop (Int
rhsLengthInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2) [StkElem token ast]
stack
          let topState :: Int
topState = [StkElem token ast] -> Int
forall token ast. Stack token ast -> Int
currentState [StkElem token ast]
stack1
          let toState :: Int
toState =
               case GotoTable -> Int -> String -> Maybe Int
lookupGotoTable GotoTable
gotoTbl Int
topState String
lhs of
                 Just Int
state -> Int
state
                 Maybe Int
Nothing -> ParseError token ast -> Int
forall a e. Exception e => e -> a
throw (Int
-> String
-> [StkElem token ast]
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Int
-> String
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> ParseError token ast
NotFoundGoto Int
topState String
lhs [StkElem token ast]
stack ActionTable
actionTbl GotoTable
gotoTbl ProdRules
prodRules [Terminal token]
terminalList)
                            -- error $ ("Not found in the goto table: ")
                            --         ++ " : "
                            --         ++ show (topState,lhs) ++ "\n"
                            --         ++ prStack stack ++ "\n"
  
          let stack2 :: [StkElem token ast]
stack2 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Maybe ast -> String -> StkElem token ast
forall token ast. Maybe ast -> String -> StkElem token ast
StkNonterminal (ast -> Maybe ast
forall a. a -> Maybe a
Just ast
ast) String
lhs) [StkElem token ast]
stack1
          let stack3 :: [StkElem token ast]
stack3 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
toState) [StkElem token ast]
stack2
          [Terminal token] -> [StkElem token ast] -> IO ast
run [Terminal token]
terminalList [StkElem token ast]
stack3

debug :: Bool -> String -> IO ()
debug :: Bool -> String -> IO ()
debug Bool
flag String
msg = if Bool
flag then String -> IO ()
putStrLn String
msg else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

prlevel :: Int -> String
prlevel Int
n = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n (let spaces :: String
spaces = Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: String
spaces in String
spaces)

-- | Computing candidates

data Candidate =     -- Todo: data Candidate vs. data EmacsDataItem = ... | Candidate String 
    TerminalSymbol String
  | NonterminalSymbol String
  deriving (Int -> Candidate -> ShowS
[Candidate] -> ShowS
Candidate -> String
(Int -> Candidate -> ShowS)
-> (Candidate -> String)
-> ([Candidate] -> ShowS)
-> Show Candidate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Candidate] -> ShowS
$cshowList :: [Candidate] -> ShowS
show :: Candidate -> String
$cshow :: Candidate -> String
showsPrec :: Int -> Candidate -> ShowS
$cshowsPrec :: Int -> Candidate -> ShowS
Show,Candidate -> Candidate -> Bool
(Candidate -> Candidate -> Bool)
-> (Candidate -> Candidate -> Bool) -> Eq Candidate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Candidate -> Candidate -> Bool
$c/= :: Candidate -> Candidate -> Bool
== :: Candidate -> Candidate -> Bool
$c== :: Candidate -> Candidate -> Bool
Eq)

data Automaton token ast =
  Automaton {
    Automaton token ast -> ActionTable
actTbl    :: ActionTable,
    Automaton token ast -> GotoTable
gotoTbl   :: GotoTable,
    Automaton token ast -> ProdRules
prodRules :: ProdRules
  }
  
compCandidates
  :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
     Bool      -- debug
     -> Int    -- maximum search depth level
     -> Bool   -- simple or nested
     -> Int
     -> [Candidate]
     -> Int
     -> Automaton token ast
     -> Stack token ast
     -> IO [[Candidate]]

compCandidates :: Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> IO [[Candidate]]
compCandidates Bool
flag Int
maxLevel Bool
isSimple Int
level [Candidate]
symbols Int
state Automaton token ast
automaton Stack token ast
stk = do
  Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs Bool
flag Int
maxLevel Bool
isSimple Int
level [Candidate]
symbols Int
state Automaton token ast
automaton Stack token ast
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) =>
     Bool
     -> Int
     -> Bool
     -> Int
     -> [Candidate]
     -> Int
     -> Automaton token ast
     -> Stack token ast
     -> [(Int, Stack token ast, String)]
     -> IO [[Candidate]]

compGammasDfs :: Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs Bool
flag Int
maxLevel Bool
isSimple Int
level [Candidate]
symbols Int
state Automaton token ast
automaton Stack token ast
stk [(Int, Stack token ast, String)]
history =
  if Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLevel then
    [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return (if [Candidate] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Candidate]
symbols then [] else [[Candidate]
symbols])
  else
  Bool
-> Bool
-> Int
-> Int
-> Stack token ast
-> String
-> [(Int, Stack token ast, String)]
-> ([(Int, Stack token ast, String)] -> IO [[Candidate]])
-> IO [[Candidate]]
forall a token ast a.
(Eq a, TokenInterface token, Show a) =>
Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
flag Bool
False Int
level Int
state Stack token ast
stk String
"" [(Int, Stack token ast, String)]
history
   (\[(Int, Stack token ast, String)]
history -> 
     case [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int
prnum | ((Int
s,String
lookahead),Reduce Int
prnum) <- Automaton token ast -> ActionTable
forall token ast. Automaton token ast -> ActionTable
actTbl Automaton token ast
automaton, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
s] of
      [] ->
        case [(String, Int)] -> [(String, Int)]
forall a. Eq a => [a] -> [a]
nub [(String
nonterminal,Int
toState) | ((Int
fromState,String
nonterminal),Int
toState) <- Automaton token ast -> GotoTable
forall token ast. Automaton token ast -> GotoTable
gotoTbl Automaton token ast
automaton, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
fromState] of
          [] ->
            if [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool
True | ((Int
s,String
lookahead),Action
Accept) <- Automaton token ast -> ActionTable
forall token ast. Automaton token ast -> ActionTable
actTbl Automaton token ast
automaton, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
s] Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
            then do 
                   [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else let cand2 :: [(String, Int)]
cand2 = [(String, Int)] -> [(String, Int)]
forall a. Eq a => [a] -> [a]
nub [(String
terminal,Int
snext) | ((Int
s,String
terminal),Shift Int
snext) <- Automaton token ast -> ActionTable
forall token ast. Automaton token ast -> ActionTable
actTbl Automaton token ast
automaton, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
s] in
                 let len :: Int
len = [(String, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Int)]
cand2 in
                 case [(String, Int)]
cand2 of
                  [] -> [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
               
                  [(String, Int)]
_  -> do [[[Candidate]]]
listOfList <-
                             (((String, Int), Integer) -> IO [[Candidate]])
-> [((String, Int), Integer)] -> IO [[[Candidate]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ ((String
terminal,Int
snext),Integer
i)->
                                let stk1 :: Stack token ast
stk1 = StkElem token ast -> Stack token ast -> Stack token ast
forall a. a -> [a] -> [a]
push (Terminal token -> StkElem token ast
forall token ast. Terminal token -> StkElem token ast
StkTerminal (String -> Int -> Int -> Maybe token -> Terminal token
forall token.
TokenInterface token =>
String -> Int -> Int -> Maybe token -> Terminal token
Terminal String
terminal Int
0 Int
0 Maybe token
forall a. Maybe a
Nothing)) Stack token ast
stk  -- Todo: ??? (toToken terminal)
                                    stk2 :: Stack token ast
stk2 = StkElem token ast -> Stack token ast -> Stack token ast
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
snext) Stack token ast
stk1
                                in 
                                -- checkCycle False level snext stk2 ("SHIFT " ++ show snext ++ " " ++ terminal) history
                                -- checkCycle True level state stk terminal history
                                Bool
-> Bool
-> Int
-> Int
-> Stack token ast
-> String
-> [(Int, Stack token ast, String)]
-> ([(Int, Stack token ast, String)] -> IO [[Candidate]])
-> IO [[Candidate]]
forall a token ast a.
(Eq a, TokenInterface token, Show a) =>
Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
flag Bool
True Int
level Int
snext Stack token ast
stk2 String
terminal [(Int, Stack token ast, String)]
history
                             
                                  (\[(Int, Stack token ast, String)]
history1 -> do
                                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"SHIFT [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]: "
                                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
terminal String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
snext
                                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Goto/Shift symbols: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show ([Candidate]
symbols[Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++[String -> Candidate
TerminalSymbol String
terminal])
                                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stk2
                                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
                                   Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs Bool
flag Int
maxLevel Bool
isSimple (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ([Candidate]
symbols[Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++[String -> Candidate
TerminalSymbol String
terminal]) Int
snext Automaton token ast
automaton Stack token ast
stk2 [(Int, Stack token ast, String)]
history1) )
                                     ([(String, Int)] -> [Integer] -> [((String, Int), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(String, Int)]
cand2 [Integer
1..])
                           [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Candidate]] -> IO [[Candidate]])
-> [[Candidate]] -> IO [[Candidate]]
forall a b. (a -> b) -> a -> b
$ [[[Candidate]]] -> [[Candidate]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Candidate]]]
listOfList
          [(String, Int)]
nontermStateList -> do
            let len :: Int
len = [(String, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Int)]
nontermStateList
   
            [[[Candidate]]]
listOfList <-
              (((String, Int), Integer) -> IO [[Candidate]])
-> [((String, Int), Integer)] -> IO [[[Candidate]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ ((String
nonterminal,Int
snext),Integer
i) ->
                 let stk1 :: Stack token ast
stk1 = StkElem token ast -> Stack token ast -> Stack token ast
forall a. a -> [a] -> [a]
push (Maybe ast -> String -> StkElem token ast
forall token ast. Maybe ast -> String -> StkElem token ast
StkNonterminal Maybe ast
forall a. Maybe a
Nothing String
nonterminal) Stack token ast
stk
                     stk2 :: Stack token ast
stk2 = StkElem token ast -> Stack token ast -> Stack token ast
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
snext) Stack token ast
stk1
                 in 
                 -- checkCycle False level snext stk2 ("GOTO " ++ show snext ++ " " ++ nonterminal) history
                 -- checkCycle True level state stk nonterminal history
                 Bool
-> Bool
-> Int
-> Int
-> Stack token ast
-> String
-> [(Int, Stack token ast, String)]
-> ([(Int, Stack token ast, String)] -> IO [[Candidate]])
-> IO [[Candidate]]
forall a token ast a.
(Eq a, TokenInterface token, Show a) =>
Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
flag Bool
True Int
level Int
snext Stack token ast
stk2 String
nonterminal [(Int, Stack token ast, String)]
history
              
                   (\[(Int, Stack token ast, String)]
history1 -> do
                    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"GOTO [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] at "
                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
nonterminal String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
snext
                    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Goto/Shift symbols:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show ([Candidate]
symbols[Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++[String -> Candidate
NonterminalSymbol String
nonterminal])
                    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stk2
                    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
      
                    Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs Bool
flag Int
maxLevel Bool
isSimple (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ([Candidate]
symbols[Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++[String -> Candidate
NonterminalSymbol String
nonterminal]) Int
snext Automaton token ast
automaton Stack token ast
stk2 [(Int, Stack token ast, String)]
history1) )
                      ([(String, Int)] -> [Integer] -> [((String, Int), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(String, Int)]
nontermStateList [Integer
1..])
            [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Candidate]] -> IO [[Candidate]])
-> [[Candidate]] -> IO [[Candidate]]
forall a b. (a -> b) -> a -> b
$ [[[Candidate]]] -> [[Candidate]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Candidate]]]
listOfList

      [Int]
prnumList -> do
        let len :: Int
len = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
prnumList
     
        Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level     String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"# of prNumList to reduce: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" at State " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state
        Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProdRules -> String
forall a. Show a => a -> String
show [ (Automaton token ast -> ProdRules
forall token ast. Automaton token ast -> ProdRules
prodRules Automaton token ast
automaton) ProdRules -> Int -> (String, [String])
forall a. [a] -> Int -> a
!! Int
prnum | Int
prnum <- [Int]
prnumList ]
     
        -- let aCandidate = if null symbols then [] else [symbols]
        -- if isSimple
        -- then return aCandidate
        -- else do listOfList <-
        do [[[Candidate]]]
listOfList <-
            ((Int, Integer) -> IO [[Candidate]])
-> [(Int, Integer)] -> IO [[[Candidate]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (Int
prnum,Integer
i) -> (
              -- checkCycle False level state stk ("REDUCE " ++ show prnum) history
              Bool
-> Bool
-> Int
-> Int
-> Stack token ast
-> String
-> [(Int, Stack token ast, String)]
-> ([(Int, Stack token ast, String)] -> IO [[Candidate]])
-> IO [[Candidate]]
forall a token ast a.
(Eq a, TokenInterface token, Show a) =>
Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
flag Bool
True Int
level Int
state Stack token ast
stk (Int -> String
forall a. Show a => a -> String
show Int
prnum) [(Int, Stack token ast, String)]
history
                (\[(Int, Stack token ast, String)]
history1 -> do
                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"State " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
state  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]" 
                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"REDUCE" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" prod #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
prnum
                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String, [String]) -> String
forall a. Show a => a -> String
show ((Automaton token ast -> ProdRules
forall token ast. Automaton token ast -> ProdRules
prodRules Automaton token ast
automaton) ProdRules -> Int -> (String, [String])
forall a. [a] -> Int -> a
!! Int
prnum)
                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Goto/Shift symbols: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show [Candidate]
symbols
                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Stack token ast -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack Stack token ast
stk
                   Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
                   Bool
-> Int
-> Int
-> Bool
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> Int
-> IO [[Candidate]]
forall token ast p.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> Int
-> Int
-> Bool
-> [Candidate]
-> p
-> Automaton token ast
-> [StkElem token ast]
-> [(Int, [StkElem token ast], String)]
-> Int
-> IO [[Candidate]]
compGammasDfsForReduce Bool
flag Int
maxLevel Int
level Bool
isSimple  [Candidate]
symbols Int
state Automaton token ast
automaton Stack token ast
stk [(Int, Stack token ast, String)]
history1 Int
prnum)) )
                 ([Int] -> [Integer] -> [(Int, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
prnumList [Integer
1..])
           [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Candidate]] -> IO [[Candidate]])
-> [[Candidate]] -> IO [[Candidate]]
forall a b. (a -> b) -> a -> b
$ [[[Candidate]]] -> [[Candidate]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Candidate]]]
listOfList )
  
compGammasDfsForReduce :: Bool
-> Int
-> Int
-> Bool
-> [Candidate]
-> p
-> Automaton token ast
-> [StkElem token ast]
-> [(Int, [StkElem token ast], String)]
-> Int
-> IO [[Candidate]]
compGammasDfsForReduce Bool
flag Int
maxLevel Int
level Bool
isSimple  [Candidate]
symbols p
state Automaton token ast
automaton [StkElem token ast]
stk [(Int, [StkElem token ast], String)]
history Int
prnum = 
  let prodrule :: (String, [String])
prodrule   = (Automaton token ast -> ProdRules
forall token ast. Automaton token ast -> ProdRules
prodRules Automaton token ast
automaton) ProdRules -> Int -> (String, [String])
forall a. [a] -> Int -> a
!! Int
prnum
      lhs :: String
lhs = (String, [String]) -> String
forall a b. (a, b) -> a
fst (String, [String])
prodrule
      rhs :: [String]
rhs = (String, [String]) -> [String]
forall a b. (a, b) -> b
snd (String, [String])
prodrule
      
      rhsLength :: Int
rhsLength = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
rhs
  in 
  if ( {- rhsLength == 0 || -} (Int
rhsLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Candidate] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Candidate]
symbols) ) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False
  then do
    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"[LEN COND: False] length rhs > length symbols: NOT " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
rhsLength String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Candidate] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Candidate]
symbols)
    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show [Candidate]
symbols
    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level
    [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- Todo: (if null symbols then [] else [symbols])
  else do
    let stk1 :: [StkElem token ast]
stk1 = Int -> [StkElem token ast] -> [StkElem token ast]
forall a. Int -> [a] -> [a]
drop (Int
rhsLengthInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2) [StkElem token ast]
stk
    let topState :: Int
topState = [StkElem token ast] -> Int
forall token ast. Stack token ast -> Int
currentState [StkElem token ast]
stk1
    let toState :: Int
toState =
         case GotoTable -> Int -> String -> Maybe Int
lookupGotoTable (Automaton token ast -> GotoTable
forall token ast. Automaton token ast -> GotoTable
gotoTbl Automaton token ast
automaton) Int
topState String
lhs of
           Just Int
state -> Int
state
           Maybe Int
Nothing -> String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"[compGammasDfsForReduce] Must not happen: lhs: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lhs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" state: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
topState
    let stk2 :: [StkElem token ast]
stk2 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Maybe ast -> String -> StkElem token ast
forall token ast. Maybe ast -> String -> StkElem token ast
StkNonterminal Maybe ast
forall a. Maybe a
Nothing String
lhs) [StkElem token ast]
stk1  -- ast
    let stk3 :: [StkElem token ast]
stk3 = StkElem token ast -> [StkElem token ast] -> [StkElem token ast]
forall a. a -> [a] -> [a]
push (Int -> StkElem token ast
forall token ast. Int -> StkElem token ast
StkState Int
toState) [StkElem token ast]
stk2
    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"GOTO after REDUCE: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
topState String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lhs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
toState
    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Goto/Shift symbols: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"[]"
    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Stack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [StkElem token ast] -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack [StkElem token ast]
stk3
    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""

    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Found a gamma: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Candidate] -> String
forall a. Show a => a -> String
show [Candidate]
symbols
    Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""

    if Bool
isSimple
    then [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return (if [Candidate] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Candidate]
symbols then [] else [[Candidate]
symbols])
    else do [[Candidate]]
listOfList <- Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> [StkElem token ast]
-> [(Int, [StkElem token ast], String)]
-> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs Bool
flag Int
maxLevel Bool
isSimple (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [] Int
toState Automaton token ast
automaton [StkElem token ast]
stk3 [(Int, [StkElem token ast], String)]
history
            [[Candidate]] -> IO [[Candidate]]
forall (m :: * -> *) a. Monad m => a -> m a
return (if [Candidate] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Candidate]
symbols then [[Candidate]]
listOfList else ([Candidate]
symbols [Candidate] -> [[Candidate]] -> [[Candidate]]
forall a. a -> [a] -> [a]
: ([Candidate] -> [Candidate]) -> [[Candidate]] -> [[Candidate]]
forall a b. (a -> b) -> [a] -> [b]
map ([Candidate]
symbols [Candidate] -> [Candidate] -> [Candidate]
forall a. [a] -> [a] -> [a]
++) [[Candidate]]
listOfList))

-- | Cycle checking
noCycleCheck :: Bool
noCycleCheck :: Bool
noCycleCheck = Bool
True

checkCycle :: Bool
-> Bool
-> Int
-> a
-> [StkElem token ast]
-> String
-> [(a, [StkElem token ast], String)]
-> ([(a, [StkElem token ast], String)] -> IO [a])
-> IO [a]
checkCycle Bool
debugflag Bool
flag Int
level a
state [StkElem token ast]
stk String
action [(a, [StkElem token ast], String)]
history [(a, [StkElem token ast], String)] -> IO [a]
cont =
  if Bool
flag Bool -> Bool -> Bool
&& (a
state,[StkElem token ast]
stk,String
action) (a, [StkElem token ast], String)
-> [(a, [StkElem token ast], String)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(a, [StkElem token ast], String)]
history
  then do
    Bool -> String -> IO ()
debug Bool
debugflag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"CYCLE is detected !!"
    Bool -> String -> IO ()
debug Bool
debugflag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
state String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
action
    Bool -> String -> IO ()
debug Bool
debugflag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
prlevel Int
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ [StkElem token ast] -> String
forall token ast. TokenInterface token => Stack token ast -> String
prStack [StkElem token ast]
stk
    Bool -> String -> IO ()
debug Bool
debugflag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
""
    [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  else [(a, [StkElem token ast], String)] -> IO [a]
cont ( (a
state,[StkElem token ast]
stk,String
action) (a, [StkElem token ast], String)
-> [(a, [StkElem token ast], String)]
-> [(a, [StkElem token ast], String)]
forall a. a -> [a] -> [a]
: [(a, [StkElem token ast], String)]
history )

-- | Parsing programming interfaces

-- | successfullyParsed
successfullyParsed :: IO [EmacsDataItem]
successfullyParsed :: IO [EmacsDataItem]
successfullyParsed = [EmacsDataItem] -> IO [EmacsDataItem]
forall (m :: * -> *) a. Monad m => a -> m a
return [EmacsDataItem
SynCompInterface.SuccessfullyParsed]

-- | handleLexError
handleLexError :: IO [EmacsDataItem]
handleLexError :: IO [EmacsDataItem]
handleLexError = [EmacsDataItem] -> IO [EmacsDataItem]
forall (m :: * -> *) a. Monad m => a -> m a
return [EmacsDataItem
SynCompInterface.LexError]

-- | handleParseError
handleParseError :: TokenInterface token => Bool -> Int -> Bool -> [Terminal token] -> ParseError token ast -> IO [EmacsDataItem]
handleParseError :: Bool
-> Int
-> Bool
-> [Terminal token]
-> ParseError token ast
-> IO [EmacsDataItem]
handleParseError Bool
flag Int
maxLevel Bool
isSimple [Terminal token]
terminalListAfterCursor ParseError token ast
parseError =
  Bool
-> Int
-> Bool
-> [Terminal token]
-> ParseError token ast
-> IO [EmacsDataItem]
forall token token ast.
TokenInterface token =>
Bool
-> Int
-> Bool
-> [Terminal token]
-> ParseError token ast
-> IO [EmacsDataItem]
unwrapParseError Bool
flag Int
maxLevel Bool
isSimple [Terminal token]
terminalListAfterCursor ParseError token ast
parseError
  
unwrapParseError :: Bool
-> Int
-> Bool
-> [Terminal token]
-> ParseError token ast
-> IO [EmacsDataItem]
unwrapParseError Bool
flag Int
maxLevel Bool
isSimple [Terminal token]
terminalListAfterCursor (NotFoundAction Terminal token
_ Int
state Stack token ast
stk ActionTable
actTbl GotoTable
gotoTbl ProdRules
prodRules [Terminal token]
terminalList) =
  Bool
-> Int
-> Bool
-> [Terminal token]
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> IO [EmacsDataItem]
forall token ast token token.
(Typeable token, Typeable ast, Show token, Show ast,
 TokenInterface token, TokenInterface token,
 TokenInterface token) =>
Bool
-> Int
-> Bool
-> [Terminal token]
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> IO [EmacsDataItem]
arrivedAtTheEndOfSymbol Bool
flag Int
maxLevel Bool
isSimple [Terminal token]
terminalListAfterCursor Int
state Stack token ast
stk ActionTable
actTbl GotoTable
gotoTbl ProdRules
prodRules [Terminal token]
terminalList
unwrapParseError Bool
flag Int
maxLevel Bool
isSimple [Terminal token]
terminalListAfterCursor (NotFoundGoto Int
state String
_ Stack token ast
stk ActionTable
actTbl GotoTable
gotoTbl ProdRules
prodRules [Terminal token]
terminalList) =
  Bool
-> Int
-> Bool
-> [Terminal token]
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> IO [EmacsDataItem]
forall token ast token token.
(Typeable token, Typeable ast, Show token, Show ast,
 TokenInterface token, TokenInterface token,
 TokenInterface token) =>
Bool
-> Int
-> Bool
-> [Terminal token]
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> IO [EmacsDataItem]
arrivedAtTheEndOfSymbol Bool
flag Int
maxLevel Bool
isSimple [Terminal token]
terminalListAfterCursor Int
state Stack token ast
stk ActionTable
actTbl GotoTable
gotoTbl ProdRules
prodRules [Terminal token]
terminalList

arrivedAtTheEndOfSymbol :: Bool
-> Int
-> Bool
-> [Terminal token]
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> [Terminal token]
-> IO [EmacsDataItem]
arrivedAtTheEndOfSymbol Bool
flag Int
maxLevel Bool
isSimple [Terminal token]
terminalListAfterCursor Int
state Stack token ast
stk ActionTable
_actTbl GotoTable
_gotoTbl ProdRules
_prodRules [Terminal token]
terminalList =
  if [Terminal token] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Terminal token]
terminalList Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then do -- [$]
     Bool
-> Int
-> Bool
-> [Terminal token]
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> IO [EmacsDataItem]
forall token ast token.
(Typeable token, Typeable ast, Show token, Show ast,
 TokenInterface token, TokenInterface token) =>
Bool
-> Int
-> Bool
-> [Terminal token]
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> IO [EmacsDataItem]
_handleParseError Bool
flag Int
maxLevel Bool
isSimple [Terminal token]
terminalListAfterCursor Int
state Stack token ast
stk ActionTable
_actTbl GotoTable
_gotoTbl ProdRules
_prodRules
  else
     [EmacsDataItem] -> IO [EmacsDataItem]
forall (m :: * -> *) a. Monad m => a -> m a
return [[String] -> EmacsDataItem
SynCompInterface.ParseError ((Terminal token -> String) -> [Terminal token] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString [Terminal token]
terminalList)]

_handleParseError :: Bool
-> Int
-> Bool
-> [Terminal token]
-> Int
-> Stack token ast
-> ActionTable
-> GotoTable
-> ProdRules
-> IO [EmacsDataItem]
_handleParseError Bool
flag Int
maxLevel Bool
isSimple [Terminal token]
terminalListAfterCursor Int
state Stack token ast
stk ActionTable
_actTbl GotoTable
_gotoTbl ProdRules
_prodRules = do
  let automaton :: Automaton token ast
automaton = Automaton :: forall token ast.
ActionTable -> GotoTable -> ProdRules -> Automaton token ast
Automaton {actTbl :: ActionTable
actTbl=ActionTable
_actTbl, gotoTbl :: GotoTable
gotoTbl=GotoTable
_gotoTbl, prodRules :: ProdRules
prodRules=ProdRules
_prodRules}
  [[Candidate]]
candidateListList <- Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> Int
-> Bool
-> Int
-> [Candidate]
-> Int
-> Automaton token ast
-> Stack token ast
-> IO [[Candidate]]
compCandidates Bool
flag Int
maxLevel Bool
isSimple Int
0 [] Int
state Automaton token ast
automaton Stack token ast
stk
  let colorListList :: [[EmacsColor]]
colorListList =
       [ [Candidate] -> [Terminal token] -> [EmacsColor]
forall token.
TokenInterface token =>
[Candidate] -> [Terminal token] -> [EmacsColor]
filterCandidates [Candidate]
candidateList [Terminal token]
terminalListAfterCursor | [Candidate]
candidateList <- [[Candidate]]
candidateListList ]
  let strList :: [String]
strList = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [ [String] -> String
concatStrList [String]
strList | [String]
strList <- ([EmacsColor] -> [String]) -> [[EmacsColor]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ((EmacsColor -> String) -> [EmacsColor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map EmacsColor -> String
showEmacsColor) [[EmacsColor]]
colorListList ]
  let rawStrListList :: [[String]]
rawStrListList = [[String]] -> [[String]]
forall a. Eq a => [a] -> [a]
nub [ [String]
strList | [String]
strList <- ([EmacsColor] -> [String]) -> [[EmacsColor]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ((EmacsColor -> String) -> [EmacsColor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map EmacsColor -> String
showRawEmacsColor) [[EmacsColor]]
colorListList ]
  Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\[String]
x -> ([String] -> String
forall a. Show a => a -> String
show [String]
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")) [[String]]
rawStrListList -- mapM_ (putStrLn . show) rawStrListList
  [EmacsDataItem] -> IO [EmacsDataItem]
forall (m :: * -> *) a. Monad m => a -> m a
return ([EmacsDataItem] -> IO [EmacsDataItem])
-> [EmacsDataItem] -> IO [EmacsDataItem]
forall a b. (a -> b) -> a -> b
$ (String -> EmacsDataItem) -> [String] -> [EmacsDataItem]
forall a b. (a -> b) -> [a] -> [b]
map String -> EmacsDataItem
Candidate [String]
strList

-- | 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 Int -> EmacsColor -> ShowS
[EmacsColor] -> ShowS
EmacsColor -> String
(Int -> EmacsColor -> ShowS)
-> (EmacsColor -> String)
-> ([EmacsColor] -> ShowS)
-> Show EmacsColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmacsColor] -> ShowS
$cshowList :: [EmacsColor] -> ShowS
show :: EmacsColor -> String
$cshow :: EmacsColor -> String
showsPrec :: Int -> EmacsColor -> ShowS
$cshowsPrec :: Int -> EmacsColor -> ShowS
Show

filterCandidates :: (TokenInterface token) => [Candidate] -> [Terminal token] -> [EmacsColor]
filterCandidates :: [Candidate] -> [Terminal token] -> [EmacsColor]
filterCandidates [Candidate]
candidates [Terminal token]
terminalListAfterCursor =
  [Candidate] -> [Terminal token] -> [EmacsColor] -> [EmacsColor]
forall token.
TokenInterface token =>
[Candidate] -> [Terminal token] -> [EmacsColor] -> [EmacsColor]
f [Candidate]
candidates [Terminal token]
terminalListAfterCursor []
  where
    f :: [Candidate] -> [Terminal token] -> [EmacsColor] -> [EmacsColor]
f (Candidate
a:[Candidate]
alpha) (Terminal token
b:[Terminal token]
beta) [EmacsColor]
accm
      | Candidate -> Terminal token -> Bool
forall token. Candidate -> Terminal token -> Bool
equal Candidate
a Terminal token
b       = [Candidate] -> [Terminal token] -> [EmacsColor] -> [EmacsColor]
f [Candidate]
alpha [Terminal token]
beta     (String -> Int -> Int -> EmacsColor
Gray (Candidate -> String
strCandidate Candidate
a) (Terminal token -> Int
forall token. TokenInterface token => Terminal token -> Int
terminalToLine Terminal token
b) (Terminal token -> Int
forall token. TokenInterface token => Terminal token -> Int
terminalToCol Terminal token
b) EmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
: [EmacsColor]
accm)
      | Bool
otherwise       = [Candidate] -> [Terminal token] -> [EmacsColor] -> [EmacsColor]
f [Candidate]
alpha (Terminal token
bTerminal token -> [Terminal token] -> [Terminal token]
forall a. a -> [a] -> [a]
:[Terminal token]
beta) (String -> EmacsColor
White (Candidate -> String
strCandidate Candidate
a) EmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
: [EmacsColor]
accm)
    f [] [Terminal token]
beta [EmacsColor]
accm      = [EmacsColor] -> [EmacsColor]
forall a. [a] -> [a]
reverse [EmacsColor]
accm
    f (Candidate
a:[Candidate]
alpha) [] [EmacsColor]
accm = [Candidate] -> [Terminal token] -> [EmacsColor] -> [EmacsColor]
f [Candidate]
alpha [] (String -> EmacsColor
White (Candidate -> String
strCandidate Candidate
a) EmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
: [EmacsColor]
accm)

    equal :: Candidate -> Terminal token -> Bool
equal (TerminalSymbol String
s1)    (Terminal String
s2 Int
_ Int
_ Maybe token
_) = String
s1String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
s2
    equal (NonterminalSymbol String
s1) Terminal token
_                   = Bool
False

    strCandidate :: Candidate -> String
strCandidate (TerminalSymbol String
s) = String
s
    strCandidate (NonterminalSymbol String
s) = String
"..."

-- | Utilities
showSymbol :: Candidate -> String
showSymbol (TerminalSymbol String
s) = String
s
showSymbol (NonterminalSymbol String
_) = String
"..."

showRawSymbol :: Candidate -> String
showRawSymbol (TerminalSymbol String
s) = String
s
showRawSymbol (NonterminalSymbol String
s) = String
s

showEmacsColor :: EmacsColor -> String
showEmacsColor (Gray String
s Int
line Int
col) = String
"gray " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
showEmacsColor (White String
s)         = String
"white " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

showRawEmacsColor :: EmacsColor -> String
showRawEmacsColor (Gray String
s Int
line Int
col) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"@" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
showRawEmacsColor (White String
s)         = String
s

concatStrList :: [String] -> String
concatStrList [] = String
"" -- error "The empty candidate?"
concatStrList [String
str] = String
str
concatStrList (String
str:[String]
strs) = String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
concatStrList [String]
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)