Lambda calculus interpreter, written with variable storage. No GC at now, so, don't use many vars. Infinite structures are impossible by construct, although some constructible finite ones can outfill the memory. Run `main` in ghci.

AST.hs

module AST where

import qualified Data.Map as Map
import           Data.Map   (Map)

import Control.Monad.State as State
import Data.List

data Ast
    = App [Ast]                 -- stack of actions
    | Fun  Name  Ast            -- parametrized object
    | Bif  Name (Ast -> VM Ast) -- built-in
    | Num  Int                  -- numeric constant
    | Atom String               -- string constant
    | Var  Name                 -- variable, "hole"
    | Force Ast                 -- request for full reduction

type Name = String

-- VM is a class of IO-actions, extended to hold a state of variable heap
type VM = StateT (Map String Ast) IO

-- determines if object could be redued further
terminal :: Ast -> Bool
terminal (App _) = False
terminal (Var _) = False
terminal  _      = True

runUntilTerminate :: Ast -> VM Ast
runUntilTerminate tree =
    if terminal tree 
    then
        return tree

    else do
        tree' <- step tree

        runUntilTerminate tree'

run :: Ast -> IO (Ast, Map Name Ast)
run tree = runStateT (runUntilTerminate tree) Map.empty

step :: Ast -> VM Ast
step tree =
    case tree of
        Var name -> 
            getVar name

        App []  -> error "somehow, void application"
        App [x] -> return x

        -- if arg need to be forced
        App (f : Force x : xs) -> do
            -- evaluate it
            x' <- step x

            -- until it could not be evaluated
            let item = if terminal x' then x' else Force x'

            -- reconstruct application stack with var evaluation result
            apply $ f : item : xs

        -- if function need to be forced
        App (Force f : x : xs) -> do
            -- evaluate it
            f' <- step f

            -- until it could not be evaluated
            let item = if terminal f' then f' else Force f'

            -- reconstruct application stack with var evaluation result
            apply $ item : x : xs

        App (f : x : xs) ->
            case f of
                -- just make it plain - application is left-assoc
                App xs' ->
                    apply $ xs' ++ x : xs

                -- store factical arg behind the name of formal & eval body
                Fun arg body -> do

                    -- special case for vars, to prevent var-to-var refs & infinite loops:
                    -- var, unconstructively pointing to itself (t = t)
                    value <- case x of
                        Var name -> getVar name
                        _        -> return x

                    -- assign var at the storage
                    State.modify $ arg =: value

                    -- use the body of function as text top stack item
                    apply $ body : xs

                -- for simplicity, builtins have nothing to do with (App ...), 
                -- so we reducing the arg to lambda or any other terminal
                Bif _ bif -> if terminal x
                    then do 
                        -- apply action
                        fx <- bif x

                        -- reconstruct stack
                        apply $ fx : xs

                    else do
                        -- evaluate until terminal
                        x' <- step x

                        apply $ f : x' : xs

                -- dereferencing var
                Var name -> do
                    f' <- getVar name

                    apply $ f' : x : xs

                -- any other obkect couldn't be applied
                -- (unless i decide to make integers to be repeat combinators)
                other ->
                    error $ "#error: <" ++ show other ++ "> instead of function in <" ++ show (f : x : xs) ++ ">"

        other ->
            error $ "#error: irreducible <" ++ show other ++ ">"

  where
    apply = return . App

getVar :: Name -> VM Ast
getVar name = do
    vars <- State.get 

    case vars `at` name of
        Nothing    -> error $ "unbound " ++ name
        Just value -> return value


(=:) :: Name -> Ast -> Map Name Ast -> Map Name Ast
(=:) = Map.insert

at :: Map Name Ast -> Name -> Maybe Ast
at = flip Map.lookup

instance Show Ast where
    show = show' False
      where
        show' :: Bool -> Ast -> String
        show' in_bracets (App [x]) = show' in_bracets x

        show' in_bracets (App asts) = 
            let inits' = for asts $ show' True

            in br' in_bracets $ " " `intercalate` inits'

        show' in_bracets (Fun x body@(Fun _ _)) = br' in_bracets $ x ++ " " ++ show' False body

        show' in_bracets (Fun x body) = br' in_bracets $ x ++ " -> " ++ show' False body

        show' _ (Bif name _)    = '#' : name
        show' _ (Num int)       = show int
        show' _ (Atom string)   = ':' : string
        show' _ (Var  name)     = name
        show' _ (Force ast)     = br $ "! " ++ show' False ast

for :: [a] -> (a -> b) -> [b]
for = flip map

-- for testing puposes

br' :: Bool -> String -> String
br' True  = br
br' False = id

br :: String -> String
br = ("(" ++) . (++ ")")

repeatM :: Monad m => Int -> (a -> m a) -> a -> m a
repeatM 0 _ = return
repeatM n f = f >=> repeatM (n - 1) f

-- list constructor
-- let cons head tail method = method head tail
cons :: Ast
cons = "h" \> "t" \> "p" \> app [var "p", var "h", var "t"]

-- let tl head tail = tail // a tail-of-list function
tl :: Ast
tl = "h" \> "t" \> var "t"

app :: [Ast] -> Ast
app   = App

infixr 1 \>
(\>) :: Name -> Ast -> Ast
(\>) = Fun

as :: (Ast -> VM Ast) -> Name -> Ast
as    = flip Bif

num :: Int -> Ast
num   = Num

atom :: String -> Ast
atom  = Atom

var :: Name -> Ast
var   = Var

force :: Ast -> Ast
force = Force

-- test = cons 1 (cons 2 3) tl tl
test :: Ast
test = letBe "cons" cons 
     $ letBe "tl" tl 
     $ letBe "COMPILED" (atom "true") 
     $ app 
        [ var "cons"
        , num 1
        , app 
            [ var "cons"
            , num 2
            , num 3
            ]
        , var "tl"
        , var "tl"
        ]

letBe :: Name -> Ast -> Ast -> Ast
letBe name body context =
    app [name \> context, body]

unfoldrM :: a -> (a -> Bool) -> (a -> IO a) -> IO [a]
unfoldrM object end iteration =
    if end object
    then 
        return [object]

    else do
        next <- iteration object
        rest <- unfoldrM next end iteration

        return (object : rest)

data VMState
    = VMState Ast (Map Name Ast)

instance Show VMState where
    show (VMState tree heap) = 
        show tree ++ "\n  where" ++ concatMap show_heap_line pairs
      where
        show_heap_line (k, v) = "\n    " ++ upTo offset k ++ " = " ++ show v

        pairs = Map.toList heap

        upTo n str | length str >= n = str
                   | otherwise       = str ++ replicate (n - length str) ' '

        offset = maximum $ map (length . fst) pairs

main :: IO ()
main = do 
    stages <- unfoldrM initial (terminal . tree) step'

    let different = nub . map show $ stages

    forM_ different $ putStrLn . (++ "\n")
        
  where
    initial = VMState test Map.empty

    tree (VMState t _) = t

    step' (VMState prog heap) = do
        (prog', heap') <- runStateT (step prog) heap

        return $ VMState prog' heap'