From 05fcc94a561335a6502fc98c3737a7e851d1285a Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Wed, 7 Dec 2022 14:33:07 +0200 Subject: Fix function body let issue --- src/Builtins.hs | 86 +++++++++++++------------- src/Interpreter.hs | 173 +++++++++++++++++++++++++++-------------------------- src/Parser.hs | 26 ++++---- src/Utils.hs | 23 +++---- 4 files changed, 156 insertions(+), 152 deletions(-) (limited to 'src') diff --git a/src/Builtins.hs b/src/Builtins.hs index 5ecf24d..3b92926 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -74,14 +74,14 @@ reservedKeyword name = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinAdd2 :: (String, AST) builtinAdd2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "+" - fn1 ast1@AST { astNode = ASTInteger a } = + fn1 ast1@AST { an = ASTInteger a } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTInteger b } = + fn2 AST { an = ASTInteger b } = return $ makeNonsenseAST $ ASTInteger $ a + b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 - fn1 ast1@AST { astNode = ASTDouble a } = + fn1 ast1@AST { an = ASTDouble a } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTDouble b } = + fn2 AST { an = ASTDouble b } = return $ makeNonsenseAST $ ASTDouble $ a + b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 @@ -89,14 +89,14 @@ builtinAdd2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinSubtract2 :: (String, AST) builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "-" - fn1 ast1@AST { astNode = ASTInteger a } = + fn1 ast1@AST { an = ASTInteger a } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTInteger b } = + fn2 AST { an = ASTInteger b } = return $ makeNonsenseAST $ ASTInteger $ a - b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 - fn1 ast1@AST { astNode = ASTDouble a } = + fn1 ast1@AST { an = ASTDouble a } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTDouble b } = + fn2 AST { an = ASTDouble b } = return $ makeNonsenseAST $ ASTDouble $ a - b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 @@ -104,14 +104,14 @@ builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinMultiply2 :: (String, AST) builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "*" - fn1 ast1@AST { astNode = ASTInteger a } = + fn1 ast1@AST { an = ASTInteger a } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTInteger b } = + fn2 AST { an = ASTInteger b } = return $ makeNonsenseAST $ ASTInteger $ a * b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 - fn1 ast1@AST { astNode = ASTDouble a } = + fn1 ast1@AST { an = ASTDouble a } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTDouble b } = + fn2 AST { an = ASTDouble b } = return $ makeNonsenseAST $ ASTDouble $ a * b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 @@ -119,15 +119,15 @@ builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinDivide2 :: (String, AST) builtinDivide2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "/" - fn1 ast1@AST { astNode = ASTInteger a } = + fn1 ast1@AST { an = ASTInteger a } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 ast2@AST { astNode = ASTInteger b } = + fn2 ast2@AST { an = ASTInteger b } = do when (b == 0) $ throwL (astPos ast2) $ "division by zero" return $ makeNonsenseAST $ ASTInteger $ a `div` b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 - fn1 ast1@AST { astNode = ASTDouble a } = + fn1 ast1@AST { an = ASTDouble a } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 ast2@AST { astNode = ASTDouble b } = + fn2 ast2@AST { an = ASTDouble b } = do when (b == 0) $ throwL (astPos ast2) $ "division by zero" return $ makeNonsenseAST $ ASTDouble $ a / b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 @@ -150,13 +150,13 @@ builtinLt2 = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinFloor :: (String, AST) builtinFloor = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "floor" - fn1 AST { astNode = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl + fn1 AST { an = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinParseInt :: (String, AST) builtinParseInt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "parse-int" - fn1 ast1@AST { astNode = ASTString str } = + fn1 ast1@AST { an = ASTString str } = case (TR.readMaybe str) of Just val -> return $ makeNonsenseAST $ ASTInteger $ val Nothing -> throwL (astPos ast1) $ argError1 name ast1 @@ -165,15 +165,15 @@ builtinParseInt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinToDouble :: (String, AST) builtinToDouble = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "to-double" - fn1 AST { astNode = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int + fn1 AST { an = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinFmt :: (String, AST) builtinFmt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "fmt" - fn1 ast1@AST { astNode = ASTString str } = + fn1 ast1@AST { an = ASTString str } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTVector replacements } = + fn2 AST { an = ASTVector replacements } = return $ makeNonsenseAST $ ASTString $ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str) fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 @@ -182,7 +182,7 @@ builtinFmt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where replaceAll _ [] text = text replaceAll n (x:xs) text = let xRepr = case x of - AST { astNode = ASTString s } -> s + AST { an = ASTString s } -> s _ -> show x text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ xRepr) text in replaceAll (n + 1) xs text' @@ -190,7 +190,7 @@ builtinFmt = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinHead :: (String, AST) builtinHead = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "head" - fn1 ast1@AST { astNode = ASTVector vec } = + fn1 ast1@AST { an = ASTVector vec } = do when (length vec == 0) $ throwL (astPos ast1) $ name ++ " of empty vector" return $ head vec fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 @@ -198,7 +198,7 @@ builtinHead = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinTail :: (String, AST) builtinTail = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "tail" - fn1 ast1@AST { astNode = ASTVector vec } = + fn1 ast1@AST { an = ASTVector vec } = do when (length vec == 0) $ throwL (astPos ast1) $ name ++ " of empty vector" return $ makeNonsenseAST $ ASTVector $ tail vec fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 @@ -206,11 +206,11 @@ builtinTail = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinSubstr :: (String, AST) builtinSubstr = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "substr" - fn1 ast1@AST { astNode = ASTInteger at } = + fn1 ast1@AST { an = ASTInteger at } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 ast2@AST { astNode = ASTInteger len } = + fn2 ast2@AST { an = ASTInteger len } = return $ makeNonsenseAST $ ASTFunction Pure $ fn3 where - fn3 AST { astNode = ASTString str } = + fn3 AST { an = ASTString str } = return $ makeNonsenseAST $ ASTString $ drop at .> take len $ str fn3 ast3 = throwL (astPos ast3) $ argError3 name ast1 ast2 ast3 fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 @@ -219,7 +219,7 @@ builtinSubstr = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinStrToVec :: (String, AST) builtinStrToVec = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "to-vec" - fn1 AST { astNode = ASTString str } = + fn1 AST { an = ASTString str } = str $> map (\c -> [c]) .> map (makeNonsenseAST . ASTString) .> (makeNonsenseAST . ASTVector) @@ -231,14 +231,14 @@ builtinPrepend = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "prepend" fn1 ast1 = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTVector vec } = + fn2 AST { an = ASTVector vec } = return $ makeNonsenseAST $ ASTVector $ ast1 : vec fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 builtinPrint :: (String, AST) builtinPrint = (name, makeNonsenseAST $ ASTFunction Impure fn1) where name = "print!" - fn1 AST { astNode = ASTString str } = + fn1 AST { an = ASTString str } = do liftIO $ putStr $ str return $ makeNonsenseAST ASTUnit fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 @@ -246,9 +246,9 @@ builtinPrint = (name, makeNonsenseAST $ ASTFunction Impure fn1) where builtinConcat :: (String, AST) builtinConcat = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "concat" - fn1 ast1@AST { astNode = ASTString str1 } = + fn1 ast1@AST { an = ASTString str1 } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTString str2 } = + fn2 AST { an = ASTString str2 } = return $ makeNonsenseAST $ ASTString $ str1 ++ str2 fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 @@ -256,14 +256,14 @@ builtinConcat = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinLen :: (String, AST) builtinLen = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "len" - fn1 AST { astNode = ASTString str } = + fn1 AST { an = ASTString str } = return $ makeNonsenseAST $ ASTInteger $ length str fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinFatal :: (String, AST) builtinFatal = (name, makeNonsenseAST $ ASTFunction Impure fn1) where name = "fatal!" - fn1 ast1@AST { astNode = ASTString str } = + fn1 ast1@AST { an = ASTString str } = throwL (astPos ast1) $ str fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 @@ -271,14 +271,14 @@ builtinFatal = (name, makeNonsenseAST $ ASTFunction Impure fn1) where builtinKind :: (String, AST) builtinKind = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "kind" - fn1 AST { astNode = ASTRecord identifier _} = + fn1 AST { an = ASTRecord identifier _} = return $ makeNonsenseAST $ ASTString identifier fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinReadFile :: (String, AST) builtinReadFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where name = "read-file!" - fn1 ast1@AST { astNode = ASTString filePath } = do + fn1 ast1@AST { an = ASTString filePath } = do contentsM <- liftIO $ safeReadFile filePath case contentsM of Just contents -> return $ makeNonsenseAST $ ASTString contents @@ -288,9 +288,9 @@ builtinReadFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where builtinWriteFile :: (String, AST) builtinWriteFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where name = "write-file!" - fn1 ast1@AST { astNode = ASTString filePath } = + fn1 ast1@AST { an = ASTString filePath } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTString content } = do + fn2 AST { an = ASTString content } = do resultM <- liftIO $ safeWriteFile filePath content case resultM of Just () -> return $ makeNonsenseAST $ ASTUnit @@ -301,9 +301,9 @@ builtinWriteFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where builtinAppendFile :: (String, AST) builtinAppendFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where name = "append-file!" - fn1 ast1@AST { astNode = ASTString filePath } = + fn1 ast1@AST { an = ASTString filePath } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where - fn2 AST { astNode = ASTString content } = do + fn2 AST { an = ASTString content } = do resultM <- liftIO $ safeAppendFile filePath content case resultM of Just () -> return $ makeNonsenseAST $ ASTUnit @@ -314,17 +314,17 @@ builtinAppendFile = (name, makeNonsenseAST $ ASTFunction Impure fn1) where builtinSortByFirst :: (String, AST) builtinSortByFirst = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "sort-by-first" - fn1 ast1@AST { astNode = ASTVector elems } = do + fn1 ast1@AST { an = ASTVector elems } = do pairs <- mapM elemToPair elems let sorted = L.sortBy (\(a, _) (b, _) -> compare a b) pairs let sortedASTS = map (\(k, v) -> makeNonsenseAST $ ASTVector [makeNonsenseAST $ ASTInteger k, v]) sorted return $ makeNonsenseAST $ ASTVector sortedASTS where - itemsToPair [AST { astNode = ASTInteger k }, v] = + itemsToPair [AST { an = ASTInteger k }, v] = return $ (k, v) itemsToPair items = throwL (astPos ast1) $ "invalid element in vector supplied to sort-by-first: " ++ show items - elemToPair AST { astNode = ASTVector items } = + elemToPair AST { an = ASTVector items } = itemsToPair items elemToPair ast2 = throwL (astPos ast2) $ argError1 name ast1 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 diff --git a/src/Interpreter.hs b/src/Interpreter.hs index d77840d..34fc6bb 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -9,6 +9,7 @@ module Interpreter ( import qualified Data.Map as M import qualified Data.List as L import qualified Data.Maybe as MB +import qualified Data.Bifunctor as B import Data.Function ( on ) import Control.Monad.State import Control.Monad.Except @@ -27,7 +28,7 @@ curryCall (arg:[]) (ASTFunction fIsPure f) = do f arg curryCall (arg:rest) f = do g <- curryCall rest f - case astNode g of + case an g of ASTFunction fIsPure f' -> do checkPurity fIsPure f' arg @@ -35,77 +36,72 @@ curryCall (arg:rest) f = do curryCall _ astFn = throwL "" $ "unreachable: curryCall, astFn: " ++ show astFn traverseAndReplace :: String -> AST -> AST -> AST -traverseAndReplace param arg ast@AST { astNode = ASTSymbol sym } +traverseAndReplace param arg ast@AST { an = ASTSymbol sym } | sym == param = arg | otherwise = ast -traverseAndReplace param arg ast@AST { astNode = ASTFunctionCall body } = - ast { astNode = ASTFunctionCall $ (map (traverseAndReplace param arg) body) } -traverseAndReplace param arg ast@AST { astNode = ASTVector vec } = - ast { astNode = ASTVector $ (map (traverseAndReplace param arg) vec) } -traverseAndReplace param arg ast@AST { astNode = ASTHashMap hmap } = - ast { astNode = ASTHashMap $ M.assocs hmap +traverseAndReplace param arg ast@AST { an = ASTFunctionCall body } = + ast { an = ASTFunctionCall $ (map (traverseAndReplace param arg) body) } +traverseAndReplace param arg ast@AST { an = ASTVector vec } = + ast { an = ASTVector $ (map (traverseAndReplace param arg) vec) } +traverseAndReplace param arg ast@AST { an = ASTHashMap hmap } = + ast { an = ASTHashMap $ M.assocs hmap $> L.concatMap (\(a, b) -> [a, b]) .> map (traverseAndReplace param arg) .> asPairs .> M.fromList } traverseAndReplace _ _ other = other -foldSymValPairs :: [(String, AST)] -> AST -> AST -foldSymValPairs [] body = body -foldSymValPairs ((sym, val):rest) body = - let replacedRestVals = map (snd .> traverseAndReplace sym val) rest - replacedRest = zip (map fst rest) (replacedRestVals) +foldScope :: Scope -> AST -> AST +foldScope [] body = body +foldScope ((sym, val):rest) body = + let replacedRest = map (B.second $ traverseAndReplace sym val) rest replacedBody = traverseAndReplace sym val body - in foldSymValPairs replacedRest replacedBody + in foldScope replacedRest replacedBody -letArgsToSymValPairs :: [AST] -> LContext (String, AST) -letArgsToSymValPairs args = - case args of - [AST { astNode = ASTSymbol symbol' }, value'] -> do - evaledValue <- evaluate value' - return (symbol', evaledValue) - [AST { astNode = ASTSymbol "lazy" }, AST { astNode = ASTSymbol symbol' }, value'] -> do - return (symbol', value') - other -> throwL (astPos $ head other) $ "let called with invalid args " ++ show other +processLetExpr :: Scope -> AST -> LContext Scope +processLetExpr scope letExpr = do + (sym, val) <- case letExpr of + AST { an = ASTFunctionCall [AST { an = ASTSymbol "let" }, AST { an = ASTSymbol symbol' }, value'] } -> + return (symbol', value') + other -> throwL (astPos other) $ "invalid let call in function body: " ++ show other + + return $ (sym, val) : scope -defineUserFunction :: AST -> [AST] -> LContext LFunction -defineUserFunction paramAst@AST { astNode = ASTSymbol param } exprs = return fn where +foldUserFunctionLetExprs :: Scope -> AST -> [AST] -> LContext LFunction +foldUserFunctionLetExprs scope paramAst@AST { an = ASTSymbol param } exprs = return fn where fn :: LFunction - fn arg = - let ret = do - let replacedExprs = map (traverseAndReplace param arg) exprs - let letExprs = take (length exprs - 1) replacedExprs - letSymValPairs <- letExprs - $> mapM (\case AST { astNode = ASTFunctionCall v } -> return $ drop 1 v - ast -> throwL (astPos ast) $ "unreachable: map letExprs, ast: " ++ show ast) - .> fmap (mapM $ letArgsToSymValPairs) .> join - let body = head $ drop (length exprs - 1) replacedExprs - let newBody = traverseAndReplace param arg body - $> foldSymValPairs letSymValPairs - evaluate newBody - in ret `catchError` - appendError ("in a function definition at " ++ astPos paramAst) - -defineUserFunction param exprs = throwL (astPos param) - $ "unreachable: defineUserFunction, param: " ++ show param ++ ", exprs: " ++ show exprs - -defineUserFunctionWithLetExprs :: [AST] -> [AST] -> LContext LFunction -defineUserFunctionWithLetExprs [] exprs = + fn arg = ret `catchError` appendError ("in a function definition at " ++ astPos paramAst) where + ret = do + let letExprs = init exprs + + let localScopeWithArgs = (param, arg) : scope + localScope <- foldM processLetExpr localScopeWithArgs letExprs + + let body = last exprs + let newBody = foldScope localScope body + evaluate newBody + +foldUserFunctionLetExprs _ param exprs = throwL (astPos param) + $ "unreachable: foldUserFunctionLetExprs, param: " ++ show param ++ ", exprs: " ++ show exprs + +foldUserFunctionParams :: Scope -> [AST] -> [AST] -> LContext LFunction +foldUserFunctionParams scope [] exprs = -- the position info is nonsensical, but it should never get read anyway - defineUserFunction (makeNonsenseAST $ ASTSymbol "unit") exprs -defineUserFunctionWithLetExprs (param:[]) exprs = - defineUserFunction param exprs -defineUserFunctionWithLetExprs (AST { astNode = ASTSymbol param }:rest) exprs = return fn where + foldUserFunctionLetExprs scope (makeNonsenseAST $ ASTSymbol "unit") exprs +foldUserFunctionParams scope (param:[]) exprs = + foldUserFunctionLetExprs scope param exprs +foldUserFunctionParams scope (AST { an = ASTSymbol param }:rest) exprs = return fn where fn :: LFunction fn arg = do - let newExprs = map (traverseAndReplace param arg) exprs - ret <- defineUserFunctionWithLetExprs rest newExprs - -- The returned AST will not have the correct position info, but that's fine + let scopeWithCurrentArg = (param, arg) : scope + ret <- foldUserFunctionParams scopeWithCurrentArg rest exprs + -- The returned function AST will not have the correct position info or purity, but that's fine -- because the info is overridden in evaluateFunctionDef anyway. - -- Also, functions are naively considered pure here, but that's also fine - -- because purity too is overridden in evaluateFunctionDef. return $ makeNonsenseAST $ ASTFunction Pure ret -defineUserFunctionWithLetExprs (param:_) _ = throwL (astPos $ param) - $ "unreachable: defineUserFunctionWithLetExprs, param: " ++ show param +foldUserFunctionParams _ (param:_) _ = throwL (astPos $ param) + $ "unreachable: foldUserFunctionParams, param: " ++ show param + +defineUserFunction :: [AST] -> [AST] -> LContext LFunction +defineUserFunction = foldUserFunctionParams [] evaluateFunctionDef :: Purity -> [AST] -> LContext AST evaluateFunctionDef isPure asts = do @@ -117,7 +113,7 @@ evaluateFunctionDef isPure asts = do throwL (astPos defAst) $ "\\ or \\! called with " ++ show (length args) ++ " arguments" | otherwise -> return $ (head args', tail args') - AST { astNode = ASTVector params' } <- assertIsASTVector params'' + AST { an = ASTVector params' } <- assertIsASTVector params'' params <- mapM assertIsASTSymbol params' env <- getEnv @@ -126,22 +122,22 @@ evaluateFunctionDef isPure asts = do let shadowingParamM = L.find (asSymbol .> isParamNameShadowing) params case shadowingParamM of Just shadowingParam -> throwL (astPos shadowingParam) - $ "parameter is shadowing already defined symbol " ++ show (astNode shadowingParam) + $ "parameter is shadowing already defined symbol " ++ show (an shadowingParam) Nothing -> return () - let letExprs = take (length exprs - 1) exprs + let letExprs = init exprs let nonLetExprM = L.find (not . isLetAST) letExprs case nonLetExprM of Just nonLetExpr -> throwL (astPos nonLetExpr) $ "non-let expression in function definition before body: " ++ show nonLetExpr Nothing -> return () - fn <- defineUserFunctionWithLetExprs params exprs - return $ defAst { astNode = ASTFunction isPure fn } + fn <- defineUserFunction params exprs + return $ defAst { an = ASTFunction isPure fn } where - isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let" }:_) } = True + isLetAST AST { an = ASTFunctionCall (AST { an = ASTSymbol "let" }:_) } = True isLetAST _ = False - asSymbol AST { astNode = ASTSymbol sym } = sym + asSymbol AST { an = ASTSymbol sym } = sym asSymbol ast = error $ "unreachable: evaluateFunctionDef asSymbol, ast: " ++ show ast evaluateMatch :: [AST] -> LContext AST @@ -161,7 +157,7 @@ evaluateMatch asts = do evaledActual <- evaluate actualExpr ret <- matchPairs (actualExpr, evaledActual) pairs - return $ matchAst { astNode = astNode ret } + return $ matchAst { an = an ret } where matchPairs :: (AST, AST) -> [(AST, AST)] -> LContext AST matchPairs (actualExpr, evaledActual) [] = throwL (astPos actualExpr) @@ -181,11 +177,18 @@ evaluateLet asts = do d <- getDepth when (d > 1) $ throwL (astPos letAst) $ "let can only be called on the top level or in a function definition, current depth: " ++ show d - (symbol, value) <- letArgsToSymValPairs args + (symbol, value) <- case args of + [AST { an = ASTSymbol "lazy" }, AST { an = ASTSymbol symbol' }, value'] -> do + return (symbol', value') + [AST { an = ASTSymbol symbol' }, value'] -> do + evaledValue <- evaluate value' + return (symbol', evaledValue) + other -> throwL (astPos $ head other) $ "let called with invalid args " ++ show other + env <- getEnv when (MB.isJust $ resolveSymbol symbol env) $ throwL (astPos letAst) $ "symbol already defined: " ++ symbol insertEnv symbol value - return $ letAst { astNode = ASTUnit } + return $ letAst { an = ASTUnit } evaluateDebugEnv :: [AST] -> LContext AST evaluateDebugEnv asts = do @@ -197,7 +200,7 @@ evaluateDebugEnv asts = do let pad s = s ++ take (length longestKey + 4 - length s) (L.repeat ' ') let rows = pairs $> map (\(k, v) -> pad k ++ show v) liftIO $ mapM_ putStrLn rows - return $ envAst { astNode = ASTUnit } + return $ envAst { an = ASTUnit } evaluateImport :: [AST] -> LContext AST evaluateImport asts = do @@ -217,7 +220,7 @@ evaluateImport asts = do } case args of -- non-qualified import - [AST { astNode = ASTString path }] -> do + [AST { an = ASTString path }] -> do let checkedPath = if (not $ ".milch" `L.isSuffixOf` path) then (path ++ ".milch") else path @@ -225,7 +228,7 @@ evaluateImport asts = do env <- getEnv putEnv $ M.union importedEnv env - return $ importAst { astNode = ASTUnit } + return $ importAst { an = ASTUnit } _ -> throwL (astPos importAst) $ "invalid arguments passed to import: " ++ show args @@ -238,7 +241,7 @@ evaluateRecord asts = do when (d > 1) $ throwL (astPos recordAst) $ "record can only be called on the top level, current depth: " ++ show d case args of - (AST { astNode = ASTSymbol ns }:rest) -> do + (AST { an = ASTSymbol ns }:rest) -> do let nonSymFields = L.find (not . isSymbolAST) rest case nonSymFields of Just invalid -> throwL (astPos invalid) @@ -261,7 +264,7 @@ evaluateRecord asts = do makeFnCreate _ _ = error $ "unreachable: makeFnCreate " ++ fnCreateName let createFn = makeFnCreate fields [] - insertEnv fnCreateName $ recordAst { astNode = ASTFunction Pure createFn } + insertEnv fnCreateName $ recordAst { an = ASTFunction Pure createFn } let makeGetFns [] = return $ () makeGetFns (param:restParams) = do @@ -283,16 +286,16 @@ evaluateRecord asts = do makeSetFns fields - return $ recordAst { astNode = ASTUnit } + return $ recordAst { an = ASTUnit } _ -> throwL (astPos recordAst) $ "invalid arguments passed to import: " ++ show args where - isSymbolAST AST { astNode = ASTSymbol _ } = True + isSymbolAST AST { an = ASTSymbol _ } = True isSymbolAST _ = False - extractRows (AST { astNode = ASTSymbol sym }:rest) = sym : extractRows rest + extractRows (AST { an = ASTSymbol sym }:rest) = sym : extractRows rest extractRows _ = [] - getFn fnName ast@AST { astNode = ASTRecord identifier record } = do + getFn fnName ast@AST { an = ASTRecord identifier record } = do when (not $ identifier `L.isPrefixOf` fnName) $ throwL (astPos ast) $ "invalid argument: " ++ fnName ++ " cannot operate on record " ++ identifier let (_, fnId) = separateNsIdPart fnName @@ -303,7 +306,7 @@ evaluateRecord asts = do getFn fnName ast = throwL (astPos ast) $ "invalid argument passed to " ++ fnName ++ ": " ++ (show ast) setFn fnName ast1 = do return $ makeNonsenseAST $ ASTFunction Pure $ fn where - fn ast2@AST { astNode = ASTRecord identifier record } = do + fn ast2@AST { an = ASTRecord identifier record } = do when (not $ identifier `L.isPrefixOf` fnName) $ throwL (astPos ast2) $ "invalid argument: " ++ fnName ++ " cannot operate on record " ++ identifier let (_, fnId) = separateNsIdPart fnName @@ -317,7 +320,7 @@ evaluateUserFunction children = do let fnAst = head children args = tail children fnEvaled <- evaluate fnAst - AST { astNode = astFn@(ASTFunction fIsPure _) } <- assertIsASTFunction fnEvaled + AST { an = astFn@(ASTFunction fIsPure _) } <- assertIsASTFunction fnEvaled checkPurity fIsPure updatePurity fIsPure @@ -328,13 +331,13 @@ evaluateUserFunction children = do result <- curryCall (reverse doubleEvaledArgs) astFn -- todo: maybe remove double eval here? can't remember why it was added - return $ fnAst { astNode = astNode result } + return $ fnAst { an = an result } resolveSymbol :: String -> Env -> Maybe AST resolveSymbol = M.lookup evaluateSymbol :: AST -> LContext AST -evaluateSymbol ast@AST { astNode = ASTSymbol sym } = do +evaluateSymbol ast@AST { an = ASTSymbol sym } = do env <- getEnv let val = resolveSymbol sym env case val of @@ -343,14 +346,14 @@ evaluateSymbol ast@AST { astNode = ASTSymbol sym } = do evaluateSymbol ast = throwL (astPos ast) $ "unreachable: evaluateSymbol, ast: " ++ show ast evaluate :: AST -> LContext AST -evaluate ast@AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = +evaluate ast@AST { an = fnc@(ASTFunctionCall args@(x:_)) } = do config <- getConfig when (configPrintCallStack config) $ liftIO $ putStrLn $ "fn call: " ++ show fnc incrementDepth currentPurity <- getPurity - let task = case astNode x of + let task = case an x of -- remember to add these as reseved keywords in Builtins! ASTSymbol "\\" -> evaluateFunctionDef Pure args @@ -376,14 +379,14 @@ evaluate ast@AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = updatePurity currentPurity return ret -evaluate ast@AST { astNode = (ASTSymbol _) } = +evaluate ast@AST { an = (ASTSymbol _) } = evaluateSymbol ast -evaluate ast@AST { astNode = (ASTVector vec) } = +evaluate ast@AST { an = (ASTVector vec) } = do incrementDepth rets <- mapM evaluate vec `catchError` appendError ("when evaluating elements of vector " ++ show vec ++ " at " ++ astPos ast) decrementDepth - return $ ast { astNode = ASTVector rets } + return $ ast { an = ASTVector rets } evaluate other = return other @@ -421,7 +424,7 @@ runInlineScript' lineNo fileName src = do PrintEvaledAll -> liftIO $ mapM_ putStrLn (map show evaluated) PrintEvaledNonUnit -> do let evaledNonUnits = evaluated $> - filter (\case AST { astNode = ASTUnit } -> False + filter (\case AST { an = ASTUnit } -> False _ -> True) liftIO $ mapM_ putStrLn (map show evaledNonUnits) PrintEvaledOff -> return () diff --git a/src/Parser.hs b/src/Parser.hs index 3779fe5..959a630 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -20,9 +20,9 @@ validateBalance allowed asts = do $ throwL (astPos $ MB.fromJust curlyM) "unbalanced hash map" return asts where - parenM = L.find ((== ASTSymbol "(") . astNode) asts - bracketM = L.find ((== ASTSymbol "[") . astNode) asts - curlyM = L.find ((== ASTSymbol "{") . astNode) asts + parenM = L.find ((== ASTSymbol "(") . an) asts + bracketM = L.find ((== ASTSymbol "[") . an) asts + curlyM = L.find ((== ASTSymbol "{") . an) asts parseToken :: Token -> AST parseToken (Token token tr tc tf) @@ -42,33 +42,33 @@ parseToken (Token token tr tc tf) removeQuotes s = drop 1 s $> take (length s - 2) isBoolean t = t `elem` ["true", "false"] asBoolean t = t == "true" - ast node = AST { astNode = node, astRow = tr, astColumn = tc, astFileName = tf } + ast node = AST { an = node, astRow = tr, astColumn = tc, astFileName = tf } _parse :: [AST] -> [Token] -> LContext [AST] _parse acc' [] = do acc <- validateBalance [] acc' return $ reverse acc _parse acc (Token { tokenContent = ")" }:rest) = do - let children' = takeWhile (astNode .> (/= ASTSymbol "(")) acc + let children' = takeWhile (an .> (/= ASTSymbol "(")) acc children <- validateBalance ["("] children' - let openParen = MB.fromJust $ L.find (astNode .> (== ASTSymbol "(")) acc - let fnCall = openParen { astNode = ASTFunctionCall (reverse children) } + let openParen = MB.fromJust $ L.find (an .> (== ASTSymbol "(")) acc + let fnCall = openParen { an = ASTFunctionCall (reverse children) } let newAcc = fnCall : drop (length children + 1) acc _parse newAcc rest _parse acc (Token { tokenContent = "]" }:rest) = do - let children' = takeWhile (astNode .> (/= ASTSymbol "[")) acc + let children' = takeWhile (an .> (/= ASTSymbol "[")) acc children <- validateBalance ["["] children' - let openBracket = MB.fromJust $ L.find (astNode .> (== ASTSymbol "[")) acc - let vec = openBracket { astNode = ASTVector (reverse 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 _parse newAcc rest _parse acc (Token { tokenContent = "}" }:rest) = do - let children' = takeWhile (astNode .> (/= ASTSymbol "{")) acc + let children' = takeWhile (an .> (/= ASTSymbol "{")) acc children <- validateBalance ["{"] children' - let openCurly = MB.fromJust $ L.find (astNode .> (== ASTSymbol "{")) acc + let openCurly = MB.fromJust $ L.find (an .> (== ASTSymbol "{")) acc pairs <- asPairsM (reverse children) `catchError` \(LException _ e) -> throwL (astPos openCurly) e - let hmap = openCurly { astNode = ASTHashMap (M.fromList pairs) } + let hmap = openCurly { an = ASTHashMap (M.fromList pairs) } let newAcc = hmap : drop (length children + 1) acc _parse newAcc rest _parse acc (token:rest) = diff --git a/src/Utils.hs b/src/Utils.hs index 785c644..127e7c0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -31,6 +31,7 @@ data Config = Config { } type Env = M.Map String AST +type Scope = [(String, AST)] data LState = LState { stateConfig :: Config, @@ -133,14 +134,14 @@ data ASTNode | ASTHole data AST = AST { - astNode :: ASTNode, + an :: ASTNode, astRow :: Int, astColumn :: Int, astFileName :: String } instance (Show AST) where - show (AST { astNode = node }) = show node + show (AST { an = node }) = show node instance (Show ASTNode) where show (ASTInteger n) = show n @@ -163,7 +164,7 @@ instance (Show ASTNode) where show ASTHole = "" instance (Eq AST) where - AST { astNode = node1 } == AST { astNode = node2 } = node1 == node2 + AST { an = node1 } == AST { an = node2 } = node1 == node2 instance (Eq ASTNode) where ASTInteger a == ASTInteger b = a == b @@ -180,7 +181,7 @@ instance (Eq ASTNode) where _ == _ = False instance (Ord AST) where - AST { astNode = node1 } <= AST { astNode = node2 } = node1 <= node2 + AST { an = node1 } <= AST { an = node2 } = node1 <= node2 instance (Ord ASTNode) where ASTInteger a <= ASTInteger b = a <= b @@ -197,32 +198,32 @@ instance (Ord ASTNode) where _ <= _ = False assertIsASTFunction :: AST -> LContext AST -assertIsASTFunction ast@(AST { astNode = node }) = case node of +assertIsASTFunction ast@(AST { an = node }) = case node of (ASTFunction _ _) -> return ast _ -> throwL (astPos ast) $ show node ++ " is not a function" assertIsASTInteger :: AST -> LContext AST -assertIsASTInteger ast@(AST { astNode = node }) = case node of +assertIsASTInteger ast@(AST { an = node }) = case node of (ASTInteger _) -> return ast _ -> throwL (astPos ast) $ show node ++ " is not an integer" assertIsASTSymbol :: AST -> LContext AST -assertIsASTSymbol ast@(AST { astNode = node }) = case node of +assertIsASTSymbol ast@(AST { an = node }) = case node of (ASTSymbol _) -> return ast _ -> throwL (astPos ast) $ show node ++ " is not a symbol" assertIsASTVector :: AST -> LContext AST -assertIsASTVector ast@(AST { astNode = node }) = case node of +assertIsASTVector ast@(AST { an = node }) = case node of (ASTVector _) -> return ast _ -> throwL (astPos ast) $ show node ++ " is not a vector" assertIsASTString :: AST -> LContext AST -assertIsASTString ast@(AST { astNode = node }) = case node of +assertIsASTString ast@(AST { an = node }) = case node of (ASTString _) -> return ast _ -> throwL (astPos ast) $ show node ++ " is not a string" assertIsASTFunctionCall :: AST -> LContext AST -assertIsASTFunctionCall ast@(AST { astNode = node }) = case node of +assertIsASTFunctionCall ast@(AST { an = node }) = case node of (ASTFunctionCall _) -> return ast _ -> throwL (astPos ast) $ show node ++ " is not a function call or body" @@ -271,7 +272,7 @@ makeNonsenseToken content = makeNonsenseAST :: ASTNode -> AST makeNonsenseAST node = - AST { astNode = node, astRow = -1, astColumn = -1, astFileName = "nonsense"} + AST { an = node, astRow = -1, astColumn = -1, astFileName = "nonsense"} astPos :: AST -> String astPos AST { astRow = r, astColumn = c, astFileName = f } = f ++ ":" ++ show r ++ ":" ++ show c -- cgit v1.3