{-# 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 { 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 :: Bool -> ParserSpec token ast -> [Terminal token] -> IO ast
parsing Bool
flag ParserSpec token ast
parserSpec [Terminal token]
terminalList =
  Bool
-> ParserSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> ParserSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
parsingHaskell Bool
flag ParserSpec token ast
parserSpec [Terminal token]
terminalList Maybe token
forall a. Maybe a
Nothing
  
parsingHaskell :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>
           Bool -> ParserSpec token ast -> [Terminal token] -> Maybe token -> IO ast
parsingHaskell :: Bool
-> ParserSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
parsingHaskell Bool
flag ParserSpec token ast
parserSpec [Terminal token]
terminalList Maybe token
haskellOption = 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
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
runAutomatonHaskell Bool
flag
                     (AutomatonSpec :: forall token ast.
ActionTable
-> GotoTable
-> ProdRules
-> ParseFunList token ast
-> Int
-> AutomatonSpec token ast
AutomatonSpec {
                       am_initState :: Int
am_initState=Int
initState,
                       am_actionTbl :: ActionTable
am_actionTbl=ActionTable
actionTbl,
                       am_gotoTbl :: GotoTable
am_gotoTbl=GotoTable
gotoTbl,
                       am_prodRules :: ProdRules
am_prodRules=ProdRules
prodRules,
                       am_parseFuns :: ParseFunList token ast
am_parseFuns=ParseFunList token ast
pFunList })
                     [Terminal token]
terminalList Maybe token
haskellOption
            -- 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

data AutomatonSpec token ast =
  AutomatonSpec {
    AutomatonSpec token ast -> ActionTable
am_actionTbl :: ActionTable,
    AutomatonSpec token ast -> GotoTable
am_gotoTbl :: GotoTable,
    AutomatonSpec token ast -> ProdRules
am_prodRules :: ProdRules,
    AutomatonSpec token ast -> ParseFunList token ast
am_parseFuns :: ParseFunList token ast,
    AutomatonSpec token ast -> Int
am_initState :: Int
  }

initState :: Int
initState = Int
0

type ParseFunList token ast = [ParseFun token ast]

runAutomaton :: Bool -> AutomatonSpec token ast -> [Terminal token] -> IO ast
runAutomaton Bool
flag AutomatonSpec token ast
amSpec [Terminal token]
terminalList =
  Bool
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
Bool
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
runAutomatonHaskell Bool
flag AutomatonSpec token ast
amSpec {- initState actionTbl gotoTbl prodRules pFunList-} [Terminal token]
terminalList Maybe token
forall a. Maybe a
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 :: Bool
-> AutomatonSpec token ast
-> [Terminal token]
-> Maybe token
-> IO ast
runAutomatonHaskell Bool
flag (rm_spec :: AutomatonSpec token ast
rm_spec @ AutomatonSpec {
      am_initState :: forall token ast. AutomatonSpec token ast -> Int
am_initState=Int
initState,
      am_actionTbl :: forall token ast. AutomatonSpec token ast -> ActionTable
am_actionTbl=ActionTable
actionTbl,
      am_gotoTbl :: forall token ast. AutomatonSpec token ast -> GotoTable
am_gotoTbl=GotoTable
gotoTbl,
      am_prodRules :: forall token ast. AutomatonSpec token ast -> ProdRules
am_prodRules=ProdRules
prodRules,
      am_parseFuns :: forall token ast. AutomatonSpec token ast -> ParseFunList token ast
am_parseFuns=ParseFunList token ast
pFunList
   }) [Terminal token]
terminalList Maybe token
haskellOption = 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
      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 -> do
          -- putStrLn $ terminalToString terminal {- debug -}
          Int
-> Terminal token
-> Action
-> [Terminal token]
-> [StkElem token ast]
-> IO ast
runAction Int
state Terminal token
terminal Action
action [Terminal token]
terminalList [StkElem token ast]
stack
          
        Maybe Action
Nothing -> do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"lookActionTable failed (1st) with: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal)
          case Maybe token
haskellOption of
            Just token
extraToken -> do
              let terminal_close_brace :: Terminal token
terminal_close_brace = 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
extraToken)
                                            (Terminal token -> Int
forall token. TokenInterface token => Terminal token -> Int
terminalToLine Terminal token
terminal)
                                              (Terminal token -> Int
forall token. TokenInterface token => Terminal token -> Int
terminalToCol Terminal token
terminal)
                                                (token -> Maybe token
forall a. a -> Maybe a
Just token
extraToken)
              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_close_brace of
                Just Action
action -> do
                  -- putStrLn $ terminalToString terminal_close_brace {- debug -}
                  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"lookActionTable succeeded (2nd) with: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal_close_brace
                  Int
-> Terminal token
-> Action
-> [Terminal token]
-> [StkElem token ast]
-> IO ast
runAction Int
state Terminal token
terminal_close_brace Action
action (Terminal token
terminal_close_brace Terminal token -> [Terminal token] -> [Terminal token]
forall a. a -> [a] -> [a]
: [Terminal token]
terminalList) [StkElem token ast]
stack
                  
                Maybe Action
Nothing -> do
                  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"lookActionTable failed (2nd) with: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal_close_brace
                  ParseError token ast -> IO ast
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)
                -- Nothing -> throw (NotFoundAction terminal_close_brace state stack actionTbl gotoTbl prodRules
                --                    (terminal_close_brace : terminalList))
                           
            Maybe token
Nothing -> ParseError token ast -> IO ast
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)

    -- separated to support the haskell layout rule
    runAction :: Int
-> Terminal token
-> Action
-> [Terminal token]
-> [StkElem token ast]
-> IO ast
runAction Int
state Terminal token
terminal Action
action [Terminal token]
terminalList [StkElem token ast]
stack = do      
      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]
++ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
tokenTextFromTerminal Terminal token
terminal)
      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"
          Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal {- debug -}
          
          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)
          Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString Terminal token
terminal {- debug -}
          
          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)
  
          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 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

instance Show Candidate where
  showsPrec :: Int -> Candidate -> ShowS
showsPrec Int
p (TerminalSymbol String
s) = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"Terminal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
  showsPrec Int
p (NonterminalSymbol String
s) = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"Nonterminal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

data Automaton token ast =
  Automaton {
    Automaton token ast -> ActionTable
actTbl    :: ActionTable,
    Automaton token ast -> GotoTable
gotoTbl   :: GotoTable,
    Automaton token ast -> ProdRules
prodRules :: ProdRules
  }

data CompCandidates token ast = CompCandidates {
    CompCandidates token ast -> Bool
cc_debugFlag :: Bool,
    CompCandidates token ast -> Int
cc_searchMaxLevel :: Int,
    CompCandidates token ast -> Bool
cc_simpleOrNested :: Bool,
    CompCandidates token ast -> Automaton token ast
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 :: CompCandidates token ast
-> Int -> [Candidate] -> Int -> Stack token ast -> IO [[Candidate]]
compCandidates CompCandidates token ast
ccOption Int
level [Candidate]
symbols Int
state Stack token ast
stk = do
  CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
forall token ast.
(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 CompCandidates token ast
ccOption Int
level [Candidate]
symbols Int
state 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) =>
     CompCandidates token ast
     -> Int
     -> [Candidate]
     -> Int
     -> Stack token ast
     -> [(Int, Stack token ast, String)]
     -> IO [[Candidate]]

compGammasDfs :: CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
compGammasDfs CompCandidates token ast
ccOption Int
level [Candidate]
symbols Int
state Stack token ast
stk [(Int, Stack token ast, String)]
history =
  let flag :: Bool
flag = CompCandidates token ast -> Bool
forall token ast. CompCandidates token ast -> Bool
cc_debugFlag CompCandidates token ast
ccOption
      maxLevel :: Int
maxLevel = CompCandidates token ast -> Int
forall token ast. CompCandidates token ast -> Int
cc_searchMaxLevel CompCandidates token ast
ccOption
      isSimple :: Bool
isSimple = CompCandidates token ast -> Bool
forall token ast. CompCandidates token ast -> Bool
cc_simpleOrNested CompCandidates token ast
ccOption
      automaton :: Automaton token ast
automaton = CompCandidates token ast -> Automaton token ast
forall token ast. CompCandidates token ast -> Automaton token ast
cc_automaton CompCandidates token ast
ccOption
      
      actionTable :: ActionTable
actionTable = Automaton token ast -> ActionTable
forall token ast. Automaton token ast -> ActionTable
actTbl Automaton token ast
automaton
      gotoTable :: GotoTable
gotoTable = Automaton token ast -> GotoTable
forall token ast. Automaton token ast -> GotoTable
gotoTbl Automaton token ast
automaton
      productionRules :: ProdRules
productionRules = Automaton token ast -> ProdRules
forall token ast. Automaton token ast -> ProdRules
prodRules Automaton token ast
automaton
  in
  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 ->
     {- 1. Reduce -}
     case [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int
prnum | ((Int
s,String
lookahead),Reduce Int
prnum) <- ActionTable
actionTable, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
s] of
      [] ->
        {- 2. Goto table -}
        case [(String, Int)] -> [(String, Int)]
forall a. Eq a => [a] -> [a]
nub [(String
nonterminal,Int
toState) | ((Int
fromState,String
nonterminal),Int
toState) <- GotoTable
gotoTable, Int
stateInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
fromState] of
          [] ->
            {- 3. Accept -}
            if [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool
True | ((Int
s,String
lookahead),Action
Accept) <- ActionTable
actionTable, 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 []
            {- 4. Shift -}
            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) <- ActionTable
actionTable, 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
""
                                   CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
forall token ast.
(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 CompCandidates token ast
ccOption (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 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
""
      
                    CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> Stack token ast
-> [(Int, Stack token ast, String)]
-> IO [[Candidate]]
forall token ast.
(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 CompCandidates token ast
ccOption (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 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 [ ProdRules
productionRules 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 (ProdRules
productionRules 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
""
                   CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> 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) =>
CompCandidates token ast
-> Int
-> [Candidate]
-> p
-> [StkElem token ast]
-> [(Int, [StkElem token ast], String)]
-> Int
-> IO [[Candidate]]
compGammasDfsForReduce CompCandidates token ast
ccOption Int
level [Candidate]
symbols Int
state 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 :: CompCandidates token ast
-> Int
-> [Candidate]
-> p
-> [StkElem token ast]
-> [(Int, [StkElem token ast], String)]
-> Int
-> IO [[Candidate]]
compGammasDfsForReduce CompCandidates token ast
ccOption Int
level [Candidate]
symbols p
state [StkElem token ast]
stk [(Int, [StkElem token ast], String)]
history Int
prnum = 
  let flag :: Bool
flag = CompCandidates token ast -> Bool
forall token ast. CompCandidates token ast -> Bool
cc_debugFlag CompCandidates token ast
ccOption
      maxLevel :: Int
maxLevel = CompCandidates token ast -> Int
forall token ast. CompCandidates token ast -> Int
cc_searchMaxLevel CompCandidates token ast
ccOption
      isSimple :: Bool
isSimple = CompCandidates token ast -> Bool
forall token ast. CompCandidates token ast -> Bool
cc_simpleOrNested CompCandidates token ast
ccOption
      automaton :: Automaton token ast
automaton = CompCandidates token ast -> Automaton token ast
forall token ast. CompCandidates token ast -> Automaton token ast
cc_automaton CompCandidates token ast
ccOption
      
      actionTable :: ActionTable
actionTable = Automaton token ast -> ActionTable
forall token ast. Automaton token ast -> ActionTable
actTbl Automaton token ast
automaton
      gotoTable :: GotoTable
gotoTable = Automaton token ast -> GotoTable
forall token ast. Automaton token ast -> GotoTable
gotoTbl Automaton token ast
automaton
      productionRules :: ProdRules
productionRules = Automaton token ast -> ProdRules
forall token ast. Automaton token ast -> ProdRules
prodRules Automaton token ast
automaton
  in
  let prodrule :: (String, [String])
prodrule   = ProdRules
productionRules 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 GotoTable
gotoTable 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 <- CompCandidates token ast
-> Int
-> [Candidate]
-> Int
-> [StkElem token ast]
-> [(Int, [StkElem token ast], String)]
-> IO [[Candidate]]
forall token ast.
(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 CompCandidates token ast
ccOption (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [] Int
toState [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]

data HandleParseError token = HandleParseError {
    HandleParseError token -> Bool
debugFlag :: Bool,
    HandleParseError token -> Int
searchMaxLevel :: Int,
    HandleParseError token -> Bool
simpleOrNested :: Bool,
    HandleParseError token -> [Terminal token]
postTerminalList :: [Terminal token],
    HandleParseError token -> Maybe ShowS
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 :: HandleParseError token
-> ParseError token ast -> IO [EmacsDataItem]
handleParseError HandleParseError token
hpeOption ParseError token ast
parseError = HandleParseError token
-> ParseError token ast -> IO [EmacsDataItem]
forall token token ast.
TokenInterface token =>
HandleParseError token
-> ParseError token ast -> IO [EmacsDataItem]
unwrapParseError HandleParseError token
hpeOption ParseError token ast
parseError
  
unwrapParseError :: HandleParseError token
-> ParseError token ast -> IO [EmacsDataItem]
unwrapParseError HandleParseError token
hpeOption (NotFoundAction Terminal token
_ Int
state Stack token ast
stk ActionTable
_actTbl GotoTable
_gotoTbl ProdRules
_prodRules [Terminal token]
terminalList) = 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}
    HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
forall token ast token token.
(Typeable token, Typeable ast, Show token, Show ast,
 TokenInterface token, TokenInterface token,
 TokenInterface token) =>
HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
arrivedAtTheEndOfSymbol HandleParseError token
hpeOption Int
state Stack token ast
stk Automaton token ast
automaton [Terminal token]
terminalList
unwrapParseError HandleParseError token
hpeOption (NotFoundGoto Int
state String
_ Stack token ast
stk ActionTable
_actTbl GotoTable
_gotoTbl ProdRules
_prodRules [Terminal token]
terminalList) = 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}
    HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
forall token ast token token.
(Typeable token, Typeable ast, Show token, Show ast,
 TokenInterface token, TokenInterface token,
 TokenInterface token) =>
HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
arrivedAtTheEndOfSymbol HandleParseError token
hpeOption Int
state Stack token ast
stk Automaton token ast
automaton [Terminal token]
terminalList

arrivedAtTheEndOfSymbol :: HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> [Terminal token]
-> IO [EmacsDataItem]
arrivedAtTheEndOfSymbol HandleParseError token
hpeOption Int
state Stack token ast
stk Automaton token ast
automaton [Terminal token]
terminalList = do
  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 -- [$]
     HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> IO [EmacsDataItem]
forall token ast token.
(Typeable token, Typeable ast, Show token, Show ast,
 TokenInterface token, TokenInterface token) =>
HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> IO [EmacsDataItem]
_handleParseError HandleParseError token
hpeOption Int
state Stack token ast
stk Automaton token ast
automaton
  else do
     String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"length terminalList /= 1 : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Terminal token] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Terminal token]
terminalList)
     (Terminal token -> IO ()) -> [Terminal token] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Terminal token
t -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal token -> String
forall token. TokenInterface token => Terminal token -> String
terminalToString (Terminal token -> String) -> Terminal token -> String
forall a b. (a -> b) -> a -> b
$ Terminal token
t) [Terminal token]
terminalList
     [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 :: HandleParseError token
-> Int
-> Stack token ast
-> Automaton token ast
-> IO [EmacsDataItem]
_handleParseError
  (hpeOption :: HandleParseError token
hpeOption @ HandleParseError {
      debugFlag :: forall token. HandleParseError token -> Bool
debugFlag=Bool
flag,
      searchMaxLevel :: forall token. HandleParseError token -> Int
searchMaxLevel=Int
maxLevel,
      simpleOrNested :: forall token. HandleParseError token -> Bool
simpleOrNested=Bool
isSimple,
      postTerminalList :: forall token. HandleParseError token -> [Terminal token]
postTerminalList=[Terminal token]
terminalListAfterCursor,
      nonterminalToStringMaybe :: forall token. HandleParseError token -> Maybe ShowS
nonterminalToStringMaybe=Maybe ShowS
_nonterminalToStringMaybe})
  Int
state Stack token ast
stk Automaton token ast
automaton = do
  let ccOption :: CompCandidates token ast
ccOption = CompCandidates :: forall token ast.
Bool
-> Int -> Bool -> Automaton token ast -> CompCandidates token ast
CompCandidates {
        cc_debugFlag :: Bool
cc_debugFlag=Bool
flag,
        cc_searchMaxLevel :: Int
cc_searchMaxLevel=Int
maxLevel,
        cc_simpleOrNested :: Bool
cc_simpleOrNested=Bool
isSimple,
        cc_automaton :: Automaton token ast
cc_automaton=Automaton token ast
automaton }
  [[Candidate]]
candidateListList <- CompCandidates token ast
-> Int -> [Candidate] -> Int -> Stack token ast -> IO [[Candidate]]
forall token ast.
(TokenInterface token, Typeable token, Typeable ast, Show token,
 Show ast) =>
CompCandidates token ast
-> Int -> [Candidate] -> Int -> Stack token ast -> IO [[Candidate]]
compCandidates CompCandidates token ast
ccOption Int
0 [] Int
state Stack token ast
stk
  let colorListList_symbols :: [[EmacsColorCandidate]]
colorListList_symbols =
       [ [Candidate] -> [Terminal token] -> [EmacsColorCandidate]
forall token.
TokenInterface token =>
[Candidate] -> [Terminal token] -> [EmacsColorCandidate]
filterCandidates [Candidate]
candidateList [Terminal token]
terminalListAfterCursor
       | [Candidate]
candidateList <- [[Candidate]]
candidateListList ]
  let convFun :: ShowS
convFun =
        case Maybe ShowS
_nonterminalToStringMaybe of
          Maybe ShowS
Nothing -> \String
s -> String
"..."
          Just ShowS
fn -> ShowS
fn
  let colorListList_ :: [[EmacsColor]]
colorListList_ = ([EmacsColorCandidate] -> [EmacsColor])
-> [[EmacsColorCandidate]] -> [[EmacsColor]]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS -> [EmacsColorCandidate] -> [EmacsColor]
stringfyCandidates ShowS
convFun) [[EmacsColorCandidate]]
colorListList_symbols
  let colorListList :: [[EmacsColor]]
colorListList = ([EmacsColor] -> [EmacsColor]) -> [[EmacsColor]] -> [[EmacsColor]]
forall a b. (a -> b) -> [a] -> [b]
map [EmacsColor] -> [EmacsColor]
collapseCandidates [[EmacsColor]]
colorListList_
  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
showConcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([EmacsColorCandidate] -> String)
-> [[EmacsColorCandidate]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\[EmacsColorCandidate]
x -> ([EmacsColorCandidate] -> String
forall a. Show a => a -> String
show [EmacsColorCandidate]
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")) [[EmacsColorCandidate]]
colorListList_symbols
  Bool -> String -> IO ()
debug Bool
flag (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
showConcat ([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
  
  where
    showConcat :: [String] -> String
showConcat [] = String
""
    showConcat (String
s:[String]
ss) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
showConcat [String]
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 (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, EmacsColor -> EmacsColor -> Bool
(EmacsColor -> EmacsColor -> Bool)
-> (EmacsColor -> EmacsColor -> Bool) -> Eq EmacsColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmacsColor -> EmacsColor -> Bool
$c/= :: EmacsColor -> EmacsColor -> Bool
== :: EmacsColor -> EmacsColor -> Bool
$c== :: EmacsColor -> EmacsColor -> Bool
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 EmacsColorCandidate -> EmacsColorCandidate -> Bool
(EmacsColorCandidate -> EmacsColorCandidate -> Bool)
-> (EmacsColorCandidate -> EmacsColorCandidate -> Bool)
-> Eq EmacsColorCandidate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmacsColorCandidate -> EmacsColorCandidate -> Bool
$c/= :: EmacsColorCandidate -> EmacsColorCandidate -> Bool
== :: EmacsColorCandidate -> EmacsColorCandidate -> Bool
$c== :: EmacsColorCandidate -> EmacsColorCandidate -> Bool
Eq

instance Show EmacsColorCandidate where
  showsPrec :: Int -> EmacsColorCandidate -> ShowS
showsPrec Int
p (GrayCandidate Candidate
c Int
lin Int
col) = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"Gray " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Candidate -> String
forall a. Show a => a -> String
show Candidate
c
  showsPrec Int
p (WhiteCandidate Candidate
c) = String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"White " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Candidate -> String
forall a. Show a => a -> String
show Candidate
c

filterCandidates :: (TokenInterface token) => [Candidate] -> [Terminal token] -> [EmacsColorCandidate]
filterCandidates :: [Candidate] -> [Terminal token] -> [EmacsColorCandidate]
filterCandidates [Candidate]
candidates [Terminal token]
terminalListAfterCursor =
  [Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
forall token.
TokenInterface token =>
[Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f [Candidate]
candidates [Terminal token]
terminalListAfterCursor []
  where
    f :: [Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f (Candidate
a:[Candidate]
alpha) (Terminal token
b:[Terminal token]
beta) [EmacsColorCandidate]
accm
      | Candidate -> Terminal token -> Bool
forall token. Candidate -> Terminal token -> Bool
equal Candidate
a Terminal token
b       = [Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f [Candidate]
alpha [Terminal token]
beta     (Candidate -> Int -> Int -> EmacsColorCandidate
GrayCandidate 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) EmacsColorCandidate
-> [EmacsColorCandidate] -> [EmacsColorCandidate]
forall a. a -> [a] -> [a]
: [EmacsColorCandidate]
accm)
      | Bool
otherwise       = [Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f [Candidate]
alpha (Terminal token
bTerminal token -> [Terminal token] -> [Terminal token]
forall a. a -> [a] -> [a]
:[Terminal token]
beta) (Candidate -> EmacsColorCandidate
WhiteCandidate Candidate
a EmacsColorCandidate
-> [EmacsColorCandidate] -> [EmacsColorCandidate]
forall a. a -> [a] -> [a]
: [EmacsColorCandidate]
accm)
    f [] [Terminal token]
beta [EmacsColorCandidate]
accm      = [EmacsColorCandidate] -> [EmacsColorCandidate]
forall a. [a] -> [a]
reverse [EmacsColorCandidate]
accm
    f (Candidate
a:[Candidate]
alpha) [] [EmacsColorCandidate]
accm = [Candidate]
-> [Terminal token]
-> [EmacsColorCandidate]
-> [EmacsColorCandidate]
f [Candidate]
alpha [] (Candidate -> EmacsColorCandidate
WhiteCandidate Candidate
a EmacsColorCandidate
-> [EmacsColorCandidate] -> [EmacsColorCandidate]
forall a. a -> [a] -> [a]
: [EmacsColorCandidate]
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

stringfyCandidates :: (String -> String) -> [EmacsColorCandidate] -> [EmacsColor]
stringfyCandidates :: ShowS -> [EmacsColorCandidate] -> [EmacsColor]
stringfyCandidates ShowS
convFun [EmacsColorCandidate]
candidates = (EmacsColorCandidate -> EmacsColor)
-> [EmacsColorCandidate] -> [EmacsColor]
forall a b. (a -> b) -> [a] -> [b]
map EmacsColorCandidate -> EmacsColor
stringfyCandidate [EmacsColorCandidate]
candidates
  where
    stringfyCandidate :: EmacsColorCandidate -> EmacsColor
stringfyCandidate (GrayCandidate Candidate
sym Int
line Int
col) = String -> Int -> Int -> EmacsColor
Gray (Candidate -> String
strCandidate Candidate
sym) Int
line Int
col
    stringfyCandidate (WhiteCandidate Candidate
sym) = String -> EmacsColor
White (Candidate -> String
strCandidate Candidate
sym)

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

collapseCandidates :: [EmacsColor] -> [EmacsColor]
collapseCandidates [] = []
collapseCandidates [EmacsColor
a] = [EmacsColor
a]
collapseCandidates ((Gray String
"..." Int
l1 Int
c1) : (Gray String
"..." Int
l2 Int
c2) : [EmacsColor]
cs) =
  [EmacsColor] -> [EmacsColor]
collapseCandidates ((String -> Int -> Int -> EmacsColor
Gray String
"..." Int
l2 Int
c2) EmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
: [EmacsColor]
cs)
collapseCandidates ((White String
"...") : (White String
"...") : [EmacsColor]
cs) =
  [EmacsColor] -> [EmacsColor]
collapseCandidates ((String -> EmacsColor
White String
"...") EmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
: [EmacsColor]
cs)    
collapseCandidates (EmacsColor
a:EmacsColor
b:[EmacsColor]
cs) = EmacsColor
a EmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
: [EmacsColor] -> [EmacsColor]
collapseCandidates (EmacsColor
bEmacsColor -> [EmacsColor] -> [EmacsColor]
forall a. a -> [a] -> [a]
:[EmacsColor]
cs)

-- | 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)