summaryrefslogtreecommitdiff
path: root/old/interpreter.hs
diff options
context:
space:
mode:
Diffstat (limited to 'old/interpreter.hs')
-rw-r--r--old/interpreter.hs234
1 files changed, 234 insertions, 0 deletions
diff --git a/old/interpreter.hs b/old/interpreter.hs
new file mode 100644
index 0000000..4595035
--- /dev/null
+++ b/old/interpreter.hs
@@ -0,0 +1,234 @@
+{-# LANGUAGE TupleSections, DeriveFunctor, GeneralizedNewtypeDeriving #-}
+module Interpreter(newContext, interpret, interpretProgram, Context) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.State
+import Data.List
+import Data.Maybe
+import qualified Data.Map.Strict as Map
+-- import Debug.Trace
+
+import AST
+import Parser
+
+
+-- TODO: place bottom varmap separately for performance? (global define's in deeply nested contexts)
+type VarMap = Map.Map Name Value
+data Context = Context {varMapStk :: [VarMap]}
+
+newtype IM a = IM {unIM :: StateT Context (ExceptT String IO) a}
+ deriving (Functor, Applicative, Monad, MonadError String, MonadState Context, MonadIO)
+
+type Builtin = [Value] -> IM Value
+
+newContext :: Context
+newContext = Context [Map.fromList [(k, VBuiltin k) | k <- Map.keys builtins]]
+
+lookupVar :: Name -> IM (Maybe Value)
+lookupVar name = liftM (msum . map (Map.lookup name)) (gets varMapStk)
+
+withScopeMap :: VarMap -> IM a -> IM a
+withScopeMap vm act = do
+ modify $ \ctx -> ctx {varMapStk = vm : varMapStk ctx}
+ x <- act
+ modify $ \ctx -> ctx {varMapStk = tail (varMapStk ctx)}
+ return x
+
+builtins :: Map.Map String Builtin
+builtins = Map.fromList
+ [("read", readBuiltin),
+ ("eval", evalBuiltin),
+ ("print", printBuiltin),
+ ("getline", getlineBuiltin),
+ ("loop", loopBuiltin),
+ ("do", doBuiltin),
+ ("if", ifBuiltin),
+ ("define", defineBuiltin),
+ ("lambda", lambdaBuiltin),
+ ("match", matchBuiltin),
+ ("+", plusBuiltin),
+ ("-", arithBuiltin "-" (-) 0), ("*", arithBuiltin "*" (*) 1),
+ ("/", arithBuiltin "/" div 1), ("%", arithBuiltin "%" mod 1),
+ ("<", compareBuiltin "<" (<) (<)), ("<=", compareBuiltin "<=" (<=) (<=)),
+ (">", compareBuiltin ">" (>) (>)), (">=", compareBuiltin ">=" (>=) (>=)),
+ ("=", compareBuiltin "=" (==) (==)), ("!=", neqBuiltin)]
+
+nArguments :: String -> Int -> Bool -> Builtin -> Builtin
+nArguments name n doeval f args
+ | length args /= n =
+ throwError $ "Function '" ++ name ++ "' expects " ++ naStr n ++ " but got " ++ naStr (length args)
+ | doeval = mapM evalValue args >>= f
+ | otherwise = f args
+ where
+ naStr 0 = "no arguments"
+ naStr 1 = "1 argument"
+ naStr num = show num ++ " arguments"
+
+
+readBuiltin :: Builtin
+readBuiltin = nArguments "read" 1 True go
+ where
+ go :: Builtin
+ go [VString s] = either (throwError . show) return $ parseExpression s
+ go _ = throwError "Can only 'read' a string"
+
+evalBuiltin :: Builtin
+evalBuiltin = nArguments "eval" 1 True (evalValue . head)
+
+printBuiltin :: Builtin
+printBuiltin args = do
+ args' <- mapM evalValue args
+ liftIO (putStrLn $ intercalate " " $ map printShow args') >> return (VList [])
+ where
+ printShow :: Value -> String
+ printShow (VString s) = s
+ printShow v = show v
+
+loopBuiltin :: Builtin
+loopBuiltin = nArguments "loop" 1 False $ forever . evalValue . head
+
+getlineBuiltin :: Builtin
+getlineBuiltin = nArguments "getline" 0 True $ const (liftIO getLine >>= return . VString)
+
+doBuiltin :: Builtin
+doBuiltin [] = return (VList [])
+doBuiltin args = fmap last $ mapM evalValue args
+
+ifBuiltin :: Builtin
+ifBuiltin [cond, v1] = evalValue cond >>= \c -> if truthy c then evalValue v1 else return (VList [])
+ifBuiltin [cond, v1, v2] = evalValue cond >>= \c -> if truthy c then evalValue v1 else evalValue v2
+ifBuiltin a = throwError $ "Cannot pass " ++ show (length a) ++ " arguments to 'if'"
+
+defineBuiltin :: Builtin
+defineBuiltin [VName name, val] = do
+ val' <- evalValue val
+ stk <- gets varMapStk
+ let go [vm] _ = [Map.insert name val' vm]
+ go (vm : vms) (False : prs) = vm : go vms prs
+ go (vm : vms) (True : _) = Map.insert name val' vm : vms
+ go _ _ = undefined
+ modify $ \ctx -> ctx {varMapStk = go stk (map (isJust . Map.lookup name) stk)}
+ return (VList [])
+defineBuiltin [name@(VName _), VList args, val]
+ | Just names <- mapM fromVName args = defineBuiltin [name, VLambda names val]
+ | otherwise = throwError "Invalid 'define' syntax: invalid argument list"
+defineBuiltin _ = throwError "Invalid 'define' syntax"
+
+lambdaBuiltin :: Builtin
+lambdaBuiltin = nArguments "lambda" 2 False go
+ where
+ go :: Builtin
+ go [VList args, body]
+ | Just names <- mapM fromVName args = return (VLambda names body)
+ | otherwise = throwError "Invalid 'lambda' syntax: invalid argument list"
+ go _ = throwError "Invalid 'lambda' syntax"
+
+matchBuiltin :: Builtin
+matchBuiltin [] = throwError "Invalid 'match' syntax: empty match"
+matchBuiltin [_] = throwError "Invalid 'match' syntax: no arms"
+matchBuiltin (subject : arms) = do
+ subject' <- evalValue subject
+ go subject' arms
+ where
+ go :: Value -> [Value] -> IM Value
+ go _ [def] = evalValue def
+ go subject' (VList [pat, value] : rest) =
+ case match pat subject' Map.empty of
+ Nothing -> go subject' rest
+ Just mp -> withScopeMap mp (evalValue value)
+ go _ _ = throwError "Invalid 'match' syntax: invalid arm"
+
+plusBuiltin :: Builtin
+plusBuiltin [] = return (VNum 0)
+plusBuiltin args
+ | Just nums <- mapM fromVNum args = return (VNum (sum nums))
+ | Just strs <- mapM maybeStrings args = return (VString (concat strs))
+ | otherwise = throwError "Invalid argument types to operator '+'"
+
+arithBuiltin :: String -> (Int -> Int -> Int) -> Int -> Builtin
+arithBuiltin name oper idelem args = do
+ args' <- mapM evalValue args
+ case mapM fromVNum args' of
+ Just [] -> return (VNum idelem)
+ Just (hd : tl) -> return (VNum (foldl oper hd tl))
+ _ -> throwError $ "Invalid argument types to operator '" ++ name ++ "'"
+
+neqBuiltin :: Builtin
+neqBuiltin = fmap (\(VNum x) -> VNum (1 - x)) . compareBuiltin "!=" (==) (==)
+
+compareBuiltin :: String -> (Int -> Int -> Bool) -> (String -> String -> Bool) -> Builtin
+compareBuiltin name oper soper args = do
+ args' <- mapM evalValue args
+ res <- case () of
+ _ | Just nums <- mapM fromVNum args' -> return $ all (uncurry oper) (zip nums (tail nums))
+ | Just strs <- mapM maybeStrings args' -> return $ all (uncurry soper) (zip strs (tail strs))
+ | otherwise -> throwError $ "Invalid argument types to operator '" ++ name ++ "'"
+ return $ VNum $ fromIntegral $ fromEnum res
+
+
+truthy :: Value -> Bool
+truthy (VNum n) = n /= 0
+truthy _ = True
+
+match :: Value -> Value -> VarMap -> Maybe VarMap
+match (VList []) (VList []) mp = Just mp
+match (VList [VEllipsis]) (VList _) mp = Just mp
+match (VList (pat : pats)) (VList (val : vals)) mp = match pat val mp >>= match (VList pats) (VList vals)
+match (VName name) val mp = case Map.lookup name mp of
+ Nothing -> Just (Map.insert name val mp)
+ Just val' | val == val' -> Just mp
+ | otherwise -> Nothing
+match (VQuoted a) (VQuoted b) mp = match a b mp
+match (VLambda _ _) _ _ = Nothing
+match a b mp | a == b = Just mp
+ | otherwise = Nothing
+
+maybeStrings :: Value -> Maybe String
+maybeStrings = liftM2 (<|>) fromVString (fmap show . fromVNum)
+
+
+evalValue :: Value -> IM Value
+-- evalValue v | traceShow v False = undefined
+evalValue (VList exs) = listCall exs
+evalValue e@(VNum _) = return e
+evalValue e@(VString _) = return e
+evalValue (VName name) = lookupVar name >>= \mval -> case mval of
+ Just value -> return value
+ Nothing -> throwError $ "Use of undefined variable '" ++ name ++ "'"
+evalValue (VQuoted e) = return e
+evalValue e@(VLambda _ _) = return e
+evalValue e@(VBuiltin _) = return e
+evalValue VEllipsis = throwError "Unexpected ellipsis in code"
+
+listCall :: [Value] -> IM Value
+listCall [] = throwError "Cannot call ()"
+listCall (hd : args) = evalValue hd >>= \hd' -> case hd' of
+ VLambda names body
+ | length names == length args -> do
+ args' <- mapM evalValue args
+ withScopeMap (Map.fromList (zip names args')) (evalValue body)
+ | otherwise -> throwError $ "Invalid number of arguments in call to lambda " ++
+ "(" ++ show (length args) ++ " found, " ++ show (length names) ++ " needed)"
+ VBuiltin name ->
+ case Map.lookup name builtins of
+ Just f -> f args
+ Nothing -> throwError $ "Unknown builtin '" ++ name ++ "'"
+ v -> throwError $ "Cannot call value: " ++ show v
+
+
+interpret :: Context -> Value -> IO (Either String (Value, Context))
+interpret ctx val =
+ runExceptT $ flip runStateT ctx $ unIM $ evalValue val
+
+interpretProgram :: Context -> Program -> IO (Either String Context)
+interpretProgram rootctx (Program l) = go l rootctx
+ where
+ go :: [Value] -> Context -> IO (Either String Context)
+ go [] ctx = return (Right ctx)
+ go (val : vals) ctx = do
+ e <- interpret ctx val
+ case e of
+ Left err -> return (Left err)
+ Right (_, ctx') -> go vals ctx'
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-06 21:24:11 +0200