Lambda.hs

import Data.Char (isLetter, isNumber, isSpace)
import Data.List (span, dropWhile, lookup)

type ParseError = String

-- A parser is a function that takes a string and returns a parse error or a
-- pair of the parsed data and the remaining string.
type Parser a = String -> Either ParseError (a, String)

type Context = [(String, Term)]

data Term = Var String
          | Lam String (Term -> Term)
          | App Term Term

instance Show Term where
  show (Var s)        = s
  show (Lam arg body) = "λ" ++ arg ++ "." ++ show (body (Var arg))
  show (App f x)      = "(" ++ (show f) ++ " " ++ (show x) ++ ")"

reduce :: Term -> Term
reduce (App (Lam arg body) x) = reduce (body x)
reduce term                   = term

normalize :: Term -> Term
normalize term = case reduce term of
  (Var name)     -> Var name
  (Lam arg body) -> Lam arg (\x -> normalize (body x))
  (App f x)      -> App (normalize f) (normalize x)

parseChar :: Char -> Parser Char
parseChar target (char:rest)
  | target == char = Right (char, rest)
  | otherwise      = Left ("Bad parse: unexpected " ++ [char])

slurpChar :: Parser Char
slurpChar (x:xs) = Right (x, xs)
slurpChar []     = Left "Bad parse: unexpected end of input"

parseName :: Parser String
parseName = Right . span (\c -> isLetter c || isNumber c)

parseWhitespace :: Parser ()
parseWhitespace s = Right ((), dropWhile isSpace s)

parseLam :: Parser (Context -> Term)
parseLam s = do
  (name, rest)   <- parseName s
  (_, rest')     <- parseChar '.' rest
  (body, rest'') <- parseTerm rest'
  return ((\ctx -> Lam name (\x -> body((name, x):ctx))), rest'')

parseApp :: Parser (Context -> Term)
parseApp s = do
  (f, rest)    <- parseTerm s
  (arg, rest') <- parseTerm rest
  (_, rest'')  <- parseChar ')' rest'
  return ((\ctx -> App (f ctx) (arg ctx)), rest'')

parseBoundName :: Parser (Context -> Term)
parseBoundName s = do
  (name, rest) <- parseName s
  return
    (
      (\ctx -> case lookup name ctx of
          Just value -> value
          Nothing    -> error ("Unknown variable " ++ name)),
      rest
    )

parseTerm :: Parser (Context -> Term)
parseTerm s = do
  ((), rest)    <- parseWhitespace s
  (char, rest') <- slurpChar rest
  case char of
    'λ' -> parseLam rest'
    '(' -> parseApp rest'
    _   -> parseBoundName (char:rest')
  

parse :: Parser Term
parse s = do
  (termFunction, rest) <- parseTerm s
  return $ (termFunction [], rest)

printTerm :: Term -> IO ()
printTerm = print . normalize

main :: IO ()
main =
  let term = "(λf.λx.(f (f x)) λg.λy.(g (g y)))"
  in case parse term of
    Left parseError   -> putStrLn parseError
    Right (result, _) -> printTerm result