{-# OPTIONS_GHC -Wall -Werror #-}
{-# LANGUAGE CPP #-}
#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
, parseNumber
, parseQuoted
, parseString
) where
import Control.Applicative (empty)
import Control.Monad (void)
import Text.Megaparsec
( (<|>)
, endBy
, many
#ifdef MEGAPARSEC_7_OR_LATER
, noneOf
, oneOf
#endif
, sepBy
, some
, try
)
import Text.Megaparsec.Char
( char
, digitChar
, letterChar
#ifndef MEGAPARSEC_7_OR_LATER
, noneOf
, oneOf
#endif
, space1
)
import Text.Megaparsec.Char.Lexer
( space
, skipLineComment
)
import Text.SExpression.Types (Parser, SExpr(..))
sc :: Parser ()
sc = space space1 lineComment empty
where
lineComment = skipLineComment ";"
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~#"
parseSExpr ::
Parser SExpr
parseSExpr =
parseAtom
<|> parseString
<|> parseNumber
<|> parseQuoted
<|> do
void $ char '('
lst <- (try parseList) <|> parseConsList
void $ char ')' >> sc
pure lst
parseAtom ::
Parser SExpr
parseAtom = do
h <- letterChar <|> symbol
t <- many (letterChar <|> digitChar <|> symbol)
let s = h : t
pure $ case s of
"#t" -> Bool True
"#f" -> Bool False
_ -> Atom s
parseList ::
Parser SExpr
parseList = List <$> parseSExpr `sepBy` sc
parseConsList ::
Parser SExpr
parseConsList = do
h <- parseSExpr `endBy` sc
t <- char '.' >> sc >> parseSExpr
pure $ ConsList h t
parseNumber ::
Parser SExpr
parseNumber = (Number . read) <$> some digitChar
parseString ::
Parser SExpr
parseString = do
void $ char '"'
s <- many (noneOf "\"")
void $ char '"'
pure $ String s
parseQuoted ::
Parser SExpr
parseQuoted = do
void $ char '\''
e <- parseSExpr
pure $ List [Atom "quote", e]