-- | A @megaparsec@ implementation of a parser for 'Shower'.
module Shower.Parser (pShower) where

import Data.Void
import Data.Char
import Text.Megaparsec
import Text.Megaparsec.Char

import Shower.Class

type Parser = Parsec Void String

pLexeme :: Parser a -> Parser a
pLexeme :: forall a. Parser a -> Parser a
pLexeme Parser a
p = Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

-- | Parser for 'Shower' expressions.
pShower :: Shower a => Parsec Void String a
pShower :: forall a. Shower a => Parsec Void String a
pShower = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Shower a => Parsec Void String a
pExpr

pExpr :: Shower a => Parser a
pExpr :: forall a. Shower a => Parsec Void String a
pExpr = forall a. Shower a => [a] -> a
showerSpace forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a. Shower a => Parsec Void String a
pPart

pCommaSep :: Parser a -> Parser [ShowerComma a]
pCommaSep :: forall a. Parser a -> Parser [ShowerComma a]
pCommaSep Parser a
p = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$
  forall a. ShowerComma a
ShowerCommaSep forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Parser a -> Parser a
pLexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
',') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall a. a -> ShowerComma a
ShowerCommaElement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p

pPart :: Shower a => Parser a
pPart :: forall a. Shower a => Parsec Void String a
pPart =
  forall a. Shower a => Parsec Void String a
pRecord forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall a. Shower a => Parsec Void String a
pList forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall a. Shower a => Parsec Void String a
pTuple forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall a. Shower a => Parsec Void String a
pStringLit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall a. Shower a => Parsec Void String a
pCharLit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall a. Shower a => String -> Parser a
pAtom String
"()[]{},="

pRecord :: Shower a => Parser a
pRecord :: forall a. Shower a => Parsec Void String a
pRecord = do
  Token String
_ <- forall a. Parser a -> Parser a
pLexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'{')
  [ShowerComma (a, ShowerFieldSep, a)]
fields <- forall a. Parser a -> Parser [ShowerComma a]
pCommaSep forall a. Shower a => Parser (a, ShowerFieldSep, a)
pField
  Token String
_ <- forall a. Parser a -> Parser a
pLexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'}')
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Shower a => [ShowerComma (a, ShowerFieldSep, a)] -> a
showerRecord [ShowerComma (a, ShowerFieldSep, a)]
fields)

pFieldName :: Shower a => Parser a
pFieldName :: forall a. Shower a => Parsec Void String a
pFieldName =
  forall a. Shower a => Parsec Void String a
pStringLit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall a. Shower a => String -> Parser a
pAtom String
"()[]{},=:"

pField :: Shower a => Parser (a, ShowerFieldSep, a)
pField :: forall a. Shower a => Parser (a, ShowerFieldSep, a)
pField = do
  a
name <- forall a. Shower a => Parsec Void String a
pFieldName
  ShowerFieldSep
sep <- forall a. Parser a -> Parser a
pLexeme forall a b. (a -> b) -> a -> b
$
    ShowerFieldSep
ShowerFieldSepEquals forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'=' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    ShowerFieldSep
ShowerFieldSepColon  forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':'
  a
value <- forall a. Shower a => Parsec Void String a
pExpr
  forall (m :: * -> *) a. Monad m => a -> m a
return (a
name, ShowerFieldSep
sep, a
value)

pList :: Shower a => Parser a
pList :: forall a. Shower a => Parsec Void String a
pList = do
  Token String
_ <- forall a. Parser a -> Parser a
pLexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'[')
  [ShowerComma a]
elements <- forall a. Parser a -> Parser [ShowerComma a]
pCommaSep forall a. Shower a => Parsec Void String a
pExpr
  Token String
_ <- forall a. Parser a -> Parser a
pLexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
']')
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Shower a => [ShowerComma a] -> a
showerList [ShowerComma a]
elements)

pTuple :: Shower a => Parser a
pTuple :: forall a. Shower a => Parsec Void String a
pTuple = do
  Token String
_ <- forall a. Parser a -> Parser a
pLexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'(')
  [ShowerComma a]
elements <- forall a. Parser a -> Parser [ShowerComma a]
pCommaSep forall a. Shower a => Parsec Void String a
pExpr
  Token String
_ <- forall a. Parser a -> Parser a
pLexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
')')
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Shower a => [ShowerComma a] -> a
showerTuple [ShowerComma a]
elements)

pQuotedLit :: Char -> Parser String
pQuotedLit :: Char -> Parser String
pQuotedLit Char
quote =
  forall a. Parser a -> Parser a
pLexeme forall a b. (a -> b) -> a -> b
$ do
    Token String
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
quote
    [String]
s <- forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill Parser String
pSymbol (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
quote)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
s)
  where
    pSymbol :: Parser String
pSymbol =
      forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string [Char
'\\', Char
'\\']  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string [Char
'\\', Char
quote] forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      ((forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle)

pStringLit :: Shower a => Parser a
pStringLit :: forall a. Shower a => Parsec Void String a
pStringLit = forall a. Shower a => String -> a
showerStringLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser String
pQuotedLit Char
'"'

pCharLit :: Shower a => Parser a
pCharLit :: forall a. Shower a => Parsec Void String a
pCharLit = forall a. Shower a => String -> a
showerCharLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser String
pQuotedLit Char
'\''

pAtom :: Shower a => [Char] -> Parser a
pAtom :: forall a. Shower a => String -> Parser a
pAtom String
disallowed =
  forall a. Parser a -> Parser a
pLexeme forall a b. (a -> b) -> a -> b
$ do
    String
s <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
atomChar)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Shower a => String -> a
showerAtom String
s)
  where
    atomChar :: Char -> Bool
atomChar Char
c =
      Bool -> Bool
not (Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
disallowed) Bool -> Bool -> Bool
&&
      Bool -> Bool
not (Char -> Bool
isSpace Char
c)