content: {-# LANGUAGE TypeFamilies #-}
  -- | Parser utilities.
  module DDC.Control.Parser
          ( module Text.Parsec
          , Parser
          , ParserState   (..)
          , D.SourcePos   (..)
          , runTokenParser
          , pTokMaybe,    pTokMaybeSP
          , pTokAs,       pTokAsSP
          , pTok,         pTokSP)
  where
  import DDC.Data.Pretty
  import DDC.Data.SourcePos               as D
  import Data.Functor.Identity
  import Text.Parsec                      hiding (string, char, SourcePos(..))
  import qualified Text.Parsec            as P
  import qualified Text.Parsec.Error      as P
  
  -- | A generic parser,
  --   parameterised over token and return types.
  type Parser k a
          =  Eq k
          => P.ParsecT [Located k] (ParserState k) Identity a
  
  
  -- | A parser state that keeps track of the name of the source file.
  data ParserState k
          = ParseState
          { stateTokenShow        :: k -> String
          , stateFileName         :: String }
  
  
  -- | Run a generic parser, making sure all input is consumed.
  runTokenParser
          :: Eq k
          => (k -> String)        -- ^ Show a token.
          -> String               -- ^ File name for error messages.
          -> Parser k a           -- ^ Parser to run.
          -> [Located k]          -- ^ Tokens to parse.
          -> Either P.ParseError a
  
  runTokenParser tokenShow fileName parser
   = P.runParser eofParser
          ParseState
          { stateTokenShow        = tokenShow
          , stateFileName         = fileName }
          fileName
   where
    eofParser
     = do r <- parser
          -- We can't use primitive Text.Parsec.eof because it requires
          -- @Show (Token k)@
          (do
                  c <- pTokMaybe Just
                  P.unexpected (tokenShow c)) P.<|> return r
  
  
  -------------------------------------------------------------------------------
  -- | Accept the given token.
  pTok   :: k -> Parser k ()
  pTok k  = pTokMaybe $ \k' -> if k == k' then Just () else Nothing
  
  
  -- | Accept the given token, returning its source position.
  pTokSP :: k -> Parser k D.SourcePos
  pTokSP k
   = do   (_, sp) <- pTokMaybeSP
                  $ \k' -> if k == k' then Just () else Nothing
          return sp
  
  
  -- | Accept a token and return the given value.
  pTokAs :: k -> t -> Parser k t
  pTokAs k t
   = do   pTok k
          return t
  
  
  -- | Accept a token and return the given value,
  --   along with the source position of the token.
  pTokAsSP :: k -> t -> Parser k (t, D.SourcePos)
  pTokAsSP k t
   = do   sp      <- pTokSP k
          return  (t, sp)
  
  
  -- | Accept a token if the function returns `Just`.
  pTokMaybe :: (k -> Maybe a) -> Parser k a
  pTokMaybe f
   = do   state   <- P.getState
  
          P.token (stateTokenShow state . valueOfLocated)
                  (parsecSourcePosOfLocated)
                  (f . valueOfLocated)
  
  
  -- | Accept a token if the function return `Just`,
  --   also returning the source position of that token.
  pTokMaybeSP  :: (k -> Maybe a) -> Parser k (a, D.SourcePos)
  pTokMaybeSP f
   = do   state   <- P.getState
  
          let f' token'
                  = case f (valueOfLocated token') of
                          Nothing -> Nothing
                          Just x  -> Just (x, sourcePosOfLocated token')
  
          P.token (stateTokenShow state . valueOfLocated)
                  (parsecSourcePosOfLocated)
                  f'
  
  
  -------------------------------------------------------------------------------
  instance Pretty P.ParseError where
   data PrettyMode P.ParseError   = PrettyParseError
   pprDefaultMode                 = PrettyParseError
   ppr err
    = vcat $  [  text "Parse error in" %% string (show (P.errorPos err)) ]
           ++ (map ppr $ packMessages $ P.errorMessages err)
  
  
  instance Pretty P.Message where
   data PrettyMode P.Message      = PrettyMessage
   pprDefaultMode                 = PrettyMessage
   ppr msg
    = case msg of
          P.SysUnExpect str -> string "Unexpected" %% string str % char '.'
          P.UnExpect    str -> string "Unexpected" %% string str % char '.'
          P.Expect      str -> string "Expected"   %% string str % char '.'
          P.Message     str -> string str
  
  
  -- | When we get a parse error, parsec adds multiple 'Unexpected' messages,
  --   but we only want to display the first one.
  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
  
  