Extra.hs

{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Data.Attoparsec.Extra where

import Control.Monad (void)
import Control.Monad.Extra (maybeM)
import Data.Attoparsec.Internal.Types (Pos (Pos))
import Data.Attoparsec.Internal.Types qualified as Internal
import Data.Attoparsec.Text (Parser, anyChar, peekChar, takeWhile)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Internal.Encoding.Utf8 (utf8Length)
import Prelude hiding (takeWhile)

-- | Fails with the reason as it is, without attoparsec's prefix.
parseError :: String -> Parser a
parseError reason = Internal.Parser \t pos more failure _ -> failure t pos more [] reason

-- | Fails with the given @reason@ at the given @position@,
-- which does not have to be the current one.
failAt :: Pos -> String -> Parser a
failAt position reason = Internal.Parser \t _ more failure _ -> failure t position more [] reason

-- | The position in the input, in bytes.
position :: Parser Pos
position = Internal.Parser \t pos more _ success -> success t pos more pos

-- | Runs a parser and rewinds if it fails, giving the position and reason of the failure.
observing :: Parser a -> Parser (Either (Pos, String) a)
observing p = Internal.Parser \t pos more _ success ->
    Internal.runParser
        p
        t
        pos
        more
        (\t' pos' more' _ reason -> success t' pos more' $ Left (pos', reason))
        (\t' pos' more' a -> success t' pos' more' $ Right a)

-- | Runs a parser and rewinds if it gives 'Nothing'. A failure is kept.
attemptMaybe :: Parser (Maybe a) -> Parser (Maybe a)
attemptMaybe p = Internal.Parser \t pos more failure success ->
    Internal.runParser p t pos more failure \t' pos' more' result ->
        success t' (maybe pos (const pos') result) more' result

-- | The result of a parser, which must not be 'Nothing'.
required :: String -> Parser (Maybe a) -> Parser a
required reason p =
    p >>= \case
        Nothing -> parseError reason
        Just a -> pure a

-- | The second character, without consuming anything.
peekSecond :: Parser (Maybe Char)
peekSecond = Internal.Parser \t pos more failure success ->
    Internal.runParser peekChar t pos more failure \t' _ more' -> \case
        Nothing -> success t' pos more' Nothing
        Just first ->
            Internal.runParser peekChar t' (pos + width first) more' failure \t'' _ more'' ->
                success t'' pos more''

-- | Whether the second character is the given one.
secondIs :: Char -> Parser Bool
secondIs c = (Just c ==) <$> peekSecond

-- | Runs a parser until it gives 'Nothing', and collects the results.
whileJust :: Parser (Maybe a) -> Parser [a]
whileJust p = maybeM (pure []) (\x -> (x :) <$> whileJust p) p

-- | Whether the next character is the given one.
nextIs :: Char -> Parser Bool
nextIs c = (Just c ==) <$> peekChar

-- | Consumes the next character.
advance :: Parser ()
advance = Internal.Parser \t pos more failure success ->
    Internal.runParser peekChar t pos more failure \t' _ more' -> \case
        Just c -> success t' (pos + width c) more' ()
        Nothing -> Internal.runParser (void anyChar) t' pos more' failure success

-- | How far a character moves the position, in bytes.
width :: Char -> Pos
width = Pos . utf8Length

-- | Consumes the character, or fails.
expectChar :: Char -> Parser ()
expectChar expected =
    peekChar >>= \case
        Just c | c == expected -> advance
        _ -> parseError $ "Expected token: " <> show (Text.singleton expected)

-- | Like 'takeWhile', but fails if it takes nothing.
takeWhile1With :: String -> (Char -> Bool) -> Parser Text
takeWhile1With expected p = do
    taken <- takeWhile p
    if Text.null taken
        then parseError $ "Expected a character from range: " <> expected
        else pure taken