Parse.hs

-- |
--
-- Module      : Mdoc.Parse
-- Copyright   : (c) 2026 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
module Mdoc.Parse
  ( Parser
  , ParseError
  , MacroState (..)
  , runParser
  , exitParseError

    -- * Megaparsec re-exports
  , module Text.Megaparsec
  , module Text.Megaparsec.Char

    -- * High-level helpers
  , macroCall

    -- * Low-level helpers
  , restOfWord
  , restOfLine
  , digits
  , quotedBy
  , escaped
  , peek
  , parseAs
  ) where

import Mdoc.Prelude

import Control.Monad.State.Strict (StateT, evalState)
import Data.Char (isSpace)
import Data.Monoid (Last (..))
import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)
import Text.Megaparsec hiding (ParseError, parseTest, runParser)
import Text.Megaparsec.Char
import Text.Read (readMaybe)

type Parser a = ParsecT Void Text (StateT MacroState Identity) a

runParser :: Parser a -> String -> Text -> Either ParseError a
runParser p name input =
  flip evalState mempty $ runParserT (p <* eof) name input

exitParseError :: MonadIO m => ParseError -> m a
exitParseError err = liftIO $ do
  hPutStrLn stderr $ errorBundlePretty err
  exitFailure

data MacroState = MacroState
  { defined :: Set Text
  -- ^ Macros that have been defined so far
  , nextClose :: Last Text
  -- ^ If in a macro definition with custom closer, this is it
  }
  deriving stock (Generic)
  deriving (Monoid, Semigroup) via GenericSemigroupMonoid MacroState

type ParseError = ParseErrorBundle Text Void

-- | Flexibly parse a macro call
--
-- Parses
--
-- @
-- .{Name}[ {Arg}...]
-- @
--
-- And passes @Name@ and @[Arg]@ to the given constructor.
macroCall
  :: (name -> [arg] -> a)
  -- ^ Constructor given name and args
  -> Parser name
  -- ^ Parser for the macro name (not including the leading @.@)
  -> Parser arg
  -- ^ Parser for an individual argument
  -> Parser a
macroCall f pName pArg = do
  name <- char '.' *> pName
  args <- manyTill (hspace1 *> pArg) (peek $ hspace >> eol)
  pure $ f name args

restOfWord :: Parser Text
restOfWord = pack <$> some (satisfy $ not . isSpace) <?> "rest of word"

restOfLine :: Parser Text
restOfLine = pack <$> manyTill anySingle (peek eol) <?> "rest of line"

digits :: Parser Int
digits = do
  s <- some digitChar
  maybe (fail $ "String " <> s <> " did not parse as Int") pure $ readMaybe s

quotedBy :: Char -> Parser Text
quotedBy c = do
  str <- char c *> manyTill (try (escaped c) <|> noneOf [c]) (char c)
  pure $ pack str

escaped :: Char -> Parser Char
escaped c = char '\\' *> char c

peek :: Parser a -> Parser a
peek p = lookAhead $ try p

parseAs :: (a -> Text) -> a -> Parser a
parseAs f a = a <$ string (f a)