Move old things out of the way

1 files changed, 0 insertions, 234 deletions

diff --git a/interpreter.hs b/interpreter.hs
deleted file mode 100644
index 4595035..0000000
--- a/interpreter.hs
+++ /dev/null
@@ -1,234 +0,0 @@
-{-# 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'