SableCC2Hs-0.0.0.2: haskell/Parser2.hs

{-
prototype of a Haskell backend for LR-parser-tables generated by SableCC
this parser imports the tables with a generated Module.
-}
{-# LANGUAGE RecordWildCards,BangPatterns #-}
module Parser2
where
import SableCC.ParserTypes as Parser
import ParserTables as Tables

import Data.Array as Array
import Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe

-- The Parser

type Stack = [(ParserStateID,DAst)]
type Input = [PToken]
type PState = (Stack,Input)

runParser :: Input -> DAst
runParser input
  = head $ parserLoop ([(ParserStateID 0, error "dummy CST of initial parserStack")], input)

parserLoop :: PState -> [DAst]
parserLoop pState@(stack,input) = case findAction pState of
    Shift newState    -> case input of
         [] -> error "shift action with empty input"
         (h:rest) -> parserLoop ((newState, DLeaf h) : stack, rest)
    Reduce reduction  -> parserLoop $ performReduction reduction pState
    Accept            -> map snd stack
    Error msg         -> error (Tables.errorTable ! msg)

findAction :: (Stack,Input) -> Action
findAction s = case s of
  ([],_) -> error "findAction: empty Stack"
  (_,[]) -> error "findAction: empty Input"
  (((state,_):_),((tokenID,_):_)) -> do
    let list = Tables.actionTable ! state
    case Map.lookup tokenID $ transitionMap list of
      Nothing -> defaultTransition list
      Just r -> r

performReduction :: Reduction -> PState -> PState
performReduction Reduction {..} (stack,input)
  = ((newState,astNode) : restStack, input)
  where
    restStack = drop popCount stack
    cl = map snd $ take popCount stack
    ! astNode = (reduceTable ! reductionID) cl
    newState = lookupGotoList gotoIndex $ fst $ head restStack

lookupGotoList :: GotoIndex -> ParserStateID -> ParserStateID
lookupGotoList index state
  = case Map.lookup state $ gotoMap gMap of
    Nothing -> defaultGoto gMap
    Just r  -> r
  where gMap = Tables.gotoTable ! index

trimTokens :: [SToken] -> [Parser.PToken]
trimTokens tokens = mapMaybe f tokens ++ [parserEof]
  where
    parserEof = (ParserTokenID Tables.eofTokenID ,"")
    f (LexTokenID tokID, tokenString)
      = case Map.lookup tokID tokenIDMap of
           Nothing -> Nothing
           Just parserID -> Just (ParserTokenID parserID, tokenString)

--- The Lexer

runLexer :: String -> [SToken]
runLexer input
  = reverse $ lexerLoop (initLexerState input) []

lexerLoop :: LexerState -> [SToken] -> [SToken]
lexerLoop lexerState@LexerState {..} acc
  = case runDFA (snd $ Tables.lexerModes ! lexerMode) lexerBuffer of
    Right (newBuff, tokenString,tokenID) -> if null newBuff
        then acc
        else lexerLoop newState (sToken : acc)
      where
         !newNestingCounter = case tokenID of
           LexTokenID 1 -> pred commentNestingCounter
           LexTokenID 0 -> succ commentNestingCounter
           _             -> commentNestingCounter
         newMode = if tokenID == LexTokenID 1 && newNestingCounter == 0
                     then ModeID 0
                     else Tables.modeTransitions ! (tokenID, lexerMode)
         sToken = (tokenID, tokenString)
         newState = lexerState {
                lexerBuffer = newBuff
               ,lexerMode = newMode
               ,commentNestingCounter = newNestingCounter
               }
    Left err -> do
      error "lexError"

runDFA :: Mode -> String -> Either String (String,String,LexTokenID)
runDFA mode input
   = checkState
       (Left "noToken recognised")
       (modeStates mode ! LexStateID 0)
       input
       []
  where
    checkState ::
           Either String (String,String,LexTokenID)
        -> State -> String -> String
        -> Either String (String,String,LexTokenID)
    checkState lastAcceptedToken dfaState input acc
      = case (input, stateAcceptedToken dfaState) of
          ([],  Just tokenID)          -> Right ("",reverse acc, tokenID)
          ([],  Nothing)               -> lastAcceptedToken
          (_, Just tokenID)          -> scanChar (Right (input, reverse acc, tokenID)) dfaState input acc
          (_, Nothing)               -> scanChar lastAcceptedToken dfaState input acc
    scanChar ::
           Either String (String,String,LexTokenID)
        -> State -> String -> String
        -> Either String (String,String,LexTokenID)
    scanChar lastAcceptedToken dfaState [] acc = error "scanChar:unreachable"
    scanChar lastAcceptedToken dfaState input@(h:rest) acc
       = case lookupInterval h $ stateTransitions dfaState of
           Nothing -> lastAcceptedToken
           Just (Epsilon newStateID)
             -> scanChar lastAcceptedToken (modeStates mode ! newStateID) input acc
           Just (NotEpsilon newStateID)
             -> checkState lastAcceptedToken (modeStates mode ! newStateID) rest (h:acc)