[ MIRROR ] An interpreter for a Lisp-like language git.ngill.net/nls.git
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127{-# LANGUAGE OverloadedStrings #-}
module Builtin ( builtins, )where
import Types
expectNumber :: NlsRunValue -> Eval IntegerexpectNumber (RNumber n) = pure nexpectNumber _ = Left "expected number"
-- template for chained arithmetic operationsmakeBuiltinArith :: (Integer -> Integer -> Integer) -> NlsRunValue -> [NlsRunValue] -> Eval NlsRunValuemakeBuiltinArith op first rest = do f <- expectNumber first rs <- mapM expectNumber rest pure $ RNumber (foldl op f rs)
-- template for chained comparisonmakeBuiltinComp :: (Integer -> Integer -> Bool) -> NlsRunValue -> [NlsRunValue] -> Eval NlsRunValuemakeBuiltinComp op first rest = do f <- expectNumber first rs <- mapM expectNumber rest pure $ RBool (and (zipWith op (f : rs) rs))
builtinAdd :: [NlsRunValue] -> Eval NlsRunValuebuiltinAdd xs = case xs of [] -> pure $ RNumber 0 (f : rest) -> makeBuiltinArith (+) f rest
builtinMul :: [NlsRunValue] -> Eval NlsRunValuebuiltinMul xs = case xs of [] -> pure $ RNumber 1 (f : rest) -> makeBuiltinArith (*) f rest
builtinSub :: [NlsRunValue] -> Eval NlsRunValuebuiltinSub xs = case xs of [] -> Left "builtinSub requires at least one argument" [x] -> RNumber . negate <$> expectNumber x (f : rest) -> makeBuiltinArith (-) f rest
builtinDiv :: [NlsRunValue] -> Eval NlsRunValuebuiltinDiv xs = case xs of [] -> Left "builtinDiv requires at least one argument" [x] -> do n <- expectNumber x if n == 0 then Left "division by zero" else pure $ RNumber (div 1 n) (f : rest) -> do rs <- mapM expectNumber rest if elem 0 rs then Left "division by zero" else makeBuiltinArith div f rest
builtinEq :: [NlsRunValue] -> Eval NlsRunValuebuiltinEq xs = case xs of [] -> pure $ RBool True (f : rest) -> makeBuiltinComp (==) f rest
builtinNEq :: [NlsRunValue] -> Eval NlsRunValuebuiltinNEq xs = case xs of [] -> pure $ RBool True (f : rest) -> makeBuiltinComp (/=) f rest
builtinGt :: [NlsRunValue] -> Eval NlsRunValuebuiltinGt xs = case xs of [] -> pure $ RBool True (f : rest) -> makeBuiltinComp (>) f rest
builtinLt :: [NlsRunValue] -> Eval NlsRunValuebuiltinLt xs = case xs of [] -> pure $ RBool True (f : rest) -> makeBuiltinComp (<) f rest
builtinGtEq :: [NlsRunValue] -> Eval NlsRunValuebuiltinGtEq xs = case xs of [] -> pure $ RBool True (f : rest) -> makeBuiltinComp (>=) f rest
builtinLtEq :: [NlsRunValue] -> Eval NlsRunValuebuiltinLtEq xs = case xs of [] -> pure $ RBool True (f : rest) -> makeBuiltinComp (<=) f rest
builtinList :: [NlsRunValue] -> Eval NlsRunValuebuiltinList args = pure $ RList args
builtinCons :: [NlsRunValue] -> Eval NlsRunValuebuiltinCons [x, RList xs] = pure $ RList (x : xs)builtinCons _ = Left "cons expects a value and list"
builtinCar :: [NlsRunValue] -> Eval NlsRunValuebuiltinCar [RList (x : _)] = pure xbuiltinCar [RList []] = Left "cannot get head of empty list"builtinCar _ = Left "car expects a single list argument"
builtinCdr :: [NlsRunValue] -> Eval NlsRunValuebuiltinCdr [RList (_ : xs)] = pure $ RList xsbuiltinCdr [RList []] = Left "cannot get tail of empty list"builtinCdr _ = Left "cdr expects a single list argument"
wrapBuiltin :: ([NlsRunValue] -> Eval NlsRunValue) -> NlsRunValuewrapBuiltin f = RFunction wrapped where wrapped :: [NlsRunValue] -> Env -> Eval (NlsRunValue, Env) wrapped args env = do val <- f args pure (val, env)
-- builtins "export" tablebuiltins :: [(String, NlsRunValue)]builtins = [ ("+", wrapBuiltin builtinAdd), ("*", wrapBuiltin builtinMul), ("-", wrapBuiltin builtinSub), ("/", wrapBuiltin builtinDiv), ("=", wrapBuiltin builtinEq), ("/=", wrapBuiltin builtinNEq), (">", wrapBuiltin builtinGt), ("<", wrapBuiltin builtinLt), (">=", wrapBuiltin builtinGtEq), ("<=", wrapBuiltin builtinLtEq), ("list", wrapBuiltin builtinList), ("cons", wrapBuiltin builtinCons), ("car", wrapBuiltin builtinCar), ("cdr", wrapBuiltin builtinCdr) ]