module DDC.Base.Parser
( module Text.Parsec
, Parser
, ParserState (..)
, runTokenParser
, pTokMaybe
, pTokAs
, pTok)
where
import DDC.Base.Lexer
import DDC.Base.Pretty
import Data.Functor.Identity
import Text.Parsec
import Text.Parsec as P
import Text.Parsec.Error as P
type Parser k a
= Eq k
=> P.ParsecT [Token k] (ParserState k) Identity a
data ParserState k
= ParseState
{ stateTokenShow :: k -> String
, stateFileName :: String }
runTokenParser
:: Eq k
=> (k -> String)
-> String
-> Parser k a
-> [Token k]
-> Either P.ParseError a
runTokenParser tokenShow fileName parser
= P.runParser parser
ParseState
{ stateTokenShow = tokenShow
, stateFileName = fileName }
fileName
pTok :: Eq k => k -> Parser k ()
pTok k = pTokMaybe $ \k' -> if k == k' then Just () else Nothing
pTokAs :: Eq k => k -> t -> Parser k t
pTokAs k t = pTok k >> return t
pTokMaybe :: (k -> Maybe a) -> Parser k a
pTokMaybe f
= do state <- P.getState
P.token (stateTokenShow state . tokenTok)
(takeParsecSourcePos)
(f . tokenTok)
instance Pretty P.ParseError where
ppr err
= vcat $ [ text "Parse error in" <+> text (show (P.errorPos err)) ]
++ (map ppr $ packMessages $ P.errorMessages err)
instance Pretty P.Message where
ppr msg
= case msg of
SysUnExpect str -> text "Unexpected" <+> text str <> text "."
UnExpect str -> text "Unexpected" <+> text str <> text "."
Expect str -> text "Expected" <+> text str <> text "."
Message str -> text str
packMessages :: [P.Message] -> [P.Message]
packMessages mm
= case mm of
[] -> []
m1@(P.UnExpect _) : (P.UnExpect _) : rest
-> packMessages (m1 : rest)
m1@(P.SysUnExpect _) : (P.SysUnExpect _) : rest
-> packMessages (m1 : rest)
m1@(P.SysUnExpect _) : (P.UnExpect _) : rest
-> packMessages (m1 : rest)
m1@(P.UnExpect _) : (P.SysUnExpect _) : rest
-> packMessages (m1 : rest)
m1 : rest
-> m1 : packMessages rest