platinum-parsing-0.1.0.0: src/PP/Parsers/Lr.hs

{-|
Module      : PP.Parsers.Lr
Description : LR parser
Copyright   : (c) 2017 Patrick Champion
License     : see LICENSE file
Maintainer  : chlablak@gmail.com
Stability   : provisional
Portability : portable
-}
module PP.Parsers.Lr
    ( LrConfig(..)
    , LrAst(..)
    , prettyAst
    ) where

import           PP.Builder (LrAction (..), LrTable (..), action, action')
import           PP.Lexer   (OToken (..))
import           PP.Parser  (LrParser (..))
import           PP.Rule    (Rule (..))

-- |Dynamic AST generated by the parser
data LrAst
  = LrAstRoot [LrAst]
  | LrAstTerm [OToken]
  | LrAstNonTerm String [LrAst]
    deriving (Eq, Show)

-- |Configuration for LR parser
data LrConfig = LrConfig
  { lrCount  :: Int        -- ^Counter
  , lrStack  :: [Int]      -- ^State stack
  , lrAction :: LrAction   -- ^Action to do
  , lrInput  :: [OToken]   -- ^Input
  , lrAst    :: LrAst      -- ^Parsed AST
  } deriving (Eq, Show)

-- Dragon Book (2nd edition, fr), page 230, algorithm 4.44
instance LrParser LrConfig where
  config t i = LrConfig 0 [0] (action' t 0 i) i (LrAstRoot [])
  next t (LrConfig c ss (LrShift s) (i:is) a) =
    LrConfig (c + 1) (s : ss) (action' t s is) is (shift a i)
  next t (LrConfig c ss (LrReduce (Rule r xs)) i a) =
    LrConfig (c + 1) sr (action t m $ NonTerm r) i (reduce a r $ length xs - 1)
    where
      sr@(m:_) = drop (length xs - 1) ss
  next t (LrConfig c ss (LrGoto s) i a) =
    LrConfig (c + 1) (s : ss) (action' t s i) i a
  next _ c = c
  hasNext _ (LrConfig _ _ LrError _ _)  = False
  hasNext _ (LrConfig _ _ LrAccept _ _) = False
  hasNext _ _                           = True

-- |Modify the AST by a Shift action
shift :: LrAst -> OToken -> LrAst
shift (LrAstRoot xs) i = LrAstRoot $ xs ++ [LrAstTerm [i]]

-- |Modify the AST by a Reduce action
reduce :: LrAst -> String -> Int -> LrAst
reduce (LrAstRoot xs) r l = LrAstRoot $ a ++ [LrAstNonTerm r b]
  where
    (a, b) = splitAt pos xs
    pos = length xs - l

-- |Pretty print the LrAst
prettyAst :: LrAst -> String
prettyAst (LrAstRoot a) = concatMap (prettyAst' 0) a
  where
    prettyAst' d (LrAstTerm t) = tab d ++ show t ++ "\n"
    prettyAst' d (LrAstNonTerm r xs) =
      tab d ++ r ++ "\n" ++ concatMap (prettyAst' $ d + 2) xs
    tab d = replicate d ' ' ++ "|"