[ MIRROR ] An interpreter for a Lisp-like language git.ngill.net/nls.git
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101{-# LANGUAGE OverloadedStrings #-}
module Parser ( Parser.parse, )where
import qualified Data.Text as Timport Text.Megaparsecimport Text.Megaparsec.Charimport qualified Text.Megaparsec.Char.Lexer as Limport Types
newtype Error = Error T.Text deriving (Show, Eq, Ord)
type Input = T.Text
instance ShowErrorComponent Error where showErrorComponent (Error e) = T.unpack e
type NlsParser a = Parsec Error Input a
sc :: NlsParser ()sc = L.space space1 lineComment empty
lineComment :: NlsParser ()lineComment = L.skipLineComment (T.pack "#")
lexeme :: NlsParser a -> NlsParser alexeme = L.lexeme sc
symbol :: T.Text -> NlsParser T.Textsymbol = L.symbol sc
-- split a string with character delimitersplitOn :: Char -> String -> [String]splitOn c str = case break (== c) str of (before, []) -> [before] (before, _ : after) -> before : splitOn c after
-- make `get` astmakeGet :: NlsAstValue -> String -> NlsAstValuemakeGet acc key = AList [ASymbol "get", acc, AString key]
-- desugar dotted expr into `get` sequencedesugarDotted :: String -> NlsAstValuedesugarDotted s = case splitOn '.' s of [] -> AString s -- this should never happen (x : xs) -> foldl makeGet (ASymbol x) xs
parseSymbol :: NlsParser NlsAstValueparseSymbol = do first <- letterChar <|> oneOf ("!$%&|*+-/:<=>?@^_~" :: String) rest <- many (alphaNumChar <|> oneOf ("!$%&|*+-/:<=>?@^_~." :: String)) let sym = first : rest if elem '.' sym then pure $ desugarDotted sym else pure $ ASymbol sym
parseQuote :: NlsParser NlsAstValueparseQuote = do _ <- char '\'' v <- parseValue pure $ AList [ASymbol "quote", v]
parseEval :: NlsParser NlsAstValueparseEval = do _ <- char '!' v <- parseValue pure $ AList [ASymbol "eval", v]
parseNumber :: NlsParser NlsAstValueparseNumber = ANumber <$> lexeme L.decimal
parseString :: NlsParser NlsAstValueparseString = AString <$> lexeme (char '"' >> manyTill L.charLiteral (char '"'))
parseList :: NlsParser NlsAstValueparseList = AList <$> between (symbol "(") (symbol ")") (many parseValue)
parseValue :: NlsParser NlsAstValueparseValue = lexeme $ parseEval <|> parseQuote <|> parseNumber <|> parseString <|> parseSymbol <|> parseList
parseProgram :: NlsParser [NlsAstValue]parseProgram = between sc eof (many parseValue)
parse :: Input -> Either T.Text [NlsAstValue]parse input = case runParser parseProgram "" input of Left err -> Left $ T.pack $ errorBundlePretty err Right val -> Right val