aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Builtins.hs86
-rw-r--r--src/Interpreter.hs169
-rw-r--r--src/Parser.hs26
-rw-r--r--src/Utils.hs23
4 files changed, 154 insertions, 150 deletions
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)
+ 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
-defineUserFunction param exprs = throwL (astPos param)
- $ "unreachable: defineUserFunction, param: " ++ show param ++ ", exprs: " ++ show exprs
+ let body = last exprs
+ let newBody = foldScope localScope body
+ evaluate newBody
-defineUserFunctionWithLetExprs :: [AST] -> [AST] -> LContext LFunction
-defineUserFunctionWithLetExprs [] exprs =
+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 = "<hole>"
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

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