The Primitive Function Library

module SExpression where

import Data.Char

data SExpression = NumAtom Int | 
                   SymAtom [Char] | 
                   List [SExpression]

first [List (a:more)] = Just a
first _ = Nothing

rest [List (a:more)] = Just (List more)
rest _ = Nothing

endp [List []] = Just (SymAtom "T")
endp [List _] = Just (SymAtom "F")
endp _ = Nothing

numberp [NumAtom _]  = Just (SymAtom "T")
numberp _  = Just (SymAtom "F")

symbolp [SymAtom _]  = Just (SymAtom "T")
symbolp _  = Just (SymAtom "F")

listp [List _]  = Just (SymAtom "T")
listp _  = Just (SymAtom "F")

cons [e, List es]  = Just (List (e:es))
cons _  = Nothing

eq [SymAtom n1, SymAtom n2]
    | n1 == n2    = Just (SymAtom "T")
    | otherwise   = Just (SymAtom "F")
eq _ = Nothing

plus [NumAtom n1, NumAtom n2] = Just (NumAtom (n1 + n2))
plus _ = Nothing

minus [NumAtom n1, NumAtom n2] = Just (NumAtom (n1 - n2))
minus _ = Nothing

times [NumAtom n1, NumAtom n2] = Just (NumAtom (n1 * n2))
times _ = Nothing

eqp [NumAtom n1, NumAtom n2]
    | n1 == n2    = Just (SymAtom "T")
    | otherwise   = Just (SymAtom "F")
eqp _ = Nothing

lessp [NumAtom n1, NumAtom n2]
    | n1 < n2    = Just (SymAtom "T")
    | otherwise   = Just (SymAtom "F")
lessp _ = Nothing

greaterp [NumAtom n1, NumAtom n2]
    | n1 > n2    = Just (SymAtom "T")
    | otherwise   = Just (SymAtom "F")
greaterp _ = Nothing

sym_lessp [SymAtom n1, SymAtom n2]
    | n1 < n2    = Just (SymAtom "T")
    | otherwise   = Just (SymAtom "F")
sym_lessp _ = Nothing

explode [SymAtom str] = Just (List (map explode1 str))
explode _ = Nothing

explode1 c
    | isDigit c  = NumAtom (digitToInt c)
    | otherwise  = SymAtom [c]

implode [List (SymAtom (c:chars): more)]
    | isAlpha c  = implodeAlpha (c:chars) more
    | otherwise  = implodeSpecial (c:chars) more
implode _ = Nothing

implodeAlpha str [] = Just (SymAtom str)
implodeAlpha s@(_:_) (SymAtom "-" : (SymAtom (c:chars)): more) 
    | isAlpha c  = implodeAlpha (s ++ ('-':c:chars)) more
    | otherwise  = Nothing
implodeAlpha str@(_:_) (SymAtom "-" : (NumAtom s): more) 
    | s > 0     = implodeAlpha (str ++ ('-':(show s))) more
    | otherwise = Nothing
implodeAlpha str ((SymAtom (c:chars)): more) 
    | isAlpha c  = implodeAlpha (str ++ (c:chars)) more
    | otherwise  = Nothing
implodeAlpha str ((NumAtom s): more) = implodeAlpha (str ++ (show s)) more

implodeSpecial str ((SymAtom (c:chars)): more) 
    | isAlpha c  = Nothing
    | otherwise  = implodeSpecial (str ++ (c:chars)) more
implodeSpecial _ _ = Nothing

divide [NumAtom n1, NumAtom 0] = Nothing
divide [NumAtom n1, NumAtom n2] = 
    Just (NumAtom (truncate (fromIntegral n1 / (fromIntegral n2))))
divide _ = Nothing

rem [NumAtom n1, NumAtom 0] = Nothing
rem [NumAtom n1, NumAtom n2] = 
    Just (NumAtom (n1 - (n2 * (truncate (fromIntegral n1 / (fromIntegral n2))))))
rem _ = Nothing

-- A custom instance for converting SExpressions to Lisp list syntax

instance Show SExpression where
    show (NumAtom n) = (show n)
    show (SymAtom s) = s
    show (List []) = "()"
    show (List (a:s)) = "(" ++ show a ++ (concatMap ((' ':) . show) s) ++ ")"

The Interpreter

module SmLispInterpret where

import SExpression as SE
import SmLispParse
import qualified Data.Map.Strict as Env
import Control.Applicative
import System.IO (stdout,stderr,hPutStr,hPutStrLn)

data FnEntry = UserDef [Identifier] SmLispExpr | 
               BuiltIn ([SE.SExpression] -> Maybe SE.SExpression)

type FnEnv = Env.Map [Char] FnEntry

builtinFnEnv = 
    Env.fromList [("first", BuiltIn SE.first), ("rest", BuiltIn SE.rest), 
                  ("endp", BuiltIn SE.endp), ("cons", BuiltIn SE.cons), 
                  ("eq", BuiltIn SE.eq),
                  ("numberp", BuiltIn SE.numberp), ("symbolp", BuiltIn SE.symbolp), 
                  ("listp", BuiltIn SE.listp), ("eqp", BuiltIn SE.eqp),
                  ("lessp", BuiltIn SE.lessp), ("greaterp", BuiltIn SE.greaterp), 
                  ("plus", BuiltIn SE.plus), ("minus", BuiltIn SE.minus), 
                  ("times", BuiltIn SE.times), ("divide", BuiltIn SE.divide), 
                  ("rem", BuiltIn SE.rem), ("sym-lessp", BuiltIn SE.sym_lessp), 
                  ("explode", BuiltIn SE.explode), ("implode", BuiltIn SE.implode)]

type ValEnv = ([(String, SE.SExpression)], [(String, SE.SExpression)])

builtinValEnv = ([], 
                 [("T", SymAtom "T"), ("F", SymAtom "F"), ("otherwise", SymAtom "T")])

reset_to_global_frame (local, global) = ([], global)

applyValEnv (local, global) name =
    case lookup name local of
        Just a -> Just a
        Nothing -> lookup name global

applyFnEnv fnEnv name = Env.lookup name fnEnv


sl_eval (SExpr a) _ _ = Just a
sl_eval (Variable n) _ valEnv = applyValEnv valEnv n
sl_eval (FnCall n args) fnEnv valEnv = 
    sl_apply n (sequence (map (\e -> sl_eval e fnEnv valEnv) args)) 
               fnEnv (reset_to_global_frame valEnv)
sl_eval (CondExpr clauses) fnEnv valEnv = sl_evcond clauses fnEnv valEnv
sl_eval (LetExpr defs e) fnEnv valEnv = 
    sl_eval e fnEnv (add_associations defs fnEnv valEnv)

add_associations [] fnEnv valEnv = valEnv
add_associations ((Binding n e):more_defs) fnEnv (local, global) = 
    case sl_eval e fnEnv (local, global) of
        Just x -> add_associations more_defs fnEnv ((n, x):local, global)
        Nothing -> add_associations more_defs fnEnv (local, global)

sl_evcond [] _ _ = Nothing
sl_evcond (Clause p e : more_clauses) fnEnv valEnv =
    case sl_eval p fnEnv valEnv of
        Just (SymAtom "T") -> sl_eval e fnEnv valEnv
        Just (SymAtom "F") -> sl_evcond more_clauses fnEnv valEnv
        Nothing -> Nothing

sl_apply n Nothing fnEnv valEnv = Nothing
sl_apply n (Just args) fnEnv (local, global) =
    case applyFnEnv fnEnv n of
        Just (BuiltIn primitive) -> primitive args
        Just (UserDef parameters expr) -> 
            sl_eval expr fnEnv (foldr (:) local (zip parameters args), global)
        _-> Nothing

setup_envs_then_eval fnEnv valEnv [] expr = sl_eval expr fnEnv valEnv

setup_envs_then_eval fnEnv valEnv@(local, global) (ConstantDef n e : more_defs) expr =
    case sl_eval e fnEnv valEnv of
        Just sexpr -> 
            setup_envs_then_eval fnEnv (local, (n, sexpr): global) more_defs expr
        Nothing ->  -- on Error, skip and leave n undefined
            setup_envs_then_eval fnEnv valEnv more_defs expr 

setup_envs_then_eval fnEnv valEnv (FunctionDef name args e : more_defs) expr =
    setup_envs_then_eval (Env.insert name (UserDef args e) fnEnv) valEnv more_defs expr


interpret defs expr = setup_envs_then_eval builtinFnEnv builtinValEnv defs expr

smlisp def_text expr_text =
    case (parseProgramText def_text, parseExpressionText expr_text) of
        (Just defs, Just expr) -> interpret defs expr
        _ -> Nothing