From ca75962a335a9954962b0213e060e3895ddc69fb Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Sun, 11 Dec 2022 01:37:40 +0200 Subject: Fix collection literal evaluation --- TODO.txt | 1 + milch.cabal | 2 +- src/Builtins.hs | 11 ++++++++++- src/Interpreter.hs | 41 +++++++++++++++++++++++++++++++++-------- src/Parser.hs | 18 +++++++++++------- test/Spec.hs | 9 ++++++++- test/scripts/hash-map1.milch | 6 ++++++ 7 files changed, 70 insertions(+), 18 deletions(-) create mode 100644 test/scripts/hash-map1.milch diff --git a/TODO.txt b/TODO.txt index 59c655f..3669134 100644 --- a/TODO.txt +++ b/TODO.txt @@ -1,2 +1,3 @@ add a `Debug/break` builtin that allows simple interactive debugging +instead of evaling all args first and then curry calling fn, eval only one at a time write tests diff --git a/milch.cabal b/milch.cabal index acfcb59..305e9cb 100644 --- a/milch.cabal +++ b/milch.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack diff --git a/src/Builtins.hs b/src/Builtins.hs index 511ef08..4ac6598 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -27,6 +27,7 @@ builtinEnv = M.fromList $ map (B.second Regular) [ builtinParseInt, builtinParseFloat, builtinStrToVec, + builtinHashMap, -- sequence (vector, string) operations builtinSeqHead, builtinSeqTail, @@ -60,7 +61,8 @@ builtinEnv = M.fromList $ map (B.second Regular) [ reservedKeyword "Debug/env", reservedKeyword "import", reservedKeyword "record", - reservedKeyword "do" + reservedKeyword "do", + reservedKeyword "eval" ] argError1 :: String -> AST -> String @@ -309,6 +311,13 @@ builtinStrToVec = (name, makeNonsenseAST $ ASTFunction Pure fn1) where .> return fn1 ast1 = throwL (astPos ast1, argError1 name ast1) +builtinHashMap :: (String, AST) +builtinHashMap = (name, makeNonsenseAST $ ASTFunction Pure fn1) where + name = "hash-map" + fn1 AST { an = ASTVector vec } = + return $ makeNonsenseAST $ ASTHashMap $ M.fromList $ asPairs vec + fn1 ast1 = throwL (astPos ast1, argError1 name ast1) + builtinPrint :: (String, AST) builtinPrint = (name, makeNonsenseAST $ ASTFunction Impure fn1) where name = "print!" diff --git a/src/Interpreter.hs b/src/Interpreter.hs index c899524..9362d91 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -111,7 +111,16 @@ evaluateFunctionDef fPurity asts = do throwL (astPos defAst, "\\ or \\! called with " ++ show (length args) ++ " arguments") | otherwise -> return $ (head args', tail args') - AST { an = ASTVector params' } <- assertIsASTVector params'' + params' <- case params'' of + AST { an = ASTVector vec } -> return vec + -- vector literals like [a b c] are turned into (eval [a b c]) in the parser, and this eval call + -- must be unwrapped. this is not the cleanest way to do this but this way we can avoid having special + -- evaluation logic for collection types. + AST { an = ASTFunctionCall ([ AST { an = ASTSymbol "eval" }, AST { an = ASTVector vec }])} + -> return vec + other -> throwL (astPos params'', + "non-vector value used as parameter list in function definition: " ++ show other) + params <- mapM assertIsASTSymbol params' env <- getEnv @@ -414,6 +423,26 @@ evaluateDo children = do evaluate retExpr +evaluateImmediateEval :: [AST] -> LContext AST +evaluateImmediateEval children = do + let fnAst = head children + args = tail children + + when (length args /= 1) $ throwL (astPos fnAst, "eval called with invalid number of arguments: " ++ show (length args)) + case head args of + ast@AST { an = ASTVector vec } -> do + rets <- mapM evaluate vec `catchError` + appendError (astPos ast, "when evaluating elements of vector") + return $ ast { an = ASTVector rets } + ast@AST { an = ASTHashMap hmap } -> do + let pairs = M.assocs hmap + evaledPairs <- mapM (\(k, v) -> do evaledK <- evaluate k + evaledV <- evaluate v + return (evaledK, evaledV)) pairs `catchError` + appendError (astPos ast, "when evaluating keys and values of hash map") + return $ ast { an = ASTHashMap $ M.fromList evaledPairs } + arg -> evaluate arg + evaluate :: AST -> LContext AST evaluate ast@AST { an = fnc@(ASTFunctionCall args@(x:_)) } = do config <- getConfig @@ -440,6 +469,8 @@ evaluate ast@AST { an = fnc@(ASTFunctionCall args@(x:_)) } = evaluateRecord args ASTSymbol "do" -> evaluateDo args + ASTSymbol "eval" -> + evaluateImmediateEval args _ -> evaluateFunctionCall args @@ -452,12 +483,6 @@ evaluate ast@AST { an = fnc@(ASTFunctionCall args@(x:_)) } = return ret evaluate ast@AST { an = (ASTSymbol _) } = evaluateSymbol ast -evaluate ast@AST { an = (ASTVector vec) } = - do incrementDepth - rets <- mapM evaluate vec `catchError` - appendError (astPos ast, "when evaluating elements of vector") - decrementDepth - return $ ast { an = ASTVector rets } evaluate other = return other @@ -509,4 +534,4 @@ runInlineScript' lineNo fileName src = do PrintEvaledOff -> return () restEvaled <- foldEvaluate rest - return $ evaledAst : restEvaled + return $ evaledAst : restEvaled \ No newline at end of file diff --git a/src/Parser.hs b/src/Parser.hs index 5e94148..3c2350c 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -2,11 +2,9 @@ module Parser ( parse, ) where -import qualified Data.Map as M import qualified Data.List as L import qualified Data.Maybe as MB import Control.Monad.State -import Control.Monad.Except import Text.Regex.TDFA import Utils @@ -64,16 +62,22 @@ _parse acc (Token { tokenContent = "]" }:rest) = do let children' = takeWhile (an .> (/= ASTSymbol "[")) acc children <- validateBalance ["["] children' let openBracket = MB.fromJust $ L.find (an .> (== ASTSymbol "[")) acc - let vec = openBracket { an = ASTVector (reverse children) } - let newAcc = vec : drop (length children + 1) acc + let evalSym = makeNonsenseAST $ ASTSymbol "eval" + let evalArg = makeNonsenseAST $ ASTVector $ reverse children + let evalCall = openBracket { an = ASTFunctionCall [evalSym, evalArg] } + let newAcc = evalCall : drop (length children + 1) acc _parse newAcc rest _parse acc (Token { tokenContent = "}" }:rest) = do let children' = takeWhile (an .> (/= ASTSymbol "{")) acc children <- validateBalance ["{"] children' + when (length children `mod` 2 /= 0) $ throwL ("", "odd number of elements in hash map literal") let openCurly = MB.fromJust $ L.find (an .> (== ASTSymbol "{")) acc - pairs <- asPairsM (reverse children) `catchError` appendError (astPos openCurly, "when parsing a hash map") - let hmap = openCurly { an = ASTHashMap (M.fromList pairs) } - let newAcc = hmap : drop (length children + 1) acc + let evalSym = makeNonsenseAST $ ASTSymbol "eval" + let evalArg = makeNonsenseAST $ ASTVector $ reverse children + let hashMapSym = makeNonsenseAST $ ASTSymbol "hash-map" + let hashMapArg = makeNonsenseAST $ ASTFunctionCall [evalSym, evalArg] + let hashMapCall = openCurly { an = ASTFunctionCall [hashMapSym, hashMapArg]} + let newAcc = hashMapCall : drop (length children + 1) acc _parse newAcc rest _parse acc (token:rest) = _parse (parseToken token : acc) rest diff --git a/test/Spec.hs b/test/Spec.hs index f85ecac..e522c9c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -137,7 +137,14 @@ e2eTests = testGroup "e2e" [ let expectedAtomMap = M.singleton (LAtomRef 1) (astInteger 15) let gotAtomMap = stateAtomMap gotState - assertEqual "" expectedAtomMap gotAtomMap + assertEqual "" expectedAtomMap gotAtomMap, + + do let env = builtinEnv + script1 <- readFile "test/scripts/hash-map1.milch" + (gotASTs, _) <- expectSuccessL env $ runInlineScript "" script1 + + let expectedLastAST = astBoolean True + assertEqual "" expectedLastAST (last gotASTs) ] testGroup label xs = TestLabel label $ TestList $ map TestCase xs diff --git a/test/scripts/hash-map1.milch b/test/scripts/hash-map1.milch new file mode 100644 index 0000000..ed61ec0 --- /dev/null +++ b/test/scripts/hash-map1.milch @@ -0,0 +1,6 @@ +(let a "foo") + +(eq? + { a 1 :b 2 } + ; equivalent to + (hash-map [a 1 :b 2])) -- cgit v1.3