{-# LANGUAGE OverloadedStrings #-}

-- simple parser for a Lisp-like syntax I wrote some time ago

import Data.Void (Void)

import Data.Text (Text)
import qualified Data.Text as T

import Text.Megaparsec.Char
import Text.Megaparsec.Error (errorBundlePretty)
import Text.Megaparsec hiding (State)
import qualified Text.Megaparsec.Char.Lexer as L

data LispVal
  = Symbol Text
  | List [LispVal]
  | Number Integer
  | String Text
  | LispTrue
  | LispFalse
  | Nil
  deriving (Show, Eq)

type Parser = Parsec Void Text

readStr :: Text -> Either String [LispVal]
readStr t =
  case parse pLisp "f" t of
    Right parsed -> Right parsed
    Left err -> Left $ errorBundlePretty err
{-# INLINABLE readStr #-}

sc :: Parser ()
sc = L.space space1 (L.skipLineComment ";") empty
{-# INLINABLE sc #-}

lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
{-# INLINE lexeme #-}

symbol :: Text -> Parser Text
symbol = L.symbol sc
{-# INLINE symbol #-}

symbol' :: Text -> Parser Text
symbol' = L.symbol' sc
{-# INLINE symbol' #-}

pNil :: Parser LispVal
pNil = symbol' "nil" >> return Nil
{-# INLINE pNil #-}

integer :: Parser Integer
integer = lexeme L.decimal
{-# INLINE integer #-}

lispSymbols :: Parser Char
lispSymbols = oneOf ("#$%&|*+-/:<=>?@^_~" :: String)
{-# INLINE lispSymbols #-}

pLispVal :: Parser LispVal
pLispVal = choice [pList, pNumber, pSymbol, pNil, pString]
{-# INLINE pLispVal #-}

pSymbol :: Parser LispVal
pSymbol = (Symbol . T.pack <$> lexeme (some (letterChar <|> lispSymbols)))
{-# INLINABLE pSymbol #-}

pList :: Parser LispVal
pList = List <$> between (symbol "(") (symbol ")") (many pLispVal)
{-# INLINABLE pList #-}

pLisp :: Parser [LispVal]
pLisp = some pLispVal
{-# INLINE pLisp #-}

pNumber :: Parser LispVal
pNumber = Number <$> integer
{-# INLINE pNumber #-}

pString :: Parser LispVal
pString = do
  str <- char '\"' *> manyTill L.charLiteral (char '\"')
  return $ String (T.pack str)
{-# INLINABLE pString #-}