{-# OPTIONS_GHC -Wall -Werror #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
#undef MEGAPARSEC_7_OR_LATER
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
#if MIN_VERSION_megaparsec(7,0,0)
#define MEGAPARSEC_7_OR_LATER
#endif
#endif
#endif
module Text.SExpression.Internal
(
parseSExpr
,
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 = space space1 lineComment empty
where
lineComment = skipLineComment ";"
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~#"
parseSExpr ::
LiteralParsers ->
Parser SExpr
parseSExpr lp@(LiteralParsers{..}) =
try parseBool
<|> parseAtom
<|> parseString
<|> parseNumber
<|> parseQuoted lp
<|> do
void $ char '('
lst <- (try $ parseList lp) <|> parseConsList lp
void $ char ')' >> sc
pure lst
parseAtom ::
Parser SExpr
parseAtom = do
h <- letterChar <|> symbol
t <- many (letterChar <|> digitChar <|> symbol)
return . Atom $ h : t
parseList ::
LiteralParsers ->
Parser SExpr
parseList lp =
List <$> parseSExpr lp `sepBy` sc
parseConsList ::
LiteralParsers ->
Parser SExpr
parseConsList lp = do
h <- parseSExpr lp `endBy` sc
t <- char '.' >> sc >> parseSExpr lp
pure $ ConsList h t
parseQuoted ::
LiteralParsers ->
Parser SExpr
parseQuoted lp = do
void $ char '\''
e <- parseSExpr lp
pure $ List [Atom "quote", e]