aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--core/maybe.milch12
-rw-r--r--core/result.milch16
-rw-r--r--lang.cabal6
-rw-r--r--package.yaml2
-rw-r--r--src/Builtins.hs4
-rw-r--r--src/Interpreter.hs10
-rw-r--r--src/Parser.hs3
-rw-r--r--src/Utils.hs19
-rw-r--r--stack.yaml2
-rw-r--r--stack.yaml.lock14
-rw-r--r--test/Spec.hs12
-rw-r--r--todo.md1
12 files changed, 76 insertions, 25 deletions
diff --git a/core/maybe.milch b/core/maybe.milch
index 71d88e1..9c0d3ac 100644
--- a/core/maybe.milch
+++ b/core/maybe.milch
@@ -6,15 +6,15 @@
(let Maybe/map (\[f m]
(match (kind m)
- "Maybe/Just" (Maybe/just (f (Maybe/Just/get-value m)))
- "Maybe/Nothing" (Maybe/nothing))))
+ :Maybe/Just (Maybe/just (f (Maybe/Just/get-value m)))
+ :Maybe/Nothing (Maybe/nothing))))
(let Maybe/and-then (\[f m]
(match (kind m)
- "Maybe/Just" (f (Maybe/Just/get-value m))
- "Maybe/Nothing" (Maybe/nothing))))
+ :Maybe/Just (f (Maybe/Just/get-value m))
+ :Maybe/Nothing (Maybe/nothing))))
(let Maybe/default (\[default m]
(match (kind m)
- "Maybe/Just" (Maybe/Just/get-value m)
- "Result/Ex" default)))
+ :Maybe/Just (Maybe/Just/get-value m)
+ :Result/Ex default)))
diff --git a/core/result.milch b/core/result.milch
index 897a540..f122ee6 100644
--- a/core/result.milch
+++ b/core/result.milch
@@ -6,20 +6,20 @@
(let Result/map (\[f m]
(match (kind m)
- "Result/Ok" (Result/ok (f (Result/Ok/get-value m)))
- "Result/Ex" m)))
+ :Result/Ok (Result/ok (f (Result/Ok/get-value m)))
+ :Result/Ex m)))
(let Result/map-ex (\[f m]
(match (kind m)
- "Result/Ok" m
- "Result/Ex" (Result/ex (f (Result/Ex/get-value m))))))
+ :Result/Ok m
+ :Result/Ex (Result/ex (f (Result/Ex/get-value m))))))
(let Result/and-then (\[f m]
(match (kind m)
- "Result/Ok" (f (Result/Ok/get-value m))
- "Result/Ex" m)))
+ :Result/Ok (f (Result/Ok/get-value m))
+ :Result/Ex m)))
(let Result/try (\[catch-f m]
(match (kind m)
- "Result/Ok" (Result/Ok/get-value m)
- "Result/Ex" (catch-f (Result/Ex/get-value m)))))
+ :Result/Ok (Result/Ok/get-value m)
+ :Result/Ex (catch-f (Result/Ex/get-value m)))))
diff --git a/lang.cabal b/lang.cabal
index ba65e25..b4c7793 100644
--- a/lang.cabal
+++ b/lang.cabal
@@ -39,10 +39,12 @@ library
HUnit ==1.6.2.0
, base >=4.7 && <5
, containers
+ , farmhash ==0.1.0.5
, haskeline ==0.8.2
, mtl
, regex-tdfa ==1.3.2
, text
+ , utf8-string ==1.0.2
default-language: Haskell2010
executable lang-exe
@@ -56,11 +58,13 @@ executable lang-exe
HUnit ==1.6.2.0
, base >=4.7 && <5
, containers
+ , farmhash ==0.1.0.5
, haskeline ==0.8.2
, lang
, mtl
, regex-tdfa ==1.3.2
, text
+ , utf8-string ==1.0.2
default-language: Haskell2010
test-suite lang-test
@@ -76,9 +80,11 @@ test-suite lang-test
HUnit ==1.6.2.0
, base >=4.7 && <5
, containers
+ , farmhash ==0.1.0.5
, haskeline ==0.8.2
, lang
, mtl
, regex-tdfa ==1.3.2
, text
+ , utf8-string ==1.0.2
default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
index ec09966..e8c18e7 100644
--- a/package.yaml
+++ b/package.yaml
@@ -27,6 +27,8 @@ dependencies:
- haskeline == 0.8.2
- regex-tdfa == 1.3.2
- HUnit == 1.6.2.0
+- farmhash == 0.1.0.5
+- utf8-string == 1.0.2
ghc-options:
- -Wall
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
diff --git a/stack.yaml b/stack.yaml
index 46f3b1b..60a5a7a 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -10,3 +10,5 @@ extra-deps:
- regex-tdfa-1.3.2
- call-stack-0.4.0
- HUnit-1.6.2.0
+ - farmhash-0.1.0.5
+ - utf8-string-1.0.2
diff --git a/stack.yaml.lock b/stack.yaml.lock
index d8ea52a..a953ac9 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -39,4 +39,18 @@ packages:
sha256: 4f20a5a33866171260d0ee1e256c27f53cc84d37a68d498c3e12347f4e3d05b4
original:
hackage: HUnit-1.6.2.0
+- completed:
+ hackage: farmhash-0.1.0.5@sha256:908f8cb5fb2b232086254aac0fdfd0bf120fb102df716ebf4ad1352685f0d93b,1972
+ pantry-tree:
+ size: 786
+ sha256: 40aa3da3e252e23e8e8318aae0d0b98b2cd09a75a45ceaf2778daf0117255901
+ original:
+ hackage: farmhash-0.1.0.5
+- completed:
+ hackage: utf8-string-1.0.2@sha256:79416292186feeaf1f60e49ac5a1ffae9bf1b120e040a74bf0e81ca7f1d31d3f,1538
+ pantry-tree:
+ size: 601
+ sha256: 0863c3c9b6ee24dd38873c62e38ac46dd50aff2ea6b362beadf7f9b4a273c75f
+ original:
+ hackage: utf8-string-1.0.2
snapshots: []
diff --git a/test/Spec.hs b/test/Spec.hs
index e27159c..6cb9fac 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -89,7 +89,7 @@ e2eTests = testGroup "e2e" [
do let env = makeEnv [builtinAdd2, builtinSubtract2, ("_", astHole)]
let script1 = "(let memo fibo (\\[n]\
- \(match n\
+ \ (match n\
\ 0 0\
\ 1 1\
\ _ (+ (fibo (- n 1)) (fibo (- n 2))))))\
@@ -99,6 +99,16 @@ e2eTests = testGroup "e2e" [
runInlineScript "<test>" script1
let expectedLastAST = astInteger 12586269025
+ assertEqual "" expectedLastAST (last gotASTs),
+
+ do let env = makeEnv [builtinAdd2, builtinEq2]
+ let script1 = "(let a :thing)\
+ \(let b :thing)\
+ \(eq? a b)"
+ (gotASTs, _) <- expectSuccessL env $
+ runInlineScript "<test>" script1
+
+ let expectedLastAST = astBoolean True
assertEqual "" expectedLastAST (last gotASTs)
]
diff --git a/todo.md b/todo.md
index 4efb8d4..608f87b 100644
--- a/todo.md
+++ b/todo.md
@@ -3,5 +3,4 @@
In order of priority
- Add a `catch` builtin for catching fatal errors
-- Add :keyword data type, use in core functions
- Write tests!

Want to contribute? Host your changes somewhere and send me the link: jan (at) sydanviita.fi. Also, check out my website.


forge.jan.systems — powered by cgit