aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Builtins.hs124
-rw-r--r--src/Interpreter.hs49
-rw-r--r--src/Utils.hs21
3 files changed, 95 insertions, 99 deletions
diff --git a/src/Builtins.hs b/src/Builtins.hs
index f68cc78..281c6aa 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -55,108 +55,108 @@ argError3 fn arg1 arg2 arg3 =
reservedKeyword :: String -> (String, AST)
reservedKeyword name = (name, makeNonsenseAST $ ASTFunction fn1) where
- fn1 _ ast1 = throwL (astPos ast1) $ "unreachable: " ++ name ++ " is a reserved word"
+ fn1 ast1 = throwL (astPos ast1) $ "unreachable: " ++ name ++ " is a reserved word"
-- BUILTINS
builtinAdd2 :: (String, AST)
builtinAdd2 = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "+"
- fn1 _ ast1@AST { astNode = ASTInteger a } =
+ fn1 ast1@AST { astNode = ASTInteger a } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ AST { astNode = ASTInteger b } =
+ 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 } =
+ fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
+ fn1 ast1@AST { astNode = ASTDouble a } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ AST { astNode = ASTDouble b } =
+ 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
+ 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
name = "-"
- fn1 _ ast1@AST { astNode = ASTInteger a } =
+ fn1 ast1@AST { astNode = ASTInteger a } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ AST { astNode = ASTInteger b } =
+ 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 } =
+ fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
+ fn1 ast1@AST { astNode = ASTDouble a } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ AST { astNode = ASTDouble b } =
+ 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
+ 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
name = "*"
- fn1 _ ast1@AST { astNode = ASTInteger a } =
+ fn1 ast1@AST { astNode = ASTInteger a } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ AST { astNode = ASTInteger b } =
+ 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 } =
+ fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
+ fn1 ast1@AST { astNode = ASTDouble a } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ AST { astNode = ASTDouble b } =
+ 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
+ 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
name = "/"
- fn1 _ ast1@AST { astNode = ASTInteger a } =
+ fn1 ast1@AST { astNode = ASTInteger a } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ ast2@AST { astNode = ASTInteger b } =
+ 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 } =
+ fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
+ fn1 ast1@AST { astNode = ASTDouble a } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ ast2@AST { astNode = ASTDouble b } =
+ fn2 ast2@AST { astNode = 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
- fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1
+ fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
+ fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
builtinEq2 :: (String, AST)
builtinEq2 = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "eq?"
- fn1 _ ast1 =
+ fn1 ast1 =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 == ast2
+ fn2 ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 == ast2
builtinLt2 :: (String, AST)
builtinLt2 = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "lt?"
- fn1 _ ast1 =
+ fn1 ast1 =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 <= ast2
+ fn2 ast2 = return $ makeNonsenseAST $ ASTBoolean $ ast1 <= ast2
builtinFloor :: (String, AST)
builtinFloor = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "floor"
- fn1 _ AST { astNode = ASTDouble dbl } = return $ makeNonsenseAST $ ASTInteger $ floor dbl
- fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1
+ 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
name = "to-double"
- fn1 _ AST { astNode = ASTInteger int } = return $ makeNonsenseAST $ ASTDouble $ fromIntegral int
- fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1
+ 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
name = "fmt"
- fn1 _ ast1@AST { astNode = ASTString str } =
+ fn1 ast1@AST { astNode = ASTString str } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ AST { astNode = ASTVector replacements } =
+ 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
+ fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
+ fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
replaceAll _ [] text = text
replaceAll n (x:xs) text =
let text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ show x) text
@@ -165,63 +165,63 @@ builtinFmt = (name, makeNonsenseAST $ ASTFunction fn1) where
builtinHead :: (String, AST)
builtinHead = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "head"
- fn1 _ ast1@AST { astNode = ASTVector vec } =
+ fn1 ast1@AST { astNode = 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
+ fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
builtinTail :: (String, AST)
builtinTail = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "tail"
- fn1 _ ast1@AST { astNode = ASTVector vec } =
+ fn1 ast1@AST { astNode = 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
+ fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
builtinSubstr :: (String, AST)
builtinSubstr = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "substr"
- fn1 _ ast1@AST { astNode = ASTInteger at } =
+ fn1 ast1@AST { astNode = ASTInteger at } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ ast2@AST { astNode = ASTInteger len } =
+ fn2 ast2@AST { astNode = ASTInteger len } =
return $ makeNonsenseAST $ ASTFunction $ fn3 where
- fn3 _ AST { astNode = ASTString str } =
+ fn3 AST { astNode = 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
- fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1
+ fn3 ast3 = throwL (astPos ast3) $ argError3 name ast1 ast2 ast3
+ fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
+ fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
builtinPrepend :: (String, AST)
builtinPrepend = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "prepend"
- fn1 _ ast1 =
+ fn1 ast1 =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ AST { astNode = ASTVector vec } =
+ fn2 AST { astNode = ASTVector vec } =
return $ makeNonsenseAST $ ASTVector $ ast1 : vec
- fn2 _ ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
+ fn2 ast2 = throwL (astPos ast2) $ argError2 name ast1 ast2
builtinPrint :: (String, AST)
builtinPrint = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "print!"
- fn1 _ AST { astNode = ASTString str } =
+ fn1 AST { astNode = ASTString str } =
do liftIO $ putStr $ str
return $ makeNonsenseAST ASTUnit
- fn1 _ ast1 = throwL (astPos ast1) $ argError1 name ast1
+ fn1 ast1 = throwL (astPos ast1) $ argError1 name ast1
builtinConcat :: (String, AST)
builtinConcat = (name, makeNonsenseAST $ ASTFunction fn1) where
name = "concat"
- fn1 _ ast1@AST { astNode = ASTString str1 } =
+ fn1 ast1@AST { astNode = ASTString str1 } =
return $ makeNonsenseAST $ ASTFunction $ fn2 where
- fn2 _ AST { astNode = ASTString str2 } =
+ 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
+ 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
name = "fatal!"
- fn1 _ ast1@AST { astNode = ASTString str } =
+ fn1 ast1@AST { astNode = ASTString str } =
throwL (astPos ast1) $ str
- fn1 _ ast1 =
+ fn1 ast1 =
throwL (astPos ast1) $ argError1 name ast1
diff --git a/src/Interpreter.hs b/src/Interpreter.hs
index e649464..b745ff2 100644
--- a/src/Interpreter.hs
+++ b/src/Interpreter.hs
@@ -11,26 +11,24 @@ import Data.Function ( on )
import Control.Monad.State
import Control.Monad.Except
import Utils
--- import Debug.Trace
import Builtins
import Tokenizer ( tokenize )
import Parser ( parse )
type Depth = Int
-_curryCall :: Env -> [AST] -> LFunction -> LContext AST
-_curryCall _ [] f = return $ (makeNonsenseAST $ ASTFunction f)
-_curryCall env (arg:[]) f = f env arg
-_curryCall env (arg:rest) f = do
- g <- _curryCall env rest f
+_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
case astNode g of
- ASTFunction f' -> f' env arg
+ ASTFunction f' -> f' arg
other -> throwL (astPos g) $ "cannot call value " ++ show other ++ " as a function"
--- todo remove Env param, use State monad
-curryCall :: Env -> [AST] -> LFunction -> LContext AST
-curryCall env [] f = f env (makeNonsenseAST ASTUnit)
-curryCall env args f = _curryCall env args f
+curryCall :: [AST] -> LFunction -> LContext AST
+curryCall [] f = f (makeNonsenseAST ASTUnit)
+curryCall args f = _curryCall args f
traverseAndReplace :: String -> AST -> AST -> AST
traverseAndReplace param arg ast@AST { astNode = ASTSymbol sym }
@@ -68,7 +66,7 @@ letArgsToSymValPairs d args =
defineUserFunction :: Depth -> AST -> [AST] -> LContext LFunction
defineUserFunction d AST { astNode = ASTSymbol param } exprs = return fn where
fn :: LFunction
- fn env arg = do
+ fn arg = do
let replacedExprs = map (traverseAndReplace param arg) exprs
let letExprs = take (length exprs - 1) replacedExprs
letSymValPairs <- letExprs
@@ -91,7 +89,7 @@ defineUserFunctionWithLetExprs d (param:[]) exprs =
defineUserFunction d param exprs
defineUserFunctionWithLetExprs d (AST { astNode = ASTSymbol param }:rest) exprs = return fn where
fn :: LFunction
- fn _ arg = do
+ fn arg = do
let newExprs = map (traverseAndReplace param arg) exprs
ret <- defineUserFunctionWithLetExprs d rest newExprs
-- the returned AST will not have the correct position info, but that's fine
@@ -171,8 +169,7 @@ evaluateLet d asts = do
(symbol, value) <- letArgsToSymValPairs d args
env <- getEnv
when (M.member symbol env) $ throwL (astPos letAst) $ "symbol already defined: " ++ symbol
- let newEnv = M.insert symbol value env
- putEnv newEnv
+ insertEnv symbol value
return $ letAst { astNode = ASTUnit }
evaluateEnv :: Depth -> [AST] -> LContext AST
@@ -242,8 +239,7 @@ evaluateUserFunction d children = do
evaledArgs <- mapM (evaluate d) args
doubleEvaledArgs <- mapM (evaluate d) evaledArgs
- env <- getEnv
- result <- curryCall env (reverse doubleEvaledArgs) fn
+ result <- curryCall (reverse doubleEvaledArgs) fn
-- todo: maybe remove double eval here? can't remember why it was added
return $ fnAst { astNode = astNode result }
@@ -289,25 +285,6 @@ runScriptFile fileName = do
src <- liftIO $ readFile fileName
runInlineScript fileName src
-getEnv :: LContext Env
-getEnv = do
- s <- get
- return $ stateEnv s
-
-getConfig :: LContext Config
-getConfig = do
- s <- get
- return $ stateConfig s
-
-putEnv :: Env -> LContext ()
-putEnv env = do
- modify (\s -> s { stateEnv = env })
-
-insertEnv :: String -> AST -> LContext ()
-insertEnv k v = do
- env <- getEnv
- putEnv $ M.insert k v env
-
getBuiltinState :: LContext LState
getBuiltinState = do
config <- getConfig
diff --git a/src/Utils.hs b/src/Utils.hs
index 6354a87..8ee2056 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -34,6 +34,25 @@ type LContext a = StateT LState (ExceptT LException IO) a
runL :: LState -> LContext a -> IO (Either LException (a, LState))
runL s lc = runExceptT $ (flip runStateT) s lc
+getEnv :: LContext Env
+getEnv = do
+ s <- get
+ return $ stateEnv s
+
+getConfig :: LContext Config
+getConfig = do
+ s <- get
+ return $ stateConfig s
+
+putEnv :: Env -> LContext ()
+putEnv env = do
+ modify (\s -> s { stateEnv = env })
+
+insertEnv :: String -> AST -> LContext ()
+insertEnv k v = do
+ env <- getEnv
+ putEnv $ M.insert k v env
+
data Token = Token {
tokenContent :: String,
tokenRow :: Int,
@@ -47,7 +66,7 @@ instance (Eq Token) where
instance (Show Token) where
show token = show $ tokenContent token
-type LFunction = (Env -> AST -> LContext AST)
+type LFunction = AST -> LContext AST
data ASTNode
= ASTInteger Int

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