Lambda calculus interpreter (with atoms, integers, bifs & ability to force a value calculation) to play with.

AST.hs

module AST where

data AST
    = [Name] :=> AST
    |  Name  :?  AST
    | App  [AST]
    | Atom  String
    | Const Integer
    | Force AST
    | Var   Name
    | BIF   Name

type Name = String

Eval.hs

{-# LANGUAGE LambdaCase, ViewPatterns #-}

module Eval where

import Control.Applicative hiding (Const)

----

import AST

eval :: AST -> IO AST
eval body
    | stump body = return body

eval body = case body of
    []    :=> ast         -> return ast
    label :?  ast         -> return ast
    
    App  [item]           -> return item
    App  (a : b : rest)   -> (App . (: rest)) <$> a <== b 
    
    Force ast | stump ast -> return ast

    Force ast             -> Force <$> eval ast

    Var   name            -> fail $ "free var " ++ name
    
stump = \case
    (_:_) :=> _ -> True
    Atom      _ -> True
    Const     _ -> True
    other       -> False

-- a <== b | stump a = fail $ "<" ++ show a ++ "> is not a valid target to pass <" ++ show b ++ ">"
a <== b           = case a of
    BIF bif               -> fail "bifs aren't supported yet"

    (name : args) :=> ast -> inject name b (args :=> ast)

    other                 -> (<== b) =<< eval a

inject name arg = \case
    args :=> ast 
        | name `elem` args -> return $ args :=> ast
        | otherwise        -> (args :=>) <$> inject name arg ast

    label :? ast           -> (label :?) <$> inject name arg ast

    App items              -> App <$> mapM (inject name arg) items

    Force ast              -> Force <$> inject name arg ast

    Var n | n == name      -> return $ arg
    Var n                  -> return $ Var n

    other                  -> return   other

Lang0.hs

module Lang0 where

import Control.Applicative           hiding (many, (<|>), Const)

import Text.ParserCombinators.Parsec

----

import AST

load :: String -> IO AST
load file = do
    text <- readFile file

    case parse program file text of
        Left err -> error (show err)
        Right a  -> return a

program :: Parser AST
program = app 

app :: Parser AST
app = do
    objects <- point `sepEndBy1` spaces

    return $ case length objects of
        1 -> head objects
        _ -> App  objects

point :: Parser AST
point = var 
    <|> bif
    <|> atom
    <|> constant
    <|> forced
    <|> lambda 
    <|> "()" `bracketed` program

forced, atom, bif, var, constant :: Parser AST

forced   = do char '!'; Force <$> "()" `bracketed` program
atom     = do char ':'; Atom  <$> name
bif      = do char '#'; BIF   <$> name
var      =              Var   <$> name
constant =     (Const . read) <$> many1 digit

name :: Parser Name
name = (:) 
    <$>       letter 
    <*> many (letter <|> digit <|> char '-')

lambda :: Parser AST
lambda = do
    char '\\'
    spaces

    args <- name `sepEndBy1` spaces

    string "->"
    spaces

    (args :=>) <$> program

----

[l, r] `bracketed` parser = char l *> parser <* char r  

Main.hs

import AST
import PP
import Lang0
import Eval

main = putStrLn . pretty =<< eval =<< load "test.lc"

PP.hs

{-# LANGUAGE LambdaCase #-}

module PP where

import Data.String.Utils

----

import AST

data ShowConf
    = Init
    | Tail
    | Inside
    | LambdaBody

    deriving Eq

bracket f x = if f then "(" ++ x ++ ")" else x

instance Show AST where
    show = pretty

pretty = prettyShow LambdaBody

prettyShow :: ShowConf -> AST -> String
prettyShow conf = \case
    args  :=> body -> case body of
        -- joining lambdas
        args2 :=> body ->
            prettyShow conf $ (args ++ args2) :=> body

        -- 
        other -> bracket (conf /= Tail) $
            "\\" ++ join " " args ++ " -> " ++ pretty body 

    label :? _program -> 
        label ++ ".."

    App [item] ->
        prettyShow conf item

    App items -> case head items of
        App subs -> 
            prettyShow conf $ App $ subs ++ tail items

        other -> bracket (conf /= LambdaBody) $

            let (h : rest)  = items
                (t, center) = (last rest, init rest)

                start       = prettyShow Init h
                end         = prettyShow Tail t
                between     = prettyShow Inside `map` center

            in 
                join " " $ start : between ++ [end]

    Atom  atom      -> ':' : atom
    Const int       -> show int
    Force program   -> "!(" ++ (pretty program) ++ ")"
    Var   name      -> name
    BIF   name      -> '#' : name

test.lc

(\let -> 

    let (\a b def f -> f a (b def f)) \cons   ->
    let (\    def f ->        def   ) \nil    ->

    let (\as bs     -> as bs cons)    \append ->

    let (\a b       -> a)             \head   ->

    let (\test      -> test nil \a b -> append b (cons a nil)) \reverse ->

    let (\as def    -> reverse as def head) \last ->

    let (cons :FIRST (cons :SECOND (cons :THIRD nil))) \test ->

    last test :NONE

)
\x env -> env x