{-|
Module      : Text.SExpression.Internal
Description : Internal parser functions
Copyright   : (C) Richard Cook, 2019
Licence     : MIT
Maintainer  : rcook@rcook.org
Stability   : stable
Portability : portable

This module provides internal parser functions.
-}

{-# OPTIONS_GHC -Wall -Werror #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

#undef MEGAPARSEC_7_OR_LATER
#ifdef MIN_VERSION_GLASGOW_HASKELL
-- GHC >= 7.10.1.0
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
-- GHC >= 8.0.0.0
#if MIN_VERSION_megaparsec(7,0,0)
#define MEGAPARSEC_7_OR_LATER
#endif
#endif
#endif

module Text.SExpression.Internal
    ( -- * S-expression parser
      parseSExpr
    , -- * S-expression value parsers
      parseAtom
    , parseConsList
    , parseList
    , parseQuoted
    , parseStringDef
    , parseNumberDef
    , parseBoolDef
    , mkLiteralParsers
    , overrideBoolP
    , overrideNumberP
    , overrideStringP
    ) where

import Control.Applicative (empty)
import Control.Monad (void)
import Text.Megaparsec
    ( (<|>)
    , endBy
    , many
#ifdef MEGAPARSEC_7_OR_LATER
    , oneOf
#endif
    , sepBy
    , try
    )
import Text.Megaparsec.Char
    ( char
    , digitChar
    , letterChar
#ifndef MEGAPARSEC_7_OR_LATER
    , oneOf
#endif
    , space1
    )
import Text.Megaparsec.Char.Lexer
    ( space
    , skipLineComment
    )
import Text.SExpression.Types (Parser, SExpr(..))
import Text.SExpression.Default

sc :: Parser ()
sc :: Parser ()
sc = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
space Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 Parser ()
lineComment Parser ()
forall (f :: * -> *) a. Alternative f => f a
empty
    where
        lineComment :: Parser ()
lineComment = Tokens [Char] -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
skipLineComment [Char]
Tokens [Char]
";"

symbol :: Parser Char
symbol :: Parser Char
symbol = [Token [Char]] -> ParsecT Void [Char] Identity (Token [Char])
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char]
[Token [Char]]
"!$%&|*+-/:<=>?@^_~#"

-- | S-expression parser
parseSExpr ::
    LiteralParsers ->
    Parser SExpr    -- ^ parser
parseSExpr :: LiteralParsers -> Parser SExpr
parseSExpr lp :: LiteralParsers
lp@(LiteralParsers{Parser SExpr
parseBool :: LiteralParsers -> Parser SExpr
parseNumber :: LiteralParsers -> Parser SExpr
parseString :: LiteralParsers -> Parser SExpr
parseBool :: Parser SExpr
parseNumber :: Parser SExpr
parseString :: Parser SExpr
..}) =
    Parser SExpr -> Parser SExpr
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser SExpr
parseBool
    Parser SExpr -> Parser SExpr -> Parser SExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser SExpr
parseAtom
    Parser SExpr -> Parser SExpr -> Parser SExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser SExpr
parseString
    Parser SExpr -> Parser SExpr -> Parser SExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser SExpr
parseNumber
    Parser SExpr -> Parser SExpr -> Parser SExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LiteralParsers -> Parser SExpr
parseQuoted LiteralParsers
lp
    Parser SExpr -> Parser SExpr -> Parser SExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
            Parser Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Char -> Parser ()) -> Parser Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ Token [Char] -> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token [Char]
'('
            SExpr
lst <- (Parser SExpr -> Parser SExpr
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser SExpr -> Parser SExpr) -> Parser SExpr -> Parser SExpr
forall a b. (a -> b) -> a -> b
$ LiteralParsers -> Parser SExpr
parseList LiteralParsers
lp) Parser SExpr -> Parser SExpr -> Parser SExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LiteralParsers -> Parser SExpr
parseConsList LiteralParsers
lp
            Parser () -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Token [Char] -> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token [Char]
')' Parser Char -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
sc
            SExpr -> Parser SExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure SExpr
lst

-- | Parse s-expression atom
parseAtom ::
    Parser SExpr    -- ^ parser
parseAtom :: Parser SExpr
parseAtom = do
    Char
h <- Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
symbol
    [Char]
t <- Parser Char -> ParsecT Void [Char] Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
symbol)
    SExpr -> Parser SExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr -> Parser SExpr)
-> ([Char] -> SExpr) -> [Char] -> Parser SExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> SExpr
Atom ([Char] -> Parser SExpr) -> [Char] -> Parser SExpr
forall a b. (a -> b) -> a -> b
$ Char
h Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
t


-- | Parse s-expression list
parseList ::
    LiteralParsers ->
    Parser SExpr    -- ^ parser
parseList :: LiteralParsers -> Parser SExpr
parseList LiteralParsers
lp =
    [SExpr] -> SExpr
List ([SExpr] -> SExpr)
-> ParsecT Void [Char] Identity [SExpr] -> Parser SExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LiteralParsers -> Parser SExpr
parseSExpr LiteralParsers
lp Parser SExpr -> Parser () -> ParsecT Void [Char] Identity [SExpr]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Parser ()
sc

-- | Parse s-expression cons list
parseConsList ::
    LiteralParsers ->
    Parser SExpr    -- ^ parser
parseConsList :: LiteralParsers -> Parser SExpr
parseConsList LiteralParsers
lp = do
    [SExpr]
h <- LiteralParsers -> Parser SExpr
parseSExpr LiteralParsers
lp Parser SExpr -> Parser () -> ParsecT Void [Char] Identity [SExpr]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`endBy` Parser ()
sc
    SExpr
t <- Token [Char] -> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token [Char]
'.' Parser Char -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
sc Parser () -> Parser SExpr -> Parser SExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LiteralParsers -> Parser SExpr
parseSExpr LiteralParsers
lp
    SExpr -> Parser SExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SExpr -> Parser SExpr) -> SExpr -> Parser SExpr
forall a b. (a -> b) -> a -> b
$ [SExpr] -> SExpr -> SExpr
ConsList [SExpr]
h SExpr
t

-- | Parse s-expression quoted expression
parseQuoted ::
    LiteralParsers ->
    Parser SExpr    -- ^ parser
parseQuoted :: LiteralParsers -> Parser SExpr
parseQuoted LiteralParsers
lp = do
    Parser Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Char -> Parser ()) -> Parser Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ Token [Char] -> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token [Char]
'\''
    SExpr
e <- LiteralParsers -> Parser SExpr
parseSExpr LiteralParsers
lp
    SExpr -> Parser SExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SExpr -> Parser SExpr) -> SExpr -> Parser SExpr
forall a b. (a -> b) -> a -> b
$ [SExpr] -> SExpr
List [[Char] -> SExpr
Atom [Char]
"quote", SExpr
e]