{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Ltml.Parser.Common.Lexeme
    ( sp
    , sp1
    , lexeme
    , symbol
    , nSc
    , nLexeme
    , nLexeme1
    , lineCommentP
    , isLineCommentPrefixFirstChar
    )
where

import Control.Applicative (empty, optional)
import Control.Monad (void)
import Data.Text (Text)
import Language.Ltml.Parser (MonadParser)
import Text.Megaparsec (takeWhile1P, takeWhileP, (<?>))
import Text.Megaparsec.Char (char)
import qualified Text.Megaparsec.Char.Lexer as L
    ( lexeme
    , skipLineComment
    , space
    , symbol
    )

-- TODO: Use.

-- | Lexeme parser combinator that permits ASCII spaces and line comments, but
--   no newlines.
lexeme :: (MonadParser m) => m a -> m a
lexeme :: forall (m :: * -> *) a. MonadParser m => m a -> m a
lexeme = m () -> m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme (m Text -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m Text
forall (m :: * -> *). MonadParser m => m Text
sp)

symbol :: (MonadParser m) => Text -> m ()
symbol :: forall (m :: * -> *). MonadParser m => Text -> m ()
symbol = m Text -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Text -> m ()) -> (Text -> m Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> Tokens Text -> m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol (m Text -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m Text
forall (m :: * -> *). MonadParser m => m Text
sp)

-- | Space parser (accepts any number of ASCII spaces and, optionally, a final
--   line comment).
sp :: (MonadParser m) => m Text
sp :: forall (m :: * -> *). MonadParser m => m Text
sp = Maybe String -> (Token Text -> Bool) -> m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"space") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
== Char
Token Text
' ') m Text -> m (Maybe ()) -> m Text
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m () -> m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
forall (m :: * -> *). MonadParser m => m ()
lineCommentP

-- | Space parser (accepts one or more ASCII spaces and, optionally, a final
--   line comment).
sp1 :: (MonadParser m) => m Text
sp1 :: forall (m :: * -> *). MonadParser m => m Text
sp1 = Maybe String -> (Token Text -> Bool) -> m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"space") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
== Char
Token Text
' ') m Text -> m (Maybe ()) -> m Text
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m () -> m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
forall (m :: * -> *). MonadParser m => m ()
lineCommentP

-- | Lexeme parser combinator that permits newlines, ASCII spaces, and line
--   comments.
nLexeme :: (MonadParser m) => m a -> m a
nLexeme :: forall (m :: * -> *) a. MonadParser m => m a -> m a
nLexeme = m () -> m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme m ()
forall (m :: * -> *). MonadParser m => m ()
nSc

-- | Like 'nLexeme', but require at least one newline.
--   Useful for parsers that do not themselves require a final newline.
nLexeme1 :: (MonadParser m) => m a -> m a
nLexeme1 :: forall (m :: * -> *) a. MonadParser m => m a -> m a
nLexeme1 m a
p = m a -> m a
forall (m :: * -> *) a. MonadParser m => m a -> m a
nLexeme (m a
p m a -> m Text -> m a
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m Text
forall (m :: * -> *). MonadParser m => m Text
sp m a -> m Char -> m a
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\n')

nSc :: (MonadParser m) => m ()
nSc :: forall (m :: * -> *). MonadParser m => m ()
nSc =
    m () -> m () -> m () -> m ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
        (m (Tokens Text) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Tokens Text) -> m ()) -> m (Tokens Text) -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> (Token Text -> Bool) -> m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"whitespace") (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '))
        m ()
forall (m :: * -> *). MonadParser m => m ()
lineCommentP
        m ()
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

lineCommentP :: (MonadParser m) => m ()
lineCommentP :: forall (m :: * -> *). MonadParser m => m ()
lineCommentP = Tokens Text -> m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"//" m () -> String -> m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"line comment"

isLineCommentPrefixFirstChar :: Char -> Bool
isLineCommentPrefixFirstChar :: Char -> Bool
isLineCommentPrefixFirstChar Char
'/' = Bool
True
isLineCommentPrefixFirstChar Char
_ = Bool
False