{-# LANGUAGE OverloadedStrings #-}

module Wave.Parser where

import Control.Arrow (left)
import Control.Monad
import qualified Data.Text as T
import Data.Void (Void)
import qualified Text.Megaparsec ((<?>))
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import qualified Text.Megaparsec.Char.Lexer as L
import Wave.Ast

type Parser = P.Parsec Void T.Text

type Ann = P.SourcePos

runParser :: Parser a -> FilePath -> T.Text -> Either T.Text a
runParser :: Parser a -> FilePath -> Text -> Either Text a
runParser Parser a
p FilePath
file Text
src =
  let withEof :: Parser a
withEof = Parser a
p Parser a -> ParsecT Void Text Identity () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof
      parsed :: Either (ParseErrorBundle Text Void) a
parsed = Parser a
-> FilePath -> Text -> Either (ParseErrorBundle Text Void) a
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
P.runParser Parser a
withEof FilePath
file Text
src
   in (ParseErrorBundle Text Void -> Text)
-> Either (ParseErrorBundle Text Void) a -> Either Text a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (FilePath -> Text
T.pack (FilePath -> Text)
-> (ParseErrorBundle Text Void -> FilePath)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> FilePath
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
P.errorBundlePretty) Either (ParseErrorBundle Text Void) a
parsed

parseLit :: Parser Lit
parseLit :: Parser Lit
parseLit =
  [Parser Lit] -> Parser Lit
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice
    [ Text -> Lit
LString (Text -> Lit) -> ParsecT Void Text Identity Text -> Parser Lit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
stringLiteral,
      Parser Lit
numberLiteral
    ]

sc :: Parser ()
sc :: ParsecT Void Text Identity ()
sc =
  ParsecT Void Text Identity ()
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
P.hspace1
    (Tokens Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"//")
    (Tokens Text -> Tokens Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockCommentNested Tokens Text
"/*" Tokens Text
"*/")

lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme = ParsecT Void Text Identity () -> Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme ParsecT Void Text Identity ()
sc

symbol :: T.Text -> Parser ()
symbol :: Text -> ParsecT Void Text Identity ()
symbol = ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity ()
-> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol ParsecT Void Text Identity ()
sc

stringLiteral :: Parser T.Text
stringLiteral :: ParsecT Void Text Identity Text
stringLiteral =
  (FilePath -> Text)
-> ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
T.pack (ParsecT Void Text Identity FilePath
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'\"' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity FilePath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity FilePath
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.manyTill ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'\"')

numberLiteral :: Parser Lit
numberLiteral :: Parser Lit
numberLiteral = do
  Maybe Char
sign <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity (Maybe Char))
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'-'
  FilePath
int <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.digitChar
  Maybe FilePath
dec <- ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity (Maybe FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (ParsecT Void Text Identity FilePath
 -> ParsecT Void Text Identity (Maybe FilePath))
-> ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'.' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity FilePath
-> ParsecT Void Text Identity FilePath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.digitChar
  case Maybe FilePath
dec of
    Maybe FilePath
Nothing -> Lit -> Parser Lit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lit -> Parser Lit) -> Lit -> Parser Lit
forall a b. (a -> b) -> a -> b
$ Int -> Lit
LInt (FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> (Char -> FilePath) -> Maybe Char -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Char -> FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Char
sign FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
int)
    Just FilePath
n -> Lit -> Parser Lit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lit -> Parser Lit) -> Lit -> Parser Lit
forall a b. (a -> b) -> a -> b
$ Float -> Lit
LFloat (FilePath -> Float
forall a. Read a => FilePath -> a
read (FilePath -> Float) -> FilePath -> Float
forall a b. (a -> b) -> a -> b
$ FilePath -> (Char -> FilePath) -> Maybe Char -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Char -> FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Char
sign FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
int FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
n)

-- Utils

getAnn :: Parser Ann
getAnn :: Parser Ann
getAnn = Parser Ann
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m Ann
P.getSourcePos