From 723fa29e5ceb2f7ee4a13632ccfe3acf5e8808c2 Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Thu, 8 Dec 2022 13:16:16 +0200 Subject: Add :tag AST, refactor core to use it --- src/Builtins.hs | 4 ++-- src/Interpreter.hs | 10 +++++----- src/Parser.hs | 3 +++ src/Utils.hs | 19 +++++++++++++++++-- 4 files changed, 27 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/Builtins.hs b/src/Builtins.hs index e87cb09..751be12 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -274,8 +274,8 @@ builtinFatal = (name, makeNonsenseAST $ ASTFunction Impure fn1) where builtinKind :: (String, AST) builtinKind = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "kind" - fn1 AST { an = ASTRecord identifier _} = - return $ makeNonsenseAST $ ASTString identifier + fn1 AST { an = ASTRecord tagHash identifier _} = + return $ makeNonsenseAST $ ASTTag tagHash identifier fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1 builtinReadFile :: (String, AST) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 585667b..c5c19e0 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -162,7 +162,7 @@ evaluateMatch asts = do matchPairs :: (AST, AST) -> [(AST, AST)] -> LContext AST matchPairs (actualExpr, evaledActual) [] = throwL (astPos actualExpr) $ "matching case not found when matching on expression: " ++ show actualExpr - ++ " (actual value: " ++ show evaledActual ++ ")" + ++ " (evaled value: " ++ show evaledActual ++ ")" matchPairs (actualExpr, evaledActual) ((matcher, branch):restPairs) = do evaledMatcher <- evaluate matcher if evaledActual == evaledMatcher @@ -261,7 +261,7 @@ evaluateRecord asts = do makeFnCreate (param:[]) argsAcc = fn where fn arg = do let record = M.fromList $ (param, arg) : argsAcc - return $ makeNonsenseAST $ ASTRecord ns record + return $ makeNonsenseAST $ ASTRecord (computeTagN ns) ns record makeFnCreate (param:restParams) argsAcc = fn where fn :: LFunction fn arg = return $ makeNonsenseAST $ ASTFunction Pure $ @@ -301,7 +301,7 @@ evaluateRecord asts = do isSymbolAST _ = False extractRows (AST { an = ASTSymbol sym }:rest) = sym : extractRows rest extractRows _ = [] - getFn fnName ast@AST { an = 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 @@ -312,13 +312,13 @@ 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 { an = ASTRecord identifier record } = do + fn ast2@AST { an = ASTRecord tagHash identifier record } = do when (not $ identifier `L.isPrefixOf` fnName) $ throwL (astPos ast2) $ "invalid argument: " ++ fnName ++ " cannot operate on record " ++ identifier let (_, fnId) = separateNsIdPart fnName let fieldId = drop 4 fnId let newRecord = M.insert fieldId ast1 record - return $ makeNonsenseAST $ ASTRecord identifier newRecord + return $ makeNonsenseAST $ ASTRecord tagHash identifier newRecord fn ast2 = throwL (astPos ast2) $ "invalid argument passed to " ++ fnName ++ ": " ++ (show ast2) data ReifyResult diff --git a/src/Parser.hs b/src/Parser.hs index 959a630..e7c0701 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -26,6 +26,8 @@ validateBalance allowed asts = do parseToken :: Token -> AST parseToken (Token token tr tc tf) + | isTag token = let tok = tail token + in ast $ ASTTag (computeTagN tok) tok | isString token = ast $ ASTString $ removeQuotes token | isInteger token = ast $ ASTInteger (read token) | isDouble token = ast $ ASTDouble (read token) @@ -39,6 +41,7 @@ parseToken (Token token tr tc tf) isDouble :: String -> Bool isDouble t = t =~ doubleRegex isString t = "\"" `L.isPrefixOf` t + isTag t = ":" `L.isPrefixOf` t && length t > 1 removeQuotes s = drop 1 s $> take (length s - 2) isBoolean t = t `elem` ["true", "false"] asBoolean t = t == "true" diff --git a/src/Utils.hs b/src/Utils.hs index 0f0654c..c4866ac 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -8,6 +8,9 @@ import qualified Data.Map as M import qualified Data.List as L import qualified Data.Char as C import qualified Data.Text as T +import qualified FarmHash as FH +import qualified Data.ByteString.UTF8 as BSU +import Data.Word as W -- TYPES @@ -122,6 +125,7 @@ data Purity = Pure | Impure deriving Eq type LFunction = AST -> LContext AST type LRecord = M.Map String AST +type TagHash = Int data ASTNode = ASTInteger Integer @@ -129,11 +133,12 @@ data ASTNode | ASTSymbol String | ASTBoolean Bool | ASTString String + | ASTTag TagHash String | ASTVector [AST] | ASTFunctionCall [AST] | ASTHashMap (M.Map AST AST) | ASTFunction Purity LFunction - | ASTRecord String LRecord + | ASTRecord TagHash String LRecord | ASTUnit | ASTHole @@ -153,6 +158,7 @@ instance (Show ASTNode) where show (ASTSymbol s) = s show (ASTBoolean b) = show b $> map C.toLower show (ASTString s) = show s + show (ASTTag hash s) = "<:" ++ s ++ " " ++ show hash ++ ">" show (ASTVector v) = "[" ++ L.intercalate " " (map show v) ++ "]" show (ASTFunctionCall v) = "(" ++ L.intercalate " " (map show v) ++ ")" show (ASTHashMap m) = @@ -161,7 +167,7 @@ instance (Show ASTNode) where show (ASTFunction isPure _) = case isPure of Pure -> "" Impure -> "" - show (ASTRecord identifier record) = + show (ASTRecord _ identifier record) = let assocsStrList = map (\(k, v) -> k ++ ":" ++ show v) (M.assocs record) in "(" ++ identifier ++ " " ++ L.intercalate " " assocsStrList ++ ")" show ASTUnit = "" @@ -176,6 +182,7 @@ instance (Eq ASTNode) where ASTSymbol a == ASTSymbol b = a == b ASTBoolean a == ASTBoolean b = a == b ASTString a == ASTString b = a == b + ASTTag n _ == ASTTag m _ = n == m ASTVector a == ASTVector b = a == b ASTFunctionCall a == ASTFunctionCall b = a == b ASTHashMap a == ASTHashMap b = a == b @@ -201,6 +208,14 @@ instance (Ord ASTNode) where _ <= ASTHole = True _ <= _ = False +computeTagNSeed :: W.Word64 +computeTagNSeed = 123 + +computeTagN :: String -> Int +computeTagN s = + let hash = FH.hash64WithSeed (BSU.fromString s) computeTagNSeed + in fromIntegral hash + assertIsASTFunction :: AST -> LContext AST assertIsASTFunction ast@(AST { an = node }) = case node of (ASTFunction _ _) -> return ast -- cgit v1.3