From 897fb17dd6a045a7056e6d6babbbb24748f698f6 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Sat, 9 Dec 2017 10:48:58 +0100 Subject: Initial --- interpreter.hs | 234 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 234 insertions(+) create mode 100644 interpreter.hs (limited to 'interpreter.hs') diff --git a/interpreter.hs b/interpreter.hs new file mode 100644 index 0000000..4595035 --- /dev/null +++ b/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' -- cgit v1.2.3-54-g00ecf