lisp_parser.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Data.Text (Text)
import System.Environment
import System.Exit
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Attoparsec.Text
import Data.Char (isSpace)
import Control.Applicative ((<|>))

main :: IO ()
main = do
  args <- getArgs
  case args of
    [filename] -> do
      contents <- T.readFile filename
      parseAndRun contents
    _ -> exitFailure

parseAndRun :: Text -> IO ()
parseAndRun source = case parseOnly (parser <* endOfInput) source of
                       Left err -> do
                         putStrLn $ "parseAndRun error: " ++ err
                         exitFailure
                       Right ast -> do
                         eval ast
                         return ()

-- | AST

data Expr = IntLit Integer
          | Call Id [Expr]
          deriving (Show)

data Value = IntVal Integer
           | Nil

instance Show Value where
  show Nil = "nil"
  show (IntVal i) = show i

type Id = Text

-- | Parse

parser :: Parser Expr
parser = parseExpr

parseExpr :: Parser Expr
parseExpr =
  try integerLiteral
  <|> parens call

  where
    integerLiteral = do
      int <- lexeme decimal
      return $ IntLit int

    call = do
      identifier <- lexeme $ takeTill isSpace
      xs <- many' parseExpr
      return $ Call identifier xs

lexeme :: Parser a -> Parser a
lexeme p = p <* skipSpace

parens :: Parser a -> Parser a
parens p = symbol "(" *> p <* symbol ")"

symbol :: Text -> Parser Text
symbol s = lexeme (string s)

-- | Interpret

eval :: Expr -> IO Value
eval (IntLit i) = return $ IntVal i

eval (Call "+" args) = do
  args' <- mapM (fmap valueToNum . eval) args
  return $ IntVal $ sum args'

eval (Call "print" args) = do
  printable <- mapM eval args
  mapM_ print printable
  return Nil

eval (Call name _) = error $ "Unknown identifier " ++ show name

valueToNum :: Value -> Integer
valueToNum (IntVal i) = i
valueToNum Nil = 0