{-# options_haddock prune #-}

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

import Data.Char (isSpace)
import Prelude hiding ((<|>))
import Text.Parsec as Parsec (
  Parsec,
  anyChar,
  char,
  choice,
  eof,
  getState,
  lookAhead,
  modifyState,
  putState,
  runParser,
  satisfy,
  string,
  try,
  (<|>),
  )

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

type Parser = Parsec String Int

ws :: Parser Char
ws :: Parser Char
ws =
  (Char -> Bool) -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isSpace

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

expr :: Parser String
expr :: ParsecT String Int Identity String
expr =
  [ParsecT String Int Identity String]
-> ParsecT String Int Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ParsecT String Int Identity String
-> ParsecT String Int Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String Int Identity String
opening, ParsecT String Int Identity String
-> ParsecT String Int Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String Int Identity String
closing, Item [ParsecT String Int Identity String]
ParsecT String Int Identity String
anyChars]
  where
    opening :: ParsecT String Int Identity String
opening = do
      Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{'
      (Int -> Int) -> ParsecT String Int Identity ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState (Int
1 +)
      String
e <- ParsecT String Int Identity String
expr
      pure (Char
'{' Char -> String -> String
forall a. a -> [a] -> [a]
: String
e)

    closing :: ParsecT String Int Identity String
closing = do
      Parser Char -> ParsecT String Int Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Char -> ParsecT String Int Identity ())
-> Parser Char -> ParsecT String Int Identity ()
forall a b. (a -> b) -> a -> b
$ Parser Char -> Parser Char
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}')
      ParsecT String Int Identity Int
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState ParsecT String Int Identity Int
-> (Int -> ParsecT String Int Identity String)
-> ParsecT String Int Identity String
forall a b.
ParsecT String Int Identity a
-> (a -> ParsecT String Int Identity b)
-> ParsecT String Int Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Int
0 -> String -> ParsecT String Int Identity String
forall a. a -> ParsecT String Int Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
        Int
cur -> do
          Int -> ParsecT String Int Identity ()
forall (m :: * -> *) u s. Monad m => u -> ParsecT s u m ()
putState (Int
cur Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}'
          String
e <- ParsecT String Int Identity String
expr
          pure (Char
'}' Char -> String -> String
forall a. a -> [a] -> [a]
: String
e)

    anyChars :: ParsecT String Int Identity String
anyChars = do
      Char
c <- Parser Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
      String
e <- ParsecT String Int Identity String
expr
      pure (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
e)

autoInterpolation :: Parser RawSegment
autoInterpolation :: Parser RawSegment
autoInterpolation =
  String -> ParsecT String Int Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"##{" ParsecT String Int Identity String
-> Parser RawSegment -> Parser RawSegment
forall a b.
ParsecT String Int Identity a
-> ParsecT String Int Identity b -> ParsecT String Int Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> RawSegment
AutoExpSegment (String -> RawSegment)
-> ParsecT String Int Identity String -> Parser RawSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String Int Identity String
expr) Parser RawSegment -> Parser Char -> Parser RawSegment
forall a b.
ParsecT String Int Identity a
-> ParsecT String Int Identity b -> ParsecT String Int Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}'

verbatimInterpolation :: Parser RawSegment
verbatimInterpolation :: Parser RawSegment
verbatimInterpolation =
  String -> ParsecT String Int Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#{" ParsecT String Int Identity String
-> Parser RawSegment -> Parser RawSegment
forall a b.
ParsecT String Int Identity a
-> ParsecT String Int Identity b -> ParsecT String Int Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> RawSegment
ExpSegment (String -> RawSegment)
-> ParsecT String Int Identity String -> Parser RawSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String Int Identity String
expr) Parser RawSegment -> Parser Char -> Parser RawSegment
forall a b.
ParsecT String Int Identity a
-> ParsecT String Int Identity b -> ParsecT String Int Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}'

interpolations :: Parser RawSegment
interpolations :: Parser RawSegment
interpolations =
  Parser RawSegment -> Parser RawSegment
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser RawSegment
autoInterpolation Parser RawSegment -> Parser RawSegment -> Parser RawSegment
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser RawSegment -> Parser RawSegment
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser RawSegment
verbatimInterpolation

verbatimStep :: Bool -> Parser Bool
verbatimStep :: Bool -> Parser Bool
verbatimStep =
  Parser Bool -> Parser Bool
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (Parser Bool -> Parser Bool)
-> (Bool -> Parser Bool) -> Bool -> Parser Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Bool
True -> Bool
False Bool -> Parser Char -> Parser Bool
forall a b.
a -> ParsecT String Int Identity b -> ParsecT String Int Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser Char
ws Parser Bool -> Parser Bool -> Parser Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Bool
forall {u}. ParsecT String u Identity Bool
basic
    Bool
False -> Parser Bool
forall {u}. ParsecT String u Identity Bool
basic
    where
      basic :: ParsecT String u Identity Bool
basic =
        Bool
False Bool
-> ParsecT String u Identity String
-> ParsecT String u Identity Bool
forall a b.
a -> ParsecT String u Identity b -> ParsecT String u Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ParsecT String u Identity String
-> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"##{") ParsecT String u Identity String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String u Identity String
-> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#{"))
        ParsecT String u Identity Bool
-> ParsecT String u Identity Bool -> ParsecT String u Identity Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
        Bool
False Bool
-> ParsecT String u Identity () -> ParsecT String u Identity Bool
forall a b.
a -> ParsecT String u Identity b -> ParsecT String u Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT String u Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
        ParsecT String u Identity Bool
-> ParsecT String u Identity Bool -> ParsecT String u Identity Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
        Bool -> ParsecT String u Identity Bool
forall a. a -> ParsecT String u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

verbatimWith :: Parser Bool -> Parser String
verbatimWith :: Parser Bool -> ParsecT String Int Identity String
verbatimWith Parser Bool
step =
  Parser Bool
step Parser Bool
-> (Bool -> ParsecT String Int Identity String)
-> ParsecT String Int Identity String
forall a b.
ParsecT String Int Identity a
-> (a -> ParsecT String Int Identity b)
-> ParsecT String Int Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> String -> ParsecT String Int Identity String
forall a. String -> ParsecT String Int Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty verbatim segment"
    Bool
True -> ParsecT String Int Identity String
go
  where
    go :: ParsecT String Int Identity String
go =
      Parser Bool
step Parser Bool
-> (Bool -> ParsecT String Int Identity String)
-> ParsecT String Int Identity String
forall a b.
ParsecT String Int Identity a
-> (a -> ParsecT String Int Identity b)
-> ParsecT String Int Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> String -> ParsecT String Int Identity String
forall a. a -> ParsecT String Int Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
        Bool
True -> do
          Char
h <- Parser Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
          String
t <- ParsecT String Int Identity String
go
          pure (Char
h Char -> String -> String
forall a. a -> [a] -> [a]
: String
t)

verbatim :: Parser String
verbatim :: ParsecT String Int Identity String
verbatim =
  Parser Bool -> ParsecT String Int Identity String
verbatimWith (Bool -> Parser Bool
verbatimStep Bool
False)

verbatimWs :: Parser String
verbatimWs :: ParsecT String Int Identity String
verbatimWs =
  Parser Bool -> ParsecT String Int Identity String
verbatimWith (Bool -> Parser Bool
verbatimStep Bool
True)

text :: Parser RawSegment
text :: Parser RawSegment
text =
  String -> RawSegment
StringSegment (String -> RawSegment)
-> ParsecT String Int Identity String -> Parser RawSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String Int Identity String
verbatim

textWs :: Parser RawSegment
textWs :: Parser RawSegment
textWs =
  String -> RawSegment
StringSegment (String -> RawSegment)
-> ParsecT String Int Identity String -> Parser RawSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String Int Identity String
verbatimWs

segment :: Parser RawSegment
segment :: Parser RawSegment
segment =
  Parser RawSegment
interpolations Parser RawSegment -> Parser RawSegment -> Parser RawSegment
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser RawSegment
text

segmentWs :: Parser RawSegment
segmentWs :: Parser RawSegment
segmentWs =
  Parser RawSegment -> Parser RawSegment
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser RawSegment
whitespace Parser RawSegment -> Parser RawSegment -> Parser RawSegment
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser RawSegment
interpolations Parser RawSegment -> Parser RawSegment -> Parser RawSegment
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser RawSegment
textWs

parser :: Parser [RawSegment]
parser :: Parser [RawSegment]
parser =
  Parser RawSegment -> Parser [RawSegment]
forall a.
ParsecT String Int Identity a -> ParsecT String Int Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser RawSegment
segment Parser [RawSegment]
-> ParsecT String Int Identity () -> Parser [RawSegment]
forall a b.
ParsecT String Int Identity a
-> ParsecT String Int Identity b -> ParsecT String Int Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String Int Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

parserWs :: Parser [RawSegment]
parserWs :: Parser [RawSegment]
parserWs =
  Parser RawSegment -> Parser [RawSegment]
forall a.
ParsecT String Int Identity a -> ParsecT String Int Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser RawSegment
segmentWs Parser [RawSegment]
-> ParsecT String Int Identity () -> Parser [RawSegment]
forall a b.
ParsecT String Int Identity a
-> ParsecT String Int Identity b -> ParsecT String Int Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String Int Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

parseWith :: Parser [RawSegment] -> String -> Either Text [RawSegment]
parseWith :: Parser [RawSegment] -> String -> Either Text [RawSegment]
parseWith Parser [RawSegment]
p =
  (ParseError -> Text)
-> Either ParseError [RawSegment] -> Either Text [RawSegment]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Text] -> Text
forall t. IsText t "unwords" => [t] -> t
unwords ([Text] -> Text) -> (ParseError -> [Text]) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall t. IsText t "lines" => t -> [t]
lines (Text -> [Text]) -> (ParseError -> Text) -> ParseError -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> Text
forall b a. (Show a, IsString b) => a -> b
show) (Either ParseError [RawSegment] -> Either Text [RawSegment])
-> (String -> Either ParseError [RawSegment])
-> String
-> Either Text [RawSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [RawSegment]
-> Int -> String -> String -> Either ParseError [RawSegment]
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser Parser [RawSegment]
p Int
0 String
""

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