packages feed

yapb 0.1.3 → 0.1.3.1

raw patch · 3 files changed

+228/−82 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

+ CommonParserUtil: AutomatonSpec :: ActionTable -> GotoTable -> ProdRules -> ParseFunList token ast -> Int -> AutomatonSpec token ast
+ CommonParserUtil: HandleParseError :: Bool -> Int -> Bool -> [Terminal token] -> Maybe (String -> String) -> HandleParseError token
+ CommonParserUtil: [am_actionTbl] :: AutomatonSpec token ast -> ActionTable
+ CommonParserUtil: [am_gotoTbl] :: AutomatonSpec token ast -> GotoTable
+ CommonParserUtil: [am_initState] :: AutomatonSpec token ast -> Int
+ CommonParserUtil: [am_parseFuns] :: AutomatonSpec token ast -> ParseFunList token ast
+ CommonParserUtil: [am_prodRules] :: AutomatonSpec token ast -> ProdRules
+ CommonParserUtil: [debugFlag] :: HandleParseError token -> Bool
+ CommonParserUtil: [nonterminalToStringMaybe] :: HandleParseError token -> Maybe (String -> String)
+ CommonParserUtil: [postTerminalList] :: HandleParseError token -> [Terminal token]
+ CommonParserUtil: [searchMaxLevel] :: HandleParseError token -> Int
+ CommonParserUtil: [simpleOrNested] :: HandleParseError token -> Bool
+ CommonParserUtil: data AutomatonSpec token ast
+ CommonParserUtil: data HandleParseError token
+ CommonParserUtil: instance GHC.Classes.Eq CommonParserUtil.EmacsColor
+ CommonParserUtil: instance GHC.Classes.Eq CommonParserUtil.EmacsColorCandidate
+ CommonParserUtil: instance GHC.Show.Show CommonParserUtil.EmacsColorCandidate
+ CommonParserUtil: parsingHaskell :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => Bool -> ParserSpec token ast -> [Terminal token] -> Maybe token -> IO ast
+ CommonParserUtil: runAutomatonHaskell :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => Bool -> AutomatonSpec token ast -> [Terminal token] -> Maybe token -> IO ast
- CommonParserUtil: handleParseError :: TokenInterface token => Bool -> Int -> Bool -> [Terminal token] -> ParseError token ast -> IO [EmacsDataItem]
+ CommonParserUtil: handleParseError :: TokenInterface token => HandleParseError token -> ParseError token ast -> IO [EmacsDataItem]
- CommonParserUtil: runAutomaton :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => Bool -> Int -> ActionTable -> GotoTable -> ProdRules -> ParseFunList token ast -> [Terminal token] -> IO ast
+ CommonParserUtil: runAutomaton :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) => Bool -> AutomatonSpec token ast -> [Terminal token] -> IO ast

Files

app/syntaxcompletion/SyntaxCompletion.hs view
@@ -39,6 +39,13 @@           {- 3. Lexing the rest and computing candidates with it -}           do (_, _, terminalListAfterCursor) <-                lexingWithLineColumn lexerSpec line column programTextAfterCursor-             handleParseError debug maxLevel isSimpleMode terminalListAfterCursor parseError))+             handleParseError+               (HandleParseError {+                   debugFlag=debug,+                   searchMaxLevel=maxLevel,+                   simpleOrNested=isSimpleMode,+                   postTerminalList=terminalListAfterCursor,+                   nonterminalToStringMaybe=Nothing})+               parseError))    `catch` \lexError ->  case lexError :: LexError of  _ -> handleLexError
src/parserlib/CommonParserUtil.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} module CommonParserUtil-  ( LexerSpec(..), ParserSpec(..)-  , lexing, lexingWithLineColumn, parsing, runAutomaton+  ( LexerSpec(..), ParserSpec(..), AutomatonSpec(..), HandleParseError(..)+  , lexing, lexingWithLineColumn, parsing, runAutomaton, parsingHaskell, runAutomatonHaskell   , get, getText   , LexError(..), ParseError(..)   , successfullyParsed, handleLexError, handleParseError) where@@ -178,9 +178,12 @@ --      ++ prStack stack ++ "\n"  ---parsing :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>-           Bool -> ParserSpec token ast -> [Terminal token] -> IO ast-parsing flag parserSpec terminalList = do+parsing flag parserSpec terminalList =+  parsingHaskell flag parserSpec terminalList Nothing+  +parsingHaskell :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+           Bool -> ParserSpec token ast -> [Terminal token] -> Maybe token -> IO ast+parsingHaskell flag parserSpec terminalList haskellOption = do   -- 1. Save the production rules in the parser spec (Parser.hs).   writtenBool <- saveProdRules specFileName sSym pSpecList @@ -199,7 +202,14 @@             putStrLn $ "Delete " ++ hashFile             removeIfExists hashFile             error $ "Error: Empty automation: please rerun"-    else do ast <- runAutomaton flag initState actionTbl gotoTbl prodRules pFunList terminalList+    else do ast <- runAutomatonHaskell flag+                     (AutomatonSpec {+                       am_initState=initState,+                       am_actionTbl=actionTbl,+                       am_gotoTbl=gotoTbl,+                       am_prodRules=prodRules,+                       am_parseFuns=pFunList })+                     terminalList haskellOption             -- putStrLn "done." -- It was for the interafce with Java-version RPC calculus interpreter.             return ast @@ -314,19 +324,39 @@  -- Automaton +data AutomatonSpec token ast =+  AutomatonSpec {+    am_actionTbl :: ActionTable,+    am_gotoTbl :: GotoTable,+    am_prodRules :: ProdRules,+    am_parseFuns :: ParseFunList token ast,+    am_initState :: Int+  }+ initState = 0  type ParseFunList token ast = [ParseFun token ast] -runAutomaton :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>-  Bool -> Int -> -  {- static part -}-  ActionTable -> GotoTable -> ProdRules -> ParseFunList token ast -> +runAutomaton flag amSpec terminalList =+  runAutomatonHaskell flag amSpec {- initState actionTbl gotoTbl prodRules pFunList-} terminalList Nothing++runAutomatonHaskell :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>+  Bool -> +  {- static part ActionTable -> GotoTable -> ProdRules -> ParseFunList token ast -> -}+  AutomatonSpec token ast ->    {- dynamic part -}   [Terminal token] ->+  {- haskell parser specific option -}+  Maybe token ->   {- AST -}   IO ast-runAutomaton flag initState actionTbl gotoTbl prodRules pFunList terminalList = do+runAutomatonHaskell flag (rm_spec @ AutomatonSpec {+      am_initState=initState,+      am_actionTbl=actionTbl,+      am_gotoTbl=gotoTbl,+      am_prodRules=prodRules,+      am_parseFuns=pFunList+   }) terminalList haskellOption = do   let initStack = push (StkState initState) emptyStack   run terminalList initStack   @@ -335,24 +365,44 @@     run terminalList stack = do       let state = currentState stack       let terminal = head terminalList-      let text  = tokenTextFromTerminal terminal-      let action =-           case lookupActionTable actionTbl state terminal of-             Just action -> action-             Nothing -> throw (NotFoundAction terminal state stack actionTbl gotoTbl prodRules terminalList)-                        -- error $ ("Not found in the action table: "-                        --          ++ terminalToString terminal)-                        --          ++ " : "-                        --          ++ show (state, tokenTextFromTerminal terminal)-                        --          ++ "\n" ++ prStack stack ++ "\n"-      +      case lookupActionTable actionTbl state terminal of+        Just action -> do+          -- putStrLn $ terminalToString terminal {- debug -}+          runAction state terminal action terminalList stack+          +        Nothing -> do+          putStrLn $ "lookActionTable failed (1st) with: " ++ show (terminalToString terminal)+          case haskellOption of+            Just extraToken -> do+              let terminal_close_brace = Terminal+                                          (fromToken extraToken)+                                            (terminalToLine terminal)+                                              (terminalToCol terminal)+                                                (Just extraToken)+              case lookupActionTable actionTbl state terminal_close_brace of+                Just action -> do+                  -- putStrLn $ terminalToString terminal_close_brace {- debug -}+                  putStrLn $ "lookActionTable succeeded (2nd) with: " ++ terminalToString terminal_close_brace+                  runAction state terminal_close_brace action (terminal_close_brace : terminalList) stack+                  +                Nothing -> do+                  putStrLn $ "lookActionTable failed (2nd) with: " ++ terminalToString terminal_close_brace+                  throw (NotFoundAction terminal state stack actionTbl gotoTbl prodRules terminalList)+                -- Nothing -> throw (NotFoundAction terminal_close_brace state stack actionTbl gotoTbl prodRules+                --                    (terminal_close_brace : terminalList))+                           +            Nothing -> throw (NotFoundAction terminal state stack actionTbl gotoTbl prodRules terminalList)++    -- separated to support the haskell layout rule+    runAction state terminal action terminalList stack = do             debug flag ("\nState " ++ show state)-      debug flag ("Token " ++ text)+      debug flag ("Token " ++ tokenTextFromTerminal terminal)       debug flag ("Stack " ++ prStack stack)              case action of         Accept -> do           debug flag "Accept"+          putStrLn $ terminalToString terminal {- debug -}                      case stack !! 1 of             StkNonterminal (Just ast) _ -> return ast@@ -361,6 +411,7 @@                  Shift toState -> do           debug flag ("Shift " ++ show toState)+          putStrLn $ terminalToString terminal {- debug -}                      let stack1 = push (StkTerminal (head terminalList)) stack           let stack2 = push (StkState toState) stack1@@ -384,10 +435,6 @@                case lookupGotoTable gotoTbl topState lhs of                  Just state -> state                  Nothing -> throw (NotFoundGoto topState lhs stack actionTbl gotoTbl prodRules terminalList)-                            -- error $ ("Not found in the goto table: ")-                            --         ++ " : "-                            --         ++ show (topState,lhs) ++ "\n"-                            --         ++ prStack stack ++ "\n"              let stack2 = push (StkNonterminal (Just ast) lhs) stack1           let stack3 = push (StkState toState) stack2@@ -403,29 +450,37 @@ data Candidate =     -- Todo: data Candidate vs. data EmacsDataItem = ... | Candidate String      TerminalSymbol String   | NonterminalSymbol String-  deriving (Show,Eq)+  deriving Eq +instance Show Candidate where+  showsPrec p (TerminalSymbol s) = (++) $ "Terminal " ++ s+  showsPrec p (NonterminalSymbol s) = (++) $ "Nonterminal " ++ s+ data Automaton token ast =   Automaton {     actTbl    :: ActionTable,     gotoTbl   :: GotoTable,     prodRules :: ProdRules   }++data CompCandidates token ast = CompCandidates {+    cc_debugFlag :: Bool,+    cc_searchMaxLevel :: Int,+    cc_simpleOrNested :: Bool,+    cc_automaton :: Automaton token ast+  }    compCandidates   :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>-     Bool      -- debug-     -> Int    -- maximum search depth level-     -> Bool   -- simple or nested+     CompCandidates token ast      -> Int      -> [Candidate]      -> Int-     -> Automaton token ast      -> Stack token ast      -> IO [[Candidate]] -compCandidates flag maxLevel isSimple level symbols state automaton stk = do-  compGammasDfs flag maxLevel isSimple level symbols state automaton stk []+compCandidates ccOption level symbols state stk = do+  compGammasDfs ccOption level symbols state stk [] --  gammas <- compGammasDfs isSimple level symbols state automaton stk [] --  if isSimple --  then return gammas@@ -433,31 +488,41 @@  compGammasDfs   :: (TokenInterface token, Typeable token, Typeable ast, Show token, Show ast) =>-     Bool-     -> Int-     -> Bool+     CompCandidates token ast      -> Int      -> [Candidate]      -> Int-     -> Automaton token ast      -> Stack token ast      -> [(Int, Stack token ast, String)]      -> IO [[Candidate]] -compGammasDfs flag maxLevel isSimple level symbols state automaton stk history =+compGammasDfs ccOption level symbols state stk history =+  let flag = cc_debugFlag ccOption+      maxLevel = cc_searchMaxLevel ccOption+      isSimple = cc_simpleOrNested ccOption+      automaton = cc_automaton ccOption+      +      actionTable = actTbl automaton+      gotoTable = gotoTbl automaton+      productionRules = prodRules automaton+  in   if level > maxLevel then     return (if null symbols then [] else [symbols])   else   checkCycle flag False level state stk "" history-   (\history -> -     case nub [prnum | ((s,lookahead),Reduce prnum) <- actTbl automaton, state==s] of+   (\history ->+     {- 1. Reduce -}+     case nub [prnum | ((s,lookahead),Reduce prnum) <- actionTable, state==s] of       [] ->-        case nub [(nonterminal,toState) | ((fromState,nonterminal),toState) <- gotoTbl automaton, state==fromState] of+        {- 2. Goto table -}+        case nub [(nonterminal,toState) | ((fromState,nonterminal),toState) <- gotoTable, state==fromState] of           [] ->-            if length [True | ((s,lookahead),Accept) <- actTbl automaton, state==s] >= 1+            {- 3. Accept -}+            if length [True | ((s,lookahead),Accept) <- actionTable, state==s] >= 1             then do                     return []-            else let cand2 = nub [(terminal,snext) | ((s,terminal),Shift snext) <- actTbl automaton, state==s] in+            {- 4. Shift -}+            else let cand2 = nub [(terminal,snext) | ((s,terminal),Shift snext) <- actionTable, state==s] in                  let len = length cand2 in                  case cand2 of                   [] -> return []@@ -477,7 +542,7 @@                                    debug flag $ prlevel level ++ "Goto/Shift symbols: " ++ show (symbols++[TerminalSymbol terminal])                                    debug flag $ prlevel level ++ "Stack " ++ prStack stk2                                    debug flag $ ""-                                   compGammasDfs flag maxLevel isSimple (level+1) (symbols++[TerminalSymbol terminal]) snext automaton stk2 history1) )+                                   compGammasDfs ccOption (level+1) (symbols++[TerminalSymbol terminal]) snext stk2 history1) )                                      (zip cand2 [1..])                            return $ concat listOfList           nontermStateList -> do@@ -499,7 +564,7 @@                     debug flag $ prlevel level ++ "Stack " ++ prStack stk2                     debug flag $ ""       -                    compGammasDfs flag maxLevel isSimple (level+1) (symbols++[NonterminalSymbol nonterminal]) snext automaton stk2 history1) )+                    compGammasDfs ccOption (level+1) (symbols++[NonterminalSymbol nonterminal]) snext stk2 history1) )                       (zip nontermStateList [1..])             return $ concat listOfList @@ -507,7 +572,7 @@         let len = length prnumList               debug flag $ prlevel level     ++ "# of prNumList to reduce: " ++ show len ++ " at State " ++ show state-        debug flag $ prlevel (level+1) ++ show [ (prodRules automaton) !! prnum | prnum <- prnumList ]+        debug flag $ prlevel (level+1) ++ show [ productionRules !! prnum | prnum <- prnumList ]               -- let aCandidate = if null symbols then [] else [symbols]         -- if isSimple@@ -520,16 +585,25 @@                 (\history1 -> do                    debug flag $ prlevel level ++ "State " ++ show state  ++ "[" ++ show i ++ "/" ++ show len ++ "]"                     debug flag $ prlevel level ++ "REDUCE" ++ " prod #" ++ show prnum-                   debug flag $ prlevel level ++ show ((prodRules automaton) !! prnum)+                   debug flag $ prlevel level ++ show (productionRules !! prnum)                    debug flag $ prlevel level ++ "Goto/Shift symbols: " ++ show symbols                    debug flag $ prlevel level ++ "Stack " ++ prStack stk                    debug flag $ ""-                   compGammasDfsForReduce flag maxLevel level isSimple  symbols state automaton stk history1 prnum)) )+                   compGammasDfsForReduce ccOption level symbols state stk history1 prnum)) )                  (zip prnumList [1..])            return $ concat listOfList )   -compGammasDfsForReduce flag maxLevel level isSimple  symbols state automaton stk history prnum = -  let prodrule   = (prodRules automaton) !! prnum+compGammasDfsForReduce ccOption level symbols state stk history prnum = +  let flag = cc_debugFlag ccOption+      maxLevel = cc_searchMaxLevel ccOption+      isSimple = cc_simpleOrNested ccOption+      automaton = cc_automaton ccOption+      +      actionTable = actTbl automaton+      gotoTable = gotoTbl automaton+      productionRules = prodRules automaton+  in+  let prodrule   = productionRules !! prnum       lhs = fst prodrule       rhs = snd prodrule       @@ -537,7 +611,8 @@   in    if ( {- rhsLength == 0 || -} (rhsLength > length symbols) ) == False   then do-    debug flag $ prlevel level ++ "[LEN COND: False] length rhs > length symbols: NOT " ++ show rhsLength ++ ">" ++ show (length symbols)+    debug flag $ prlevel level ++ "[LEN COND: False] length rhs > length symbols: NOT "+                   ++ show rhsLength ++ ">" ++ show (length symbols)     debug flag $ prlevel (level+1) ++ show symbols     debug flag $ prlevel level     return [] -- Todo: (if null symbols then [] else [symbols])@@ -545,12 +620,14 @@     let stk1 = drop (rhsLength*2) stk     let topState = currentState stk1     let toState =-         case lookupGotoTable (gotoTbl automaton) topState lhs of+         case lookupGotoTable gotoTable topState lhs of            Just state -> state-           Nothing -> error $ "[compGammasDfsForReduce] Must not happen: lhs: " ++ lhs ++ " state: " ++ show topState+           Nothing -> error $ "[compGammasDfsForReduce] Must not happen: lhs: "+                                ++ lhs ++ " state: " ++ show topState     let stk2 = push (StkNonterminal Nothing lhs) stk1  -- ast     let stk3 = push (StkState toState) stk2-    debug flag $ prlevel level ++ "GOTO after REDUCE: " ++ show topState ++ " " ++ lhs ++ " " ++ show toState+    debug flag $ prlevel level ++ "GOTO after REDUCE: "+                   ++ show topState ++ " " ++ lhs ++ " " ++ show toState     debug flag $ prlevel level ++ "Goto/Shift symbols: " ++ "[]"     debug flag $ prlevel level ++ "Stack " ++ prStack stk3     debug flag $ ""@@ -560,7 +637,7 @@      if isSimple     then return (if null symbols then [] else [symbols])-    else do listOfList <- compGammasDfs flag maxLevel isSimple (level+1) [] toState automaton stk3 history+    else do listOfList <- compGammasDfs ccOption (level+1) [] toState stk3 history             return (if null symbols then listOfList else (symbols : map (symbols ++) listOfList))  -- | Cycle checking@@ -587,53 +664,115 @@ handleLexError :: IO [EmacsDataItem] handleLexError = return [SynCompInterface.LexError] +data HandleParseError token = HandleParseError {+    debugFlag :: Bool,+    searchMaxLevel :: Int,+    simpleOrNested :: Bool,+    postTerminalList :: [Terminal token],+    nonterminalToStringMaybe :: Maybe (String->String)+  }+ -- | handleParseError-handleParseError :: TokenInterface token => Bool -> Int -> Bool -> [Terminal token] -> ParseError token ast -> IO [EmacsDataItem]-handleParseError flag maxLevel isSimple terminalListAfterCursor parseError =-  unwrapParseError flag maxLevel isSimple terminalListAfterCursor parseError+-- handleParseError :: TokenInterface token => Bool -> Int -> Bool -> [Terminal token] -> ParseError token ast -> IO [EmacsDataItem]+-- handleParseError flag maxLevel isSimple terminalListAfterCursor parseError =+--   unwrapParseError flag maxLevel isSimple terminalListAfterCursor parseError   -unwrapParseError flag maxLevel isSimple terminalListAfterCursor (NotFoundAction _ state stk actTbl gotoTbl prodRules terminalList) =-  arrivedAtTheEndOfSymbol flag maxLevel isSimple terminalListAfterCursor state stk actTbl gotoTbl prodRules terminalList-unwrapParseError flag maxLevel isSimple terminalListAfterCursor (NotFoundGoto state _ stk actTbl gotoTbl prodRules terminalList) =-  arrivedAtTheEndOfSymbol flag maxLevel isSimple terminalListAfterCursor state stk actTbl gotoTbl prodRules terminalList+handleParseError :: TokenInterface token => HandleParseError token -> ParseError token ast -> IO [EmacsDataItem]+handleParseError hpeOption parseError = unwrapParseError hpeOption parseError+  +unwrapParseError hpeOption (NotFoundAction _ state stk _actTbl _gotoTbl _prodRules terminalList) = do+    let automaton = Automaton {actTbl=_actTbl, gotoTbl=_gotoTbl, prodRules=_prodRules}+    arrivedAtTheEndOfSymbol hpeOption state stk automaton terminalList+unwrapParseError hpeOption (NotFoundGoto state _ stk _actTbl _gotoTbl _prodRules terminalList) = do+    let automaton = Automaton {actTbl=_actTbl, gotoTbl=_gotoTbl, prodRules=_prodRules}+    arrivedAtTheEndOfSymbol hpeOption state stk automaton terminalList -arrivedAtTheEndOfSymbol flag maxLevel isSimple terminalListAfterCursor state stk _actTbl _gotoTbl _prodRules terminalList =+arrivedAtTheEndOfSymbol hpeOption state stk automaton terminalList = do   if length terminalList == 1 then do -- [$]-     _handleParseError flag maxLevel isSimple terminalListAfterCursor state stk _actTbl _gotoTbl _prodRules-  else+     _handleParseError hpeOption state stk automaton+  else do+     putStrLn $ "length terminalList /= 1 : " ++ show (length terminalList)+     mapM_ (\t -> putStrLn $ terminalToString $ t) terminalList      return [SynCompInterface.ParseError (map terminalToString terminalList)] -_handleParseError flag maxLevel isSimple terminalListAfterCursor state stk _actTbl _gotoTbl _prodRules = do-  let automaton = Automaton {actTbl=_actTbl, gotoTbl=_gotoTbl, prodRules=_prodRules}-  candidateListList <- compCandidates flag maxLevel isSimple 0 [] state automaton stk-  let colorListList =-       [ filterCandidates candidateList terminalListAfterCursor | candidateList <- candidateListList ]+_handleParseError+  (hpeOption @ HandleParseError {+      debugFlag=flag,+      searchMaxLevel=maxLevel,+      simpleOrNested=isSimple,+      postTerminalList=terminalListAfterCursor,+      nonterminalToStringMaybe=_nonterminalToStringMaybe})+  state stk automaton = do+  let ccOption = CompCandidates {+        cc_debugFlag=flag,+        cc_searchMaxLevel=maxLevel,+        cc_simpleOrNested=isSimple,+        cc_automaton=automaton }+  candidateListList <- compCandidates ccOption 0 [] state stk+  let colorListList_symbols =+       [ filterCandidates candidateList terminalListAfterCursor+       | candidateList <- candidateListList ]+  let convFun =+        case _nonterminalToStringMaybe of+          Nothing -> \s -> "..."+          Just fn -> fn+  let colorListList_ = map (stringfyCandidates convFun) colorListList_symbols+  let colorListList = map collapseCandidates colorListList_   let strList = nub [ concatStrList strList | strList <- map (map showEmacsColor) colorListList ]   let rawStrListList = nub [ strList | strList <- map (map showRawEmacsColor) colorListList ]-  debug flag $ show $ map (\x -> (show x ++ "\n")) rawStrListList -- mapM_ (putStrLn . show) rawStrListList+  debug flag $ showConcat $ map (\x -> (show x ++ "\n")) colorListList_symbols+  debug flag $ showConcat $ map (\x -> (show x ++ "\n")) rawStrListList -- mapM_ (putStrLn . show) rawStrListList   return $ map Candidate strList-+  +  where+    showConcat [] = ""+    showConcat (s:ss) = s ++ " " ++ showConcat ss+     -- | Filter the given candidates with the following texts data EmacsColor =     Gray  String Line Column -- Overlapping with some in the following text   | White String             -- Not overlapping-  deriving Show+  deriving (Show, Eq) -filterCandidates :: (TokenInterface token) => [Candidate] -> [Terminal token] -> [EmacsColor]+-- for debugging EmacsColor in terms of symbols before they are stringfied+data EmacsColorCandidate =+    GrayCandidate  Candidate Line Column -- Overlapping with some in the following text+  | WhiteCandidate Candidate             -- Not overlapping+  deriving Eq++instance Show EmacsColorCandidate where+  showsPrec p (GrayCandidate c lin col) = (++) $ "Gray " ++ show c+  showsPrec p (WhiteCandidate c) = (++) $ "White " ++ show c++filterCandidates :: (TokenInterface token) => [Candidate] -> [Terminal token] -> [EmacsColorCandidate] filterCandidates candidates terminalListAfterCursor =   f candidates terminalListAfterCursor []   where     f (a:alpha) (b:beta) accm-      | equal a b       = f alpha beta     (Gray (strCandidate a) (terminalToLine b) (terminalToCol b) : accm)-      | otherwise       = f alpha (b:beta) (White (strCandidate a) : accm)+      | equal a b       = f alpha beta     (GrayCandidate a (terminalToLine b) (terminalToCol b) : accm)+      | otherwise       = f alpha (b:beta) (WhiteCandidate a : accm)     f [] beta accm      = reverse accm-    f (a:alpha) [] accm = f alpha [] (White (strCandidate a) : accm)+    f (a:alpha) [] accm = f alpha [] (WhiteCandidate a : accm)      equal (TerminalSymbol s1)    (Terminal s2 _ _ _) = s1==s2     equal (NonterminalSymbol s1) _                   = False +stringfyCandidates :: (String -> String) -> [EmacsColorCandidate] -> [EmacsColor]+stringfyCandidates convFun candidates = map stringfyCandidate candidates+  where+    stringfyCandidate (GrayCandidate sym line col) = Gray (strCandidate sym) line col+    stringfyCandidate (WhiteCandidate sym) = White (strCandidate sym)+     strCandidate (TerminalSymbol s) = s-    strCandidate (NonterminalSymbol s) = "..."+    strCandidate (NonterminalSymbol s) = convFun s -- "..." -- ++ s ++ "..."++collapseCandidates [] = []+collapseCandidates [a] = [a]+collapseCandidates ((Gray "..." l1 c1) : (Gray "..." l2 c2) : cs) =+  collapseCandidates ((Gray "..." l2 c2) : cs)+collapseCandidates ((White "...") : (White "...") : cs) =+  collapseCandidates ((White "...") : cs)    +collapseCandidates (a:b:cs) = a : collapseCandidates (b:cs)  -- | Utilities showSymbol (TerminalSymbol s) = s
yapb.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 859129ea79d8fa58a86693919544d22f7730f727ef3cc4358ce3f31c25db35fb+-- hash: 16df070449e5bdf4422c57c84ee5baa14a57cd1c98ab276c87e1e250f47fe403  name:           yapb-version:        0.1.3+version:        0.1.3.1 synopsis:       Yet Another Parser Builder (YAPB) description:    A programmable LALR(1) parser builder system. Please see the README on GitHub at <https://github.com/kwanghoon/yapb#readme> category:       parser builder