-- |Description: Internal
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_,
  spanned,
  string,
  takeRest,
  (<|>),
  )
import Prelude hiding (empty, get, modify, put, span, (<|>))

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

type Parser =
  FlatParse.Parser Text

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

ws :: Parser Char
ws :: Parser Char
ws =
  (Char -> Bool) -> Parser Char
forall e. (Char -> Bool) -> Parser e Char
satisfy Char -> Bool
isSpace

whitespace :: Parser RawSegment
whitespace :: Parser RawSegment
whitespace =
  String -> RawSegment
WsSegment (String -> RawSegment) -> Parser String -> Parser RawSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser String
span (Parser Char -> Parser ()
forall e a. Parser e a -> Parser e ()
some_ Parser Char
ws)

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

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

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

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

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

text :: Parser RawSegment
text :: Parser RawSegment
text =
  String -> RawSegment
StringSegment (String -> RawSegment) -> Parser String -> Parser RawSegment
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 =
  Parser ()
-> Parser RawSegment -> Parser RawSegment -> Parser RawSegment
forall e a b. Parser e a -> Parser e b -> Parser e b -> Parser e b
branch Parser ()
forall e. Parser e ()
eof Parser RawSegment
forall e a. Parser e a
empty (Parser RawSegment
whitespace Parser RawSegment -> Parser RawSegment -> Parser RawSegment
forall e a. Parser e a -> Parser e a -> Parser e a
<|> Parser RawSegment
interpolation Parser RawSegment -> Parser RawSegment -> Parser RawSegment
forall e a. Parser e a -> Parser e a -> Parser e a
<|> Parser RawSegment
text)

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

parse :: String -> Either Text [RawSegment]
parse :: String -> Either Text [RawSegment]
parse =
  Parser [RawSegment]
-> Int -> Int -> String -> Result Text [RawSegment]
forall e a. Parser e a -> Int -> Int -> String -> Result e a
runParserS Parser [RawSegment]
parser Int
0 Int
0 (String -> Result Text [RawSegment])
-> (Result Text [RawSegment] -> Either Text [RawSegment])
-> String
-> Either Text [RawSegment]
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
"" -> [RawSegment] -> Either Text [RawSegment]
forall a b. b -> Either a b
Right [RawSegment]
a
    OK [RawSegment]
_ Int
_ ByteString
u -> Text -> Either Text [RawSegment]
forall a b. a -> Either a b
Left (Text
"unconsumed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
u)
    Result Text [RawSegment]
Fail -> Text -> Either Text [RawSegment]
forall a b. a -> Either a b
Left Text
"fail"
    Err Text
e -> Text -> Either Text [RawSegment]
forall a b. a -> Either a b
Left Text
e