{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Various <https://hackage.haskell.org/package/flatparse flatparse> helpers and combinators.
module MarkupParse.FlatParse
  ( -- * Parsing
    ParserWarning (..),
    runParserMaybe,
    runParserEither,
    runParserWarn,
    runParser_,

    -- * Flatparse re-exports
    runParser,
    Parser,
    Result (..),

    -- * Parsers
    isWhitespace,
    ws_,
    ws,
    wss,
    nota,
    isa,
    sq,
    dq,
    wrappedDq,
    wrappedSq,
    wrappedQ,
    wrappedQNoGuard,
    eq,
    sep,
    bracketed,
    bracketedSB,
    wrapped,
    digit,
    int,
    double,
    signed,
    byteStringOf',
    comma,
  )
where

import Control.DeepSeq
import Data.Bool
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B
import Data.Char hiding (isDigit)
import Data.These
import FlatParse.Basic hiding (cut, take)
import GHC.Exts
import GHC.Generics (Generic)
import Prelude hiding (replicate)

-- $setup
-- >>> :set -XTemplateHaskell
-- >>> import MarkupParse.FlatParse
-- >>> import FlatParse.Basic

-- | Run a Parser, throwing away leftovers. Nothing on 'Fail' or 'Err'.
--
-- >>> runParserMaybe ws "x"
-- Nothing
--
-- >>> runParserMaybe ws " x"
-- Just ' '
runParserMaybe :: Parser e a -> ByteString -> Maybe a
runParserMaybe :: forall e a. Parser e a -> ByteString -> Maybe a
runParserMaybe Parser e a
p ByteString
b = case forall e a. Parser e a -> ByteString -> Result e a
runParser Parser e a
p ByteString
b of
  OK a
r ByteString
_ -> forall a. a -> Maybe a
Just a
r
  Result e a
Fail -> forall a. Maybe a
Nothing
  Err e
_ -> forall a. Maybe a
Nothing

-- | Run a Parser, throwing away leftovers. Returns Left on 'Fail' or 'Err'.
--
-- >>> runParserEither ws " x"
-- Right ' '
runParserEither :: (IsString e) => Parser e a -> ByteString -> Either e a
runParserEither :: forall e a. IsString e => Parser e a -> ByteString -> Either e a
runParserEither Parser e a
p ByteString
bs = case forall e a. Parser e a -> ByteString -> Result e a
runParser Parser e a
p ByteString
bs of
  Err e
e -> forall a b. a -> Either a b
Left e
e
  OK a
a ByteString
_ -> forall a b. b -> Either a b
Right a
a
  Result e a
Fail -> forall a b. a -> Either a b
Left e
"uncaught parse error"

-- | Warnings covering leftovers, 'Err's and 'Fail'
--
-- >>> runParserWarn ws " x"
-- These (ParserLeftover "x") ' '
--
-- >>> runParserWarn ws "x"
-- This ParserUncaught
--
-- >>> runParserWarn (ws `cut` "no whitespace") "x"
-- This (ParserError "no whitespace")
data ParserWarning = ParserLeftover ByteString | ParserError ByteString | ParserUncaught deriving (ParserWarning -> ParserWarning -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParserWarning -> ParserWarning -> Bool
$c/= :: ParserWarning -> ParserWarning -> Bool
== :: ParserWarning -> ParserWarning -> Bool
$c== :: ParserWarning -> ParserWarning -> Bool
Eq, Int -> ParserWarning -> ShowS
[ParserWarning] -> ShowS
ParserWarning -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParserWarning] -> ShowS
$cshowList :: [ParserWarning] -> ShowS
show :: ParserWarning -> String
$cshow :: ParserWarning -> String
showsPrec :: Int -> ParserWarning -> ShowS
$cshowsPrec :: Int -> ParserWarning -> ShowS
Show, Eq ParserWarning
ParserWarning -> ParserWarning -> Bool
ParserWarning -> ParserWarning -> Ordering
ParserWarning -> ParserWarning -> ParserWarning
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ParserWarning -> ParserWarning -> ParserWarning
$cmin :: ParserWarning -> ParserWarning -> ParserWarning
max :: ParserWarning -> ParserWarning -> ParserWarning
$cmax :: ParserWarning -> ParserWarning -> ParserWarning
>= :: ParserWarning -> ParserWarning -> Bool
$c>= :: ParserWarning -> ParserWarning -> Bool
> :: ParserWarning -> ParserWarning -> Bool
$c> :: ParserWarning -> ParserWarning -> Bool
<= :: ParserWarning -> ParserWarning -> Bool
$c<= :: ParserWarning -> ParserWarning -> Bool
< :: ParserWarning -> ParserWarning -> Bool
$c< :: ParserWarning -> ParserWarning -> Bool
compare :: ParserWarning -> ParserWarning -> Ordering
$ccompare :: ParserWarning -> ParserWarning -> Ordering
Ord, forall x. Rep ParserWarning x -> ParserWarning
forall x. ParserWarning -> Rep ParserWarning x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ParserWarning x -> ParserWarning
$cfrom :: forall x. ParserWarning -> Rep ParserWarning x
Generic, ParserWarning -> ()
forall a. (a -> ()) -> NFData a
rnf :: ParserWarning -> ()
$crnf :: ParserWarning -> ()
NFData)

-- | Run parser, returning leftovers and errors as 'ParserWarning's.
--
-- >>> runParserWarn ws " "
-- That ' '
--
-- >>> runParserWarn ws "x"
-- This ParserUncaught
--
-- >>> runParserWarn ws " x"
-- These (ParserLeftover "x") ' '
runParserWarn :: Parser ByteString a -> ByteString -> These ParserWarning a
runParserWarn :: forall a.
Parser ByteString a -> ByteString -> These ParserWarning a
runParserWarn Parser ByteString a
p ByteString
bs = case forall e a. Parser e a -> ByteString -> Result e a
runParser Parser ByteString a
p ByteString
bs of
  Err ByteString
e -> forall a b. a -> These a b
This (ByteString -> ParserWarning
ParserError ByteString
e)
  OK a
a ByteString
"" -> forall a b. b -> These a b
That a
a
  OK a
a ByteString
x -> forall a b. a -> b -> These a b
These (ByteString -> ParserWarning
ParserLeftover forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.take Int
200 ByteString
x) a
a
  Result ByteString a
Fail -> forall a b. a -> These a b
This ParserWarning
ParserUncaught

-- | Run parser, discards leftovers & throws an error on failure.
--
-- >>> runParser_ ws " "
-- ' '
--
-- >>> runParser_ ws "x"
-- *** Exception: uncaught parse error
-- ...
runParser_ :: Parser String a -> ByteString -> a
runParser_ :: forall a. Parser String a -> ByteString -> a
runParser_ Parser String a
p ByteString
bs = case forall e a. Parser e a -> ByteString -> Result e a
runParser Parser String a
p ByteString
bs of
  Err String
e -> forall a. HasCallStack => String -> a
error String
e
  OK a
a ByteString
_ -> a
a
  Result String a
Fail -> forall a. HasCallStack => String -> a
error String
"uncaught parse error"

-- | Consume whitespace.
--
-- >>> runParser ws_ " \nx"
-- OK () "x"
--
-- >>> runParser ws_ "x"
-- OK () "x"
ws_ :: Parser e ()
ws_ :: forall e. Parser e ()
ws_ =
  $( switch
       [|
         case _ of
           " " -> ws_
           "\n" -> ws_
           "\t" -> ws_
           "\r" -> ws_
           "\f" -> ws_
           _ -> pure ()
         |]
   )
{-# INLINE ws_ #-}

-- | \\n \\t \\f \\r and space
isWhitespace :: Char -> Bool
isWhitespace :: Char -> Bool
isWhitespace Char
' ' = Bool
True -- \x20 space
isWhitespace Char
'\x0a' = Bool
True -- \n linefeed
isWhitespace Char
'\x09' = Bool
True -- \t tab
isWhitespace Char
'\x0c' = Bool
True -- \f formfeed
isWhitespace Char
'\x0d' = Bool
True -- \r carriage return
isWhitespace Char
_ = Bool
False
{-# INLINE isWhitespace #-}

-- | single whitespace
--
-- >>> runParser ws " \nx"
-- OK ' ' "\nx"
ws :: Parser e Char
ws :: forall e. Parser e Char
ws = forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy Char -> Bool
isWhitespace

-- | multiple whitespace
--
-- >>> runParser wss " \nx"
-- OK " \n" "x"
--
-- >>> runParser wss "x"
-- Fail
wss :: Parser e ByteString
wss :: forall e. Parser e ByteString
wss = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e ByteString
byteStringOf forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall e. Parser e Char
ws

-- | Single quote
--
-- >>> runParserMaybe sq "'"
-- Just ()
sq :: ParserT st e ()
sq :: forall (st :: ZeroBitType) e. ParserT st e ()
sq = $(char '\'')

-- | Double quote
--
-- >>> runParserMaybe dq "\""
-- Just ()
dq :: ParserT st e ()
dq :: forall (st :: ZeroBitType) e. ParserT st e ()
dq = $(char '"')

-- | Parse whilst not a specific character
--
-- >>> runParser (nota 'x') "abcxyz"
-- OK "abc" "xyz"
nota :: Char -> Parser e ByteString
nota :: forall e. Char -> Parser e ByteString
nota Char
c = forall (st :: ZeroBitType) e a b.
ParserT st e a -> (a -> Span -> ParserT st e b) -> ParserT st e b
withSpan (forall (st :: ZeroBitType) e a. ParserT st e a -> ParserT st e ()
skipMany (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
c))) (\() Span
s -> forall (st :: ZeroBitType) e. Span -> ParserT st e ByteString
unsafeSpanToByteString Span
s)
{-# INLINE nota #-}

-- | Parse whilst satisfying a predicate.
--
-- >>> runParser (isa (=='x')) "xxxabc"
-- OK "xxx" "abc"
isa :: (Char -> Bool) -> Parser e ByteString
isa :: forall e. (Char -> Bool) -> Parser e ByteString
isa Char -> Bool
p = forall (st :: ZeroBitType) e a b.
ParserT st e a -> (a -> Span -> ParserT st e b) -> ParserT st e b
withSpan (forall (st :: ZeroBitType) e a. ParserT st e a -> ParserT st e ()
skipMany (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy Char -> Bool
p)) (\() Span
s -> forall (st :: ZeroBitType) e. Span -> ParserT st e ByteString
unsafeSpanToByteString Span
s)
{-# INLINE isa #-}

-- | 'byteStringOf' but using withSpan internally. Doesn't seems faster...
byteStringOf' :: Parser e a -> Parser e ByteString
byteStringOf' :: forall e a. Parser e a -> Parser e ByteString
byteStringOf' Parser e a
p = forall (st :: ZeroBitType) e a b.
ParserT st e a -> (a -> Span -> ParserT st e b) -> ParserT st e b
withSpan Parser e a
p (\a
_ Span
s -> forall (st :: ZeroBitType) e. Span -> ParserT st e ByteString
unsafeSpanToByteString Span
s)
{-# INLINE byteStringOf' #-}

-- | A single-quoted string.
wrappedSq :: Parser b ByteString
wrappedSq :: forall e. Parser e ByteString
wrappedSq = $(char '\'') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e. Char -> Parser e ByteString
nota Char
'\'' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(char '\'')
{-# INLINE wrappedSq #-}

-- | A double-quoted string.
wrappedDq :: Parser b ByteString
wrappedDq :: forall e. Parser e ByteString
wrappedDq = $(char '"') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e. Char -> Parser e ByteString
nota Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(char '"')
{-# INLINE wrappedDq #-}

-- | A single-quoted or double-quoted string.
--
-- >>> runParserMaybe wrappedQ "\"quoted\""
-- Just "quoted"
--
-- >>> runParserMaybe wrappedQ "'quoted'"
-- Just "quoted"
wrappedQ :: Parser e ByteString
wrappedQ :: forall e. Parser e ByteString
wrappedQ =
  forall e. Parser e ByteString
wrappedDq
    forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> forall e. Parser e ByteString
wrappedSq
{-# INLINE wrappedQ #-}

-- | A single-quoted or double-quoted wrapped parser.
--
-- >>> runParser (wrappedQNoGuard (many $ satisfy (/= '"'))) "\"name\""
-- OK "name" ""
--
-- Will consume quotes if the underlying parser does.
--
-- >>> runParser (wrappedQNoGuard (many anyChar)) "\"name\""
-- Fail
wrappedQNoGuard :: Parser e a -> Parser e a
wrappedQNoGuard :: forall e a. Parser e a -> Parser e a
wrappedQNoGuard Parser e a
p = forall e a. Parser e () -> Parser e a -> Parser e a
wrapped forall (st :: ZeroBitType) e. ParserT st e ()
dq Parser e a
p forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> forall e a. Parser e () -> Parser e a -> Parser e a
wrapped forall (st :: ZeroBitType) e. ParserT st e ()
sq Parser e a
p

-- | xml production [25]
--
-- >>> runParserMaybe eq " = "
-- Just ()
--
-- >>> runParserMaybe eq "="
-- Just ()
eq :: Parser e ()
eq :: forall e. Parser e ()
eq = forall e. Parser e ()
ws_ forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char '=') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e. Parser e ()
ws_
{-# INLINE eq #-}

-- | Some with a separator.
--
-- >>> runParser (sep ws (many (satisfy (/= ' ')))) "a b c"
-- OK ["a","b","c"] ""
sep :: Parser e s -> Parser e a -> Parser e [a]
sep :: forall e s a. Parser e s -> Parser e a -> Parser e [a]
sep Parser e s
s Parser e a
p = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser e a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser e s
s forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser e a
p)

-- | Parser bracketed by two other parsers.
--
-- >>> runParser (bracketed ($(char '[')) ($(char ']')) (many (satisfy (/= ']')))) "[bracketed]"
-- OK "bracketed" ""
bracketed :: Parser e b -> Parser e b -> Parser e a -> Parser e a
bracketed :: forall e b a. Parser e b -> Parser e b -> Parser e a -> Parser e a
bracketed Parser e b
o Parser e b
c Parser e a
p = Parser e b
o forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser e a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser e b
c
{-# INLINE bracketed #-}

-- | Parser bracketed by square brackets.
--
-- >>> runParser bracketedSB "[bracketed]"
-- OK "bracketed" ""
bracketedSB :: Parser e [Char]
bracketedSB :: forall e. Parser e String
bracketedSB = forall e b a. Parser e b -> Parser e b -> Parser e a -> Parser e a
bracketed $(char '[') $(char ']') (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
']')))

-- | Parser wrapped by another parser.
--
-- >>> runParser (wrapped ($(char '"')) (many (satisfy (/= '"')))) "\"wrapped\""
-- OK "wrapped" ""
wrapped :: Parser e () -> Parser e a -> Parser e a
wrapped :: forall e a. Parser e () -> Parser e a -> Parser e a
wrapped Parser e ()
x Parser e a
p = forall e b a. Parser e b -> Parser e b -> Parser e a -> Parser e a
bracketed Parser e ()
x Parser e ()
x Parser e a
p
{-# INLINE wrapped #-}

-- | A single digit
--
-- >>> runParserMaybe digit "5"
-- Just 5
digit :: Parser e Int
digit :: forall e. Parser e Int
digit = (\Char
c -> Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfyAscii Char -> Bool
isDigit

-- | An (unsigned) 'Int' parser
--
-- >>> runParserMaybe int "567"
-- Just 567
int :: Parser e Int
int :: forall e. Parser e Int
int = do
  (Int
place, Int
n) <- forall a b (st :: ZeroBitType) e.
(a -> b -> b) -> ParserT st e a -> ParserT st e b -> ParserT st e b
chainr (\Int
n (!Int
place, !Int
acc) -> (Int
place forall a. Num a => a -> a -> a
* Int
10, Int
acc forall a. Num a => a -> a -> a
+ Int
place forall a. Num a => a -> a -> a
* Int
n)) forall e. Parser e Int
digit (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Int
0))
  case Int
place of
    Int
1 -> forall (f :: * -> *) a. Alternative f => f a
empty
    Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n

digits :: Parser e (Int, Int)
digits :: forall e. Parser e (Int, Int)
digits = forall a b (st :: ZeroBitType) e.
(a -> b -> b) -> ParserT st e a -> ParserT st e b -> ParserT st e b
chainr (\Int
n (!Int
place, !Int
acc) -> (Int
place forall a. Num a => a -> a -> a
* Int
10, Int
acc forall a. Num a => a -> a -> a
+ Int
place forall a. Num a => a -> a -> a
* Int
n)) forall e. Parser e Int
digit (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Int
0))

-- | A 'Double' parser.
--
-- >>> runParser double "1.234x"
-- OK 1.234 "x"
--
-- >>> runParser double "."
-- Fail
--
-- >>> runParser double "123"
-- OK 123.0 ""
--
-- >>> runParser double ".123"
-- OK 0.123 ""
--
-- >>> runParser double "123."
-- OK 123.0 ""
double :: Parser e Double
double :: forall e. Parser e Double
double = do
  (Int
placel, Int
nl) <- forall e. Parser e (Int, Int)
digits
  forall (st :: ZeroBitType) e a r.
ParserT st e a
-> (a -> ParserT st e r) -> ParserT st e r -> ParserT st e r
withOption
    ($(char '.') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e. Parser e (Int, Int)
digits)
    ( \(Int
placer, Int
nr) ->
        case (Int
placel, Int
placer) of
          (Int
1, Int
1) -> forall (f :: * -> *) a. Alternative f => f a
empty
          (Int, Int)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nl forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nr forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
placer
    )
    ( case Int
placel of
        Int
1 -> forall (f :: * -> *) a. Alternative f => f a
empty
        Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nl
    )

minus :: Parser e ()
minus :: forall e. Parser e ()
minus = $(char '-')

-- | Parser for a signed prefix to a number.
--
-- >>> runParser (signed double) "-1.234x"
-- OK (-1.234) "x"
signed :: (Num b) => Parser e b -> Parser e b
signed :: forall b e. Num b => Parser e b -> Parser e b
signed Parser e b
p = do
  Maybe ()
m <- forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional forall e. Parser e ()
minus
  case Maybe ()
m of
    Maybe ()
Nothing -> Parser e b
p
    Just () -> forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser e b
p

-- | Comma parser
--
-- >>> runParserMaybe comma ","
-- Just ()
comma :: Parser e ()
comma :: forall e. Parser e ()
comma = $(char ',')