{-# options_haddock prune #-}

-- |Description: The parser for the quasiquote body, using "FlatParse".
module Exon.Parse where

import Data.Char (isSpace)
import qualified FlatParse.Stateful as FlatParse
import FlatParse.Stateful (
  Result (Err, Fail, OK),
  anyChar,
  branch,
  char,
  empty,
  eof,
  get,
  inSpan,
  lookahead,
  modify,
  put,
  runParserUtf8,
  satisfy,
  string,
  takeRestString,
  withSpan,
  (<|>),
  )
import Prelude hiding (empty, span, (<|>))

import Exon.Data.RawSegment (RawSegment (AutoExpSegment, ExpSegment, StringSegment, WsSegment))

type Parser =
  FlatParse.Parser Int Text

span :: Parser () -> Parser String
span :: Parser () -> Parser String
span Parser ()
seek =
  forall (st :: ZeroBitType) r e a b.
ParserT st r e a
-> (a -> Span -> ParserT st r e b) -> ParserT st r e b
withSpan Parser ()
seek \ ()
_ Span
sp -> forall (st :: ZeroBitType) r e a.
Span -> ParserT st r e a -> ParserT st r e a
inSpan Span
sp forall (st :: ZeroBitType) r e. ParserT st r e String
takeRestString

ws :: Parser Char
ws :: Parser Char
ws =
  forall (st :: ZeroBitType) r e.
(Char -> Bool) -> ParserT st r e Char
satisfy Char -> Bool
isSpace

whitespace :: Parser RawSegment
whitespace :: Parser RawSegment
whitespace =
  String -> RawSegment
WsSegment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser String
span (forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser Char
ws))

before ::
  Parser a ->
  Parser () ->
  Parser () ->
  Parser ()
before :: forall a. Parser a -> Parser () -> Parser () -> Parser ()
before =
  forall (st :: ZeroBitType) r e a b.
ParserT st r e a
-> ParserT st r e b -> ParserT st r e b -> ParserT st r e b
branch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a
lookahead

finishBefore ::
  Parser a ->
  Parser () ->
  Parser ()
finishBefore :: forall a. Parser a -> Parser () -> Parser ()
finishBefore Parser a
cond =
  forall a. Parser a -> Parser () -> Parser () -> Parser ()
before Parser a
cond forall (f :: * -> *). Applicative f => f ()
unit

expr :: Parser ()
expr :: Parser ()
expr =
  forall (st :: ZeroBitType) r e a b.
ParserT st r e a
-> ParserT st r e b -> ParserT st r e b -> ParserT st r e b
branch $(char '{') (forall (st :: ZeroBitType) r e. (Int -> Int) -> ParserT st r e ()
modify (Int
1 +) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
expr) forall a b. (a -> b) -> a -> b
$
  forall a. Parser a -> Parser () -> Parser () -> Parser ()
before $(char '}') Parser ()
closing (forall (st :: ZeroBitType) r e. ParserT st r e Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
expr)
  where
    closing :: Parser ()
closing =
      forall (st :: ZeroBitType) r e. ParserT st r e Int
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Int
0 -> forall (f :: * -> *). Applicative f => f ()
unit
        Int
cur -> forall (st :: ZeroBitType) r e. Int -> ParserT st r e ()
put (Int
cur forall a. Num a => a -> a -> a
- Int
1) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char '}') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
expr

autoInterpolation :: Parser RawSegment
autoInterpolation :: Parser RawSegment
autoInterpolation =
  $(string "##{") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> RawSegment
AutoExpSegment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser String
span Parser ()
expr) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(char '}')

verbatimInterpolation :: Parser RawSegment
verbatimInterpolation :: Parser RawSegment
verbatimInterpolation =
  $(string "#{") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> RawSegment
ExpSegment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser String
span Parser ()
expr) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(char '}')

untilTokenEnd :: Parser ()
untilTokenEnd :: Parser ()
untilTokenEnd =
  forall a. Parser a -> Parser () -> Parser ()
finishBefore ($(string "##{") forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> $(string "#{")) forall a b. (a -> b) -> a -> b
$
  forall (st :: ZeroBitType) r e. ParserT st r e ()
eof forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> (forall (st :: ZeroBitType) r e. ParserT st r e Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
untilTokenEnd)

untilTokenEndWs :: Parser ()
untilTokenEndWs :: Parser ()
untilTokenEndWs =
  forall a. Parser a -> Parser () -> Parser ()
finishBefore ($(string "##{") forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> $(string "#{") forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Char
ws) forall a b. (a -> b) -> a -> b
$
  forall (st :: ZeroBitType) r e. ParserT st r e ()
eof forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> (forall (st :: ZeroBitType) r e. ParserT st r e Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
untilTokenEndWs)

text :: Parser RawSegment
text :: Parser RawSegment
text =
  String -> RawSegment
StringSegment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser String
span Parser ()
untilTokenEnd

textWs :: Parser RawSegment
textWs :: Parser RawSegment
textWs =
  String -> RawSegment
StringSegment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser String
span Parser ()
untilTokenEndWs

segment :: Parser RawSegment
segment :: Parser RawSegment
segment =
  forall (st :: ZeroBitType) r e a b.
ParserT st r e a
-> ParserT st r e b -> ParserT st r e b -> ParserT st r e b
branch forall (st :: ZeroBitType) r e. ParserT st r e ()
eof forall (f :: * -> *) a. Alternative f => f a
empty (Parser RawSegment
autoInterpolation forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> Parser RawSegment
verbatimInterpolation forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> Parser RawSegment
text)

segmentWs :: Parser RawSegment
segmentWs :: Parser RawSegment
segmentWs =
  forall (st :: ZeroBitType) r e a b.
ParserT st r e a
-> ParserT st r e b -> ParserT st r e b -> ParserT st r e b
branch forall (st :: ZeroBitType) r e. ParserT st r e ()
eof forall (f :: * -> *) a. Alternative f => f a
empty (Parser RawSegment
whitespace forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> Parser RawSegment
autoInterpolation forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> Parser RawSegment
verbatimInterpolation forall (st :: ZeroBitType) r e a.
ParserT st r e a -> ParserT st r e a -> ParserT st r e a
<|> Parser RawSegment
textWs)

parser :: Parser [RawSegment]
parser :: Parser [RawSegment]
parser =
  forall (f :: * -> *) a. Alternative f => f a -> f [a]
FlatParse.many Parser RawSegment
segment

parserWs :: Parser [RawSegment]
parserWs :: Parser [RawSegment]
parserWs =
  forall (f :: * -> *) a. Alternative f => f a -> f [a]
FlatParse.many Parser RawSegment
segmentWs

parseWith :: Parser [RawSegment] -> String -> Either Text [RawSegment]
parseWith :: Parser [RawSegment] -> String -> Either Text [RawSegment]
parseWith Parser [RawSegment]
p =
  forall r e a. Parser r e a -> r -> Int -> String -> Result e a
runParserUtf8 Parser [RawSegment]
p Int
0 Int
0 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    OK [RawSegment]
a Int
_ ByteString
"" -> forall a b. b -> Either a b
Right [RawSegment]
a
    OK [RawSegment]
_ Int
_ ByteString
u -> forall a b. a -> Either a b
Left (Text
"unconsumed: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
u)
    Result Text [RawSegment]
Fail -> forall a b. a -> Either a b
Left Text
"fail"
    Err Text
e -> forall a b. a -> Either a b
Left Text
e

parse :: String -> Either Text [RawSegment]
parse :: String -> Either Text [RawSegment]
parse =
  Parser [RawSegment] -> String -> Either Text [RawSegment]
parseWith Parser [RawSegment]
parser

parseWs :: String -> Either Text [RawSegment]
parseWs :: String -> Either Text [RawSegment]
parseWs =
  Parser [RawSegment] -> String -> Either Text [RawSegment]
parseWith Parser [RawSegment]
parserWs