Add :tag AST, refactor core to use it

4 files changed, 27 insertions, 9 deletions

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 -> "<pure fn>"
         Impure -> "<impure fn>"
-    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 = "<unit>"
@@ -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