.Lambda Calculus Interpreter

-

Ast.hs

module Ast where

import Ast.Scope

data Blob =
     Blob { tree  :: AST
          , scope :: Scope }

data AST =
     Val { _val   :: Value  }
   | Var { _var   :: String }
   | Fun { _arg   :: String 
         , _body  :: Blob   }
   | App { _f, _x :: Blob   }

   | Force { _body :: Blob }

   deriving Eq

data Value =
     Constant { _constant   :: Integer      }
   | Atom     { _atom       :: String       }
   | BIF      { _human_name :: String
              , _action     :: Blob -> IO Blob }

knows = Blob

Blob _ scope `does_know`    name =      name `inside` scope
Blob _ scope `doesn't_know` name = not (name `inside` scope)

calculate_scopes (Blob tree _) =
  case tree of
       Val _         -> tree `knows` nothing
       Var name      -> tree `knows` single name
       Fun name body -> tree `knows` (scope (calculate_scopes body) `except` name)
       Force    body -> tree `knows`  scope (calculate_scopes body)
       App f    x    -> tree `knows` (scope (calculate_scopes f) 
                               `join` scope (calculate_scopes x))

force :: Blob -> IO Blob
force blob | stump (blob) = return blob
           | otherwise    = do trunk <- chop blob
                               force trunk

stump (Blob tree _) =
  case tree of
       Val _   -> True
       Fun _ _ -> True
       App _ _ -> False
       Force _ -> False

chop (Blob (App f x) _) = reduce f x
chop (Blob (Force x) _) = chop x

reduce (Blob f scope) x =
  case f of
       Val (BIF _ f) -> f x
       Fun arg body  -> (arg ==> x) body
       App f y       -> do g <- reduce f y
                           return $ (g `App` x) `knows` scope
       
       other         -> error $ show (Blob other scope)

(==>) :: String -> Blob -> Blob -> IO Blob
(formal ==> factical) blob = descent blob
  where 
    descent blob @ (Blob tree scope)
      | blob `doesn't_know` formal = return blob
      | otherwise =
          let erased_scope = scope `except` formal 
          in case tree of
                  Var name 
                    | name == formal -> case factical of
                                             Blob (Force body) _ -> force body
                                             other               -> return other

                    | otherwise      -> return blob

                  Fun arg body 
                    | arg == formal  -> return blob
                    | otherwise      -> do down <- descent body
                                           return $ Fun arg down 
                                                     `knows` erased_scope

                  App f x            -> do down_f <- descent f
                                           down_x <- descent x
                                           return $
                                             (down_f `App` down_x) 
                                              `knows` erased_scope

                  Force body         -> do down <- descent body
                                           return $ Force down
                                              `knows` erased_scope

calculate_clean tree = calculate_scopes (tree `knows` nothing)

fun arg body = calculate_clean (Fun arg body)
enforce body = calculate_clean (Force body)
var name     = calculate_clean (Var name)
constant c   = calculate_clean (Val (Constant c))
atom a       = calculate_clean (Val (Atom     a))
bif n f      = calculate_clean (Val (BIF    n f))
f # x        = calculate_clean (App f x)

funN arglist body = foldr (fun) body arglist

infixl 8 #

instance Show Blob where
  show (Blob tree scope) = 
    concat 
      [ "" -- show scope
      , case tree of
             Val   val  -> show val
             Var   name -> name
             Force body -> "!(" ++ show body ++ ")"
             
             Fun x f  -> concat $ 
               [ "\\"
               , x
               , case f of
                      Blob (Fun _ _) _ -> " "
                      other            -> " -> "
             
               , show f
               ]
             
             App f x  -> concat
               [ case f of
                      Blob (Fun _ _) _ -> concat ["(", show f, ")"]
                      other            ->              show f
             
               , " "
               , case x of
                      Blob (App _ _) _ -> concat ["(", show x, ")"]
                      other            ->              show x
               ]
      ]

instance Show Value where
  show (Constant c) = show c
  show (Atom     a) = ":" ++ a
  show (BIF name _) = "#" ++ name

instance Eq Blob where
  a == b = 
    tree a == tree b

instance Eq Scope where
  Scope a == Scope b = 
    a == b

instance Eq Value where
  Constant a == Constant b =
    a == b

  Atom a == Atom b =
    a == b

  BIF a _ == BIF b _ =
    a == b

  _ == _ = False

Lang0.hs

module Lang0 where

import qualified Stdlib as Lib
import qualified Ast as To

data AST =
     Let    { _name    :: String
            , _body    :: AST
            , _rest    :: AST    }

   | List   { _items   :: [AST]  }

   | Val    { _val     :: Value }
   | Var    { _var     :: String }

   | Fun    { _arg     :: String
            , _body    :: AST    }

   | Force  { _body    :: AST    }

   | App    { _f, _x   :: AST    }

instance Show AST where
  show (Let n b r) =
    concat
      [ "let "
      , n
      , " = "
      , show b
      , "; "
      , show r
      ]

  show (Val val) = show val
  show (Var var) =      var
  show (Fun x f) =
    concat
      [ "\\"
      , x
      , " -> "
      , show f
      ]

  show (Force f) =
    concat
      [ "!("
      , show f
      , ")"
      ]

  show (List items) = show items

  show (App f x) =
    concat
      [ show f
      , " "
      , show x
      ]

type Value = To.Value

(#) = App

(##) = (To.#)

funN = flip (foldr Fun)

infixl 8 ##, #

descent (Let name body rest) =
  To.fun name (descent rest) ## descent body

descent (List []) =
  To.atom "end"

descent (List (h : rest)) =
  To.fun "p" (To.var "p" ## descent h ## descent (List rest))

descent (Val (To.Constant c)) =
  To.constant c

descent (Val (To.Atom a)) =
  To.atom a

descent (Val (To.BIF n b)) =
  To.bif n b

descent (Var v) =
  To.var v

descent (Fun a b) =
  To.fun a (descent b)

descent (Force b) =
  To.enforce (descent b)

descent (App f x) =
  descent f ## descent x

compile = Lib.environ 
            [ "eq"    `is` Lib.eq
            , "add"   `is` Lib.binary_on_int "+" (+)
            , "sub"   `is` Lib.binary_on_int "-" (-)
            , "force" `is` Lib.unary "force" To.force
            , "print" `is` Lib.unary "print" (\x -> print x >> return x)
            ] 
        . descent

is = (,)

main.hs

import Parser

main = do program <- loadFile "test.lc"
          
          print program

Parser.hs

{-# LANGUAGE FlexibleInstances #-}

module Parser where

import Text.Parsec
import Text.Parsec.String

import Lang0
import qualified Ast as To

--data AST =
--     Let    { _name    :: String
--            , _body    :: AST
--            , _rest    :: AST    }

--   | List   { _items   :: [AST]  }

--   | Val    { _val     :: Value }
--   | Var    { _var     :: String }

--   | Fun    { _arg     :: String
--            , _body    :: AST    }

--   | App    { _f, _x   :: AST    }

instance Show (AST -> AST) where
  show = show . ($ Var "... algorithm...")

program :: Parser AST
program = let_expr

let_expr = do contexts <- many (do try $ str "let"
                                   let_block) :: Parser [AST -> AST]
              
              expr <- expr

              return $ foldr ($) expr contexts
       <|> expr
       <?> "let-expression"

let_block = do fun_name : args <- many1 name

               str "="

               body     <- expr

               str ";"

               let function = foldr Fun body args

               return $ \trunk -> Let fun_name function trunk
       <?> "let-block"

expr = lambda <|> app

lambda = do str "\\"
            
            args <- many name

            str "->"

            body <- expr

            return $ foldr Fun body args
       <?> "lambda"

app = do h : t <- many1 term

         return $ foldl1 App (h : t)
       <?> "app"

list = do str "["
          (do { str "]"; return $ List [] })
            <|>
            (do h <- let_expr
                t <- many (try $ do str ","
                                    let_expr)
                str "]"; 
                return $ List (h : t))

term = constant
   <|> list
   <|> atom
   <|> var
   <|> str "(" *> let_expr <* str ")"
   <|> enforce
   <|> lambda

constant = (Val . To.Constant 
                . read)        `fmap` number
       <?> "integer constant"

atom     = (Val . To.Atom)     `fmap` tokenized (string ":" *> name)
var      = Var                 `fmap` name

name   = (<?> "name") $ tokenized (many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ "._")
number = tokenized (many1 $ oneOf $ ['0'..'9'])

tokenized x = many (space) *> x <* many (space)

str x = tokenized (string x)

sp *> p = sp >> p
p <* sp = do { r <- p; sp; return r }

enforce = do
   str "!"
   str "("
   expr <- let_expr
   str ")"
   return $ Force expr

evaluate = To.force . either (error . show)  compile . parse program "" 

loadFile name = 
  do text <- readFile name
     evaluate text

Scope.hs

module Ast.Scope where

import Data.Set
import Data.List (intercalate)

newtype Scope = Scope (Set String)

nothing = Scope empty

single = Scope . singleton

name `inside` Scope set = name `member` set

Scope set `except` name = Scope (name `delete` set)

Scope left `join` Scope right = Scope (left `union` right)

instance Show Scope where
  show (Scope set) = concat ["[", intercalate ", " (toList set), "] "]

Stdlib.hs

module Stdlib where

import Ast
import Ast.Scope

unary :: String -> (Blob -> IO Blob) -> Blob
unary n = (`knows` nothing) . Val . BIF n

binary :: String -> (Blob -> Blob -> IO Blob) -> Blob
binary n f = unary n (\arg -> return $ unary ("<" ++ n ++ " " ++ show arg ++ ">") $ f arg)

eq = binary "eq" $
		\x y ->
			do a <- force x
			   b <- force y

			   return $ if a == b then true else false

true = binary "true" $
         \x y -> return x

false = binary "false" $
         \x y -> return y

toValue (Val bif) = bif

binary_on_int n f = 
	binary n $ 
		\x y ->
			do Val (Constant a) <- tree `fmap` force x
			   Val (Constant b) <- tree `fmap` force y

			   return $ constant $ f a b

environ funs =
	flip (foldl $ 
			\program (name, builtin) ->
				fun name program # builtin
		  )
	     funs

test.lc

let cons h t = \p -> p h t;
let head h t = h;
let tail h t = t;

let rec self = self self;

let const = head;

let map f = 
    rec \self list ->
        (eq list :end)
            :end
            (list \h t ->
                cons !(f h) (rec self t))
    ;

let fold_left f =
    rec \self i l ->
        (eq l :end)
            i
            (l \h t -> 
                rec self !(f i h) t)
    ;

let false = tail;

let true  = head;

let and a b = a b false;

let or a b = a true b;

let take =
    rec \self n list -> 
        (eq n 0)
            :end
            (list \h t -> 
                cons
                    h
                    (rec self !(sub n 1) t))
    ;

let COMPILED = :here;

let fib =
    (rec \self a b ->
        cons
            a
            (rec self b !(add a b))
    ) 0 1;

let repeat i =
    (rec \self ->
        cons
            i
            (rec self));

let drop_unless_eq value =
    (rec 
        \self h t ->
            (eq h value)
                t
                (t (rec self))
    );

let naturals =
    (rec \self n ->
        cons n (rec self !(add 1 n))
    ) 0;

let bad_fib =
    rec \self n ->
        (eq n 0) 0
        ((eq n 1) 1
            (let np  = rec self !(sub n 1);
             let npp = rec self !(sub n 2);
             add np npp))
    ;

let lit = 1;

let nth n list = fold_left tail :nil (take n list);

nth 100000 fib

test1.lc

let cons h t = \p -> p h t;
let head h t = h;
let tail h t = t;

let rec self = self self;

let const = head;

let map f = 
    rec \self list ->
        (eq list :end)
            :end
            (list \h t ->
                cons !(f h) (rec self t))
    ;

let fold_left f =
    rec \self i l ->
        (eq l :end)
            i
            (l \h t -> 
                rec self !(f i h) t)
    ;

let false = tail;

let true  = head;

let and a b =
    a b false;

let or a b =
    a true b;

let take =
    rec \self n list -> 
        (eq n 0)
            :end
            (list \h t -> 
                cons
                    h
                    (rec self !(sub n 1) t))
    ;

let COMPILED = :here;

let fib =
    (rec \self a b ->
        cons
            a
            (rec self b !(add a b))
    ) 0 1;

let repeat i =
    (rec \self ->
        cons
            i
            (rec self));

let drop_unless_eq value =
    (rec 
        \self h t ->
            (eq h value)
                t
                (t (rec self))
    );

let naturals =
    (rec \self n ->
        cons n (rec self !(add 1 n))
    ) 0;

fold_left add 0 (take 10000 naturals)