{-# 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,
  runParserS,
  satisfy,
  some_,
  withSpan,
  string,
  takeRest,
  (<|>),
  )
import Prelude hiding (empty, span, (<|>))

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

type Parser =
  FlatParse.Parser Int Text

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

ws :: Parser Char
ws :: Parser Char
ws =
  forall r e. (Char -> Bool) -> Parser 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 r e a. Parser r e a -> Parser r e ()
some_ Parser Char
ws)

before ::
  Parser a ->
  Parser () ->
  Parser () ->
  Parser ()
before :: forall a. Parser a -> Parser () -> Parser () -> Parser ()
before =
  forall r e a b.
Parser r e a -> Parser r e b -> Parser r e b -> Parser r e b
branch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r e a. Parser r e a -> Parser 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 r e a b.
Parser r e a -> Parser r e b -> Parser r e b -> Parser r e b
branch $(char '{') (forall r e. (Int -> Int) -> Parser r e ()
modify (Int
1 forall a. Num a => a -> a -> a
+) 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 r e. Parser r e Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
expr)
  where
    closing :: Parser ()
closing =
      forall r e. Parser 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 r e. Int -> Parser 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

interpolation :: Parser RawSegment
interpolation :: Parser RawSegment
interpolation =
  $(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 r e a b.
Parser r e a -> Parser r e b -> Parser r e b -> Parser r e b
branch $(char '\\') (forall r e. Parser r e Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
untilTokenEnd) forall a b. (a -> b) -> a -> b
$
  forall a. Parser a -> Parser () -> Parser ()
finishBefore ($(string "#{") forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Char
ws) forall a b. (a -> b) -> a -> b
$
  forall r e. Parser r e ()
eof forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> (forall r e. Parser r e Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
untilTokenEnd)

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

segment :: Parser RawSegment
segment :: Parser RawSegment
segment =
  forall r e a b.
Parser r e a -> Parser r e b -> Parser r e b -> Parser r e b
branch forall r e. Parser r e ()
eof forall r e a. Parser r e a
empty (Parser RawSegment
whitespace forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> Parser RawSegment
interpolation forall r e a. Parser r e a -> Parser r e a -> Parser r e a
<|> Parser RawSegment
text)

parser :: Parser [RawSegment]
parser :: Parser [RawSegment]
parser =
  forall r e a. Parser r e a -> Parser r e [a]
FlatParse.many Parser RawSegment
segment

parse :: String -> Either Text [RawSegment]
parse :: String -> Either Text [RawSegment]
parse =
  forall r e a. Parser r e a -> r -> Int -> String -> Result e a
runParserS Parser [RawSegment]
parser 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