From bba047ae945ae7d7899d6e2c1610923bcedb0442 Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Mon, 5 Dec 2022 12:42:21 +0200 Subject: Implement purity checking --- app/Main.hs | 3 +- examples/impure-concept.lisp | 2 +- examples/purity-test.lisp | 20 +++++++++++++ src/Builtins.hs | 70 +++++++++++++++++++++++--------------------- src/Interpreter.hs | 69 ++++++++++++++++++++++++++++++------------- src/Tokenizer.hs | 2 +- src/Utils.hs | 34 ++++++++++++++++++--- 7 files changed, 139 insertions(+), 61 deletions(-) create mode 100644 examples/purity-test.lisp diff --git a/app/Main.hs b/app/Main.hs index 34fe23a..0bfda2c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -59,7 +59,8 @@ main = do let config = parseArgs initialConfig args ls = LState { stateConfig = config, stateEnv = emptyEnv { envImported = builtinEnv }, - stateDepth = 0 } + stateDepth = 0, + statePure = False } if (configShowHelp config) then do putStrLn $ "Usage: " ++ progName ++ " # to open REPL" diff --git a/examples/impure-concept.lisp b/examples/impure-concept.lisp index f769424..893b29e 100644 --- a/examples/impure-concept.lisp +++ b/examples/impure-concept.lisp @@ -9,4 +9,4 @@ (let! f (\[x] x)) ; impure function -(let! g (\![x] (print! x))) +(let! g! (\![x] (print! x))) diff --git a/examples/purity-test.lisp b/examples/purity-test.lisp new file mode 100644 index 0000000..31e82d3 --- /dev/null +++ b/examples/purity-test.lisp @@ -0,0 +1,20 @@ +(let! f (\[x] x)) +(f 10) + +(let! g! (\![x] (print! x))) +(g! "foo") + +(let! h (\[x] (g! x))) +(h "bar") + +(let! main! (\![] + (print! (fmt "{0}\n" ["main"])) + )) + +(main!) + +(let! pure-main (\[] + (print! (fmt "{0}\n" ["pure-main"])) + )) + +(pure-main) diff --git a/src/Builtins.hs b/src/Builtins.hs index 9fe8f21..e56d00d 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -54,67 +54,67 @@ argError3 fn arg1 arg2 arg3 = "invalid arguments to " ++ fn ++ ": " ++ show arg1 ++ ", " ++ show arg2 ++ ", " ++ show arg3 reservedKeyword :: String -> (String, AST) -reservedKeyword name = (name, makeNonsenseAST $ ASTFunction fn1) where +reservedKeyword name = (name, makeNonsenseAST $ ASTFunction True fn1) where fn1 ast1 = throwL (astPos ast1) $ "unreachable: " ++ name ++ " is a reserved word" -- BUILTINS builtinAdd2 :: (String, AST) -builtinAdd2 = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinAdd2 = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "+" fn1 ast1@AST { astNode = ASTInteger a } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 AST { astNode = ASTInteger b } = return $ makeNonsenseAST $ ASTInteger $ a + b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1@AST { astNode = ASTDouble a } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 AST { astNode = ASTDouble b } = return $ makeNonsenseAST $ ASTDouble $ a + b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinSubtract2 :: (String, AST) -builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinSubtract2 = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "-" fn1 ast1@AST { astNode = ASTInteger a } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 AST { astNode = ASTInteger b } = return $ makeNonsenseAST $ ASTInteger $ a - b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1@AST { astNode = ASTDouble a } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 AST { astNode = ASTDouble b } = return $ makeNonsenseAST $ ASTDouble $ a - b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinMultiply2 :: (String, AST) -builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinMultiply2 = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "*" fn1 ast1@AST { astNode = ASTInteger a } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 AST { astNode = ASTInteger b } = return $ makeNonsenseAST $ ASTInteger $ a * b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1@AST { astNode = ASTDouble a } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 AST { astNode = ASTDouble b } = return $ makeNonsenseAST $ ASTDouble $ a * b fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinDivide2 :: (String, AST) -builtinDivide2 = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinDivide2 = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "/" fn1 ast1@AST { astNode = ASTInteger a } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 ast2@AST { astNode = 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 } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 ast2@AST { astNode = ASTDouble b } = do when (b == 0) $ throwL (astPos ast2) $ "division by zero" return $ makeNonsenseAST $ ASTDouble $ a / b @@ -122,48 +122,52 @@ builtinDivide2 = (name, makeNonsenseAST $ ASTFunction fn1) where fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinEq2 :: (String, AST) -builtinEq2 = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinEq2 = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "eq?" fn1 ast1 = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 == ast2 builtinLt2 :: (String, AST) -builtinLt2 = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinLt2 = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "lt?" fn1 ast1 = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 <= ast2 builtinFloor :: (String, AST) -builtinFloor = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinFloor = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "floor" fn1 AST { astNode = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinToDouble :: (String, AST) -builtinToDouble = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinToDouble = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "to-double" fn1 AST { astNode = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinFmt :: (String, AST) -builtinFmt = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinFmt = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "fmt" fn1 ast1@AST { astNode = ASTString str } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 AST { astNode = ASTVector replacements } = return $ makeNonsenseAST $ ASTString $ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str) fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 + replaceAll :: Int -> [AST] -> T.Text -> T.Text replaceAll _ [] text = text replaceAll n (x:xs) text = - let text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ show x) text + let xRepr = case x of + AST { astNode = ASTString s } -> s + _ -> show x + text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ xRepr) text in replaceAll (n + 1) xs text' builtinHead :: (String, AST) -builtinHead = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinHead = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "head" fn1 ast1@AST { astNode = ASTVector vec } = do when (length vec == 0) $ throwL (astPos ast1) $ name ++ " of empty vector" @@ -171,7 +175,7 @@ builtinHead = (name, makeNonsenseAST $ ASTFunction fn1) where fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinTail :: (String, AST) -builtinTail = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinTail = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "tail" fn1 ast1@AST { astNode = ASTVector vec } = do when (length vec == 0) $ throwL (astPos ast1) $ name ++ " of empty vector" @@ -179,12 +183,12 @@ builtinTail = (name, makeNonsenseAST $ ASTFunction fn1) where fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinSubstr :: (String, AST) -builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinSubstr = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "substr" fn1 ast1@AST { astNode = ASTInteger at } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 ast2@AST { astNode = ASTInteger len } = - return $ makeNonsenseAST $ ASTFunction $ fn3 where + return $ makeNonsenseAST $ ASTFunction True $ fn3 where fn3 AST { astNode = ASTString str } = return $ makeNonsenseAST $ ASTString $ drop at .> take len $ str fn3 ast3 = throwL (astPos ast3) $ argError3 name ast1 ast2 ast3 @@ -192,16 +196,16 @@ builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinPrepend :: (String, AST) -builtinPrepend = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinPrepend = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "prepend" fn1 ast1 = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 AST { astNode = ASTVector vec } = return $ makeNonsenseAST $ ASTVector $ ast1 : vec fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 builtinPrint :: (String, AST) -builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinPrint = (name, makeNonsenseAST $ ASTFunction False fn1) where name = "print!" fn1 AST { astNode = ASTString str } = do liftIO $ putStr $ str @@ -209,17 +213,17 @@ builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinConcat :: (String, AST) -builtinConcat = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinConcat = (name, makeNonsenseAST $ ASTFunction True fn1) where name = "concat" fn1 ast1@AST { astNode = ASTString str1 } = - return $ makeNonsenseAST $ ASTFunction $ fn2 where + return $ makeNonsenseAST $ ASTFunction True $ fn2 where fn2 AST { astNode = ASTString str2 } = return $ makeNonsenseAST $ ASTString $ str1 ++ str2 fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2 fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinFatal :: (String, AST) -builtinFatal = (name, makeNonsenseAST $ ASTFunction fn1) where +builtinFatal = (name, makeNonsenseAST $ ASTFunction False fn1) where name = "fatal!" fn1 ast1@AST { astNode = ASTString str } = throwL (astPos ast1) $ str diff --git a/src/Interpreter.hs b/src/Interpreter.hs index ce68270..aefd816 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -18,18 +18,30 @@ import Builtins import Tokenizer ( tokenize' ) import Parser ( parse ) -_curryCall :: [AST] -> LFunction -> LContext AST -_curryCall [] f = return $ (makeNonsenseAST $ ASTFunction f) -_curryCall (arg:[]) f = f arg -_curryCall (arg:rest) f = do - g <- _curryCall rest f +-- _curryCall :: [AST] -> ASTNode -> LContext AST +-- _curryCall (arg:[]) f = f arg +-- _curryCall (arg:rest) f = do +-- g <- _curryCall rest f +-- case astNode g of +-- ASTFunction fIsPure f' -> f' arg +-- other -> throwL (astPos g) $ "cannot call value " ++ show other ++ " as a function" +-- _curryCall _ astFn = throwL "" $ "unreachable: _curryCall, astFn: " ++ show astFn + +curryCall :: [AST] -> ASTNode -> LContext AST +curryCall [] (ASTFunction fIsPure f) = do + checkPurity fIsPure + f (makeNonsenseAST ASTUnit) +curryCall (arg:[]) (ASTFunction fIsPure f) = do + checkPurity fIsPure + f arg +curryCall (arg:rest) f = do + g <- curryCall rest f case astNode g of - ASTFunction f' -> f' arg + ASTFunction fIsPure f' -> do + checkPurity fIsPure + f' arg other -> throwL (astPos g) $ "cannot call value " ++ show other ++ " as a function" - -curryCall :: [AST] -> LFunction -> LContext AST -curryCall [] f = f (makeNonsenseAST ASTUnit) -curryCall args f = _curryCall args f +curryCall _ astFn = throwL "" $ "unreachable: curryCall, astFn: " ++ show astFn traverseAndReplace :: String -> AST -> AST -> AST traverseAndReplace param arg ast@AST { astNode = ASTSymbol sym } @@ -96,20 +108,22 @@ defineUserFunctionWithLetExprs (AST { astNode = ASTSymbol param }:rest) exprs = 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 - -- because the info is overridden in evaluateFunctionDef anyway - return $ makeNonsenseAST $ ASTFunction $ ret + -- The returned AST will not have the correct position info, 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 True ret defineUserFunctionWithLetExprs (param:_) _ = throwL (astPos $ param) $ "unreachable: defineUserFunctionWithLetExprs, param: " ++ show param -evaluateFunctionDef :: [AST] -> LContext AST -evaluateFunctionDef asts = do +evaluateFunctionDef :: Bool -> [AST] -> LContext AST +evaluateFunctionDef isPure asts = do let defAst = head asts args = tail asts (params'', exprs) <- case args of args' | length args' < 2 -> - throwL (astPos defAst) $ "\\ called with " ++ show (length args) ++ " arguments" + throwL (astPos defAst) $ "\\ or \\! called with " ++ show (length args) ++ " arguments" | otherwise -> return $ (head args', tail args') AST { astNode = ASTVector params' } <- assertIsASTVector params'' @@ -132,7 +146,7 @@ evaluateFunctionDef asts = do Nothing -> return () fn <- defineUserFunctionWithLetExprs params exprs - return $ defAst { astNode = ASTFunction fn } + return $ defAst { astNode = ASTFunction isPure fn } where isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let!" }:_) } = True isLetAST _ = False @@ -209,7 +223,8 @@ evaluateImport asts = do let initialState = LState { stateConfig = config, stateDepth = 0, - stateEnv = emptyEnv { envImported = builtinEnv } + stateEnv = emptyEnv { envImported = builtinEnv }, + statePure = False } case args of -- non-qualified import @@ -229,11 +244,15 @@ evaluateUserFunction children = do let fnAst = head children args = tail children fnEvaled <- evaluate fnAst - AST { astNode = (ASTFunction fn) } <- assertIsASTFunction fnEvaled + AST { astNode = astFn@(ASTFunction fIsPure _) } <- assertIsASTFunction fnEvaled + + checkPurity fIsPure + updatePurity fIsPure + evaledArgs <- mapM evaluate args doubleEvaledArgs <- mapM evaluate evaledArgs - result <- curryCall (reverse doubleEvaledArgs) fn + result <- curryCall (reverse doubleEvaledArgs) astFn -- todo: maybe remove double eval here? can't remember why it was added return $ fnAst { astNode = astNode result } @@ -261,10 +280,15 @@ evaluate ast@AST { astNode = 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 -- remember to add these as reseved keywords in Builtins! ASTSymbol "\\" -> - evaluateFunctionDef args + evaluateFunctionDef True args + ASTSymbol "\\!" -> + evaluateFunctionDef False args ASTSymbol "match" -> evaluateMatch args ASTSymbol "let!" -> @@ -278,7 +302,10 @@ evaluate ast@AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } = ret <- task `catchError` appendError ("when calling function " ++ show x ++ " at " ++ astPos ast) + decrementDepth + updatePurity currentPurity + return ret evaluate ast@AST { astNode = (ASTSymbol _) } = evaluateSymbol ast diff --git a/src/Tokenizer.hs b/src/Tokenizer.hs index b38e568..96a1c5a 100644 --- a/src/Tokenizer.hs +++ b/src/Tokenizer.hs @@ -65,7 +65,7 @@ _tokenize fileName acc current (x:xs) tokenColumn = tColumn $ head cur, tokenFileName = fileName } in _tokenize fileName (token : acc) [] xs - | tChar x `elem` ['(', ')', '[', ']', '{', '}', '\\'] = + | tChar x `elem` ['(', ')', '[', ']', '{', '}'] = let cur = reverse current token1 = Token { tokenContent = [tChar x], diff --git a/src/Utils.hs b/src/Utils.hs index c215b2e..0cc17bd 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -38,7 +38,8 @@ emptyEnv = Env { data LState = LState { stateConfig :: Config, stateEnv :: Env, - stateDepth :: Int + stateDepth :: Int, + statePure :: LIsPure } type LineNo = Int @@ -91,6 +92,28 @@ getDepth = do s <- get return $ stateDepth s +getPurity :: LContext LIsPure +getPurity = do + s <- get + return $ statePure s + +isAllowedPurity :: LIsPure -> LContext Bool +isAllowedPurity purity = do + s <- get + let currentPurity = statePure s + return $ case currentPurity of + False -> True -- if currently in impure context (false), all calls are ok + True -> purity == True -- but if in pure context (true), only pure calls are ok + +updatePurity :: LIsPure -> LContext () +updatePurity purity = do + modify (\s -> s { statePure = purity }) + +checkPurity :: LIsPure -> LContext () +checkPurity purity = do + purityOk <- isAllowedPurity purity + when (not purityOk) $ throwL "" $ "cannot call impure function in pure context" + data Token = Token { tokenContent :: String, tokenRow :: Int, @@ -104,6 +127,7 @@ instance (Eq Token) where instance (Show Token) where show token = show $ tokenContent token +type LIsPure = Bool type LFunction = AST -> LContext AST data ASTNode @@ -115,7 +139,7 @@ data ASTNode | ASTVector [AST] | ASTFunctionCall [AST] | ASTHashMap (M.Map AST AST) - | ASTFunction LFunction + | ASTFunction LIsPure LFunction | ASTUnit | ASTHole @@ -140,7 +164,9 @@ instance (Show ASTNode) where show (ASTHashMap m) = let flattenMap = M.assocs .> L.concatMap (\(k, v) -> [k, v]) in "{" ++ L.intercalate " " (map show $ flattenMap m) ++ "}" - show (ASTFunction _) = "" + show (ASTFunction isPure _) = case isPure of + True -> "" + False -> "" show ASTUnit = "" show ASTHole = "" @@ -180,7 +206,7 @@ instance (Ord ASTNode) where assertIsASTFunction :: AST -> LContext AST assertIsASTFunction ast@(AST { astNode = node }) = case node of - (ASTFunction _) -> return ast + (ASTFunction _ _) -> return ast _ -> throwL (astPos ast) $ show node ++ " is not a function" assertIsASTInteger :: AST -> LContext AST -- cgit v1.3