LispEval.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import           Control.Applicative
import           Data.Attoparsec.Text
import           Data.Char            (isLetter)
import qualified Data.Map.Strict      as M
import           Data.Text            hiding (foldr, zipWith)

{-
from https://ccrma.stanford.edu/courses/124/resources/Basic%20Lisp%20Primitives.htm
(+ number &rest numbers) (- number &rest numbers) (* number &rest numbers) (/ number &rest numbers)

(= number &rest numbers) (< number &rest numbers) (> number &rest numbers) (<= number &rest numbers) (>= number &rest numbers)
-}

data Expr = Lit Integer -- does not handle negative numbers!
          | Lambda [Var] Expr -- (lambda x (+ x x))
          | Variable Var -- x from above line
          | Apply Expr [Expr]
            deriving Show

type Var = Text
-- there must be some way to factor out this code to make it simpler, not sure how
-- real lisp handles any number of args, pExpr `sepBy` char ' ' ?
pExpr :: Parser Expr
pExpr = Lit <$> decimal -- does not handle negative numbers
        <|> Lambda <$ char '(' <* string "lambda" <* space <* char '(' <*>  (pVar `sepBy` space) <* char ')' <* space <*> pExpr <* char ')'
        <|> Variable <$> pVar
            -- why doesn't this same thing work for Add, etc?
        <|> Apply <$ char '(' <*> pExpr <* space <*> (pExpr `sepBy` space) <* char ')'
            where exprs = many (space *> pExpr)
                  left c = char '(' <* char c <* space

pVar = takeWhile1 (not . (`elem` [' ','(' , ')'] ++ "1234567890"))

type Context = M.Map Var Expr

pEval :: Context -> Expr -> Expr
pEval _ l@(Lit _) = l
pEval c (Variable v) = case M.lookup v c of
                         Just v' -> v'
                         Nothing -> (Variable v)
pEval c (Lambda vs e) = Lambda vs (pEval (shadow c vs) e)
    where shadow c vs = foldr M.delete c vs
pEval c (Apply f args) = case (pEval c f,pEval c <$> args) of
                          (Lambda vs body,args') -> pEval (foldr ($) c (zipWith M.insert vs args')) body
                          (f',args')            -> Apply f' args'