this repo has no description
feat: add simple environment imports
- use lexical scoping, this currently breaks recursion
+130
-61
+27
-9
src/Eval.hs
+27
-9
src/Eval.hs
···
34
34
metaFuncs =
35
35
M.fromList
36
36
[ ("define", defineFunc),
37
-
("undefine", unDefineFunc),
37
+
("undef", unDefFunc),
38
38
("lambda", lambdaFunc),
39
39
("if", ifFunc),
40
40
("eval", evalFunc),
41
-
("quote", quoteFunc)
41
+
("quote", quoteFunc),
42
+
("get", getFunc),
43
+
("import", importFunc)
42
44
]
43
45
44
46
defineFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)
···
55
57
Right env'' -> pureWithEnv (RUnit) env''
56
58
defineFunc _ _ = Left "define expects a symbol and expression"
57
59
58
-
unDefineFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)
59
-
unDefineFunc env [ASymbol name] =
60
+
unDefFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)
61
+
unDefFunc env [ASymbol name] =
60
62
case undefine name env of
61
63
Left err -> Left err
62
64
Right env' -> pureWithEnv (RUnit) env'
63
-
unDefineFunc _ _ = Left "undefine expects a symbol"
65
+
unDefFunc _ _ = Left "undef expects a symbol"
64
66
65
67
lambdaFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)
66
68
lambdaFunc env [AList params, body] = do
67
69
paramNames <- mapM extractParam params
68
-
let fn = createLambda paramNames [body]
70
+
let fn = createLambda env paramNames [body]
69
71
pureWithEnv fn env
70
72
lambdaFunc _ _ = Left "lambda expects a parameter and body list"
71
73
···
92
94
quoteFunc env [expr] = pureWithEnv (aToRValue expr) env
93
95
quoteFunc _ _ = Left "quote expects one argument"
94
96
97
+
getFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)
98
+
getFunc env [mExpr, AString key] = do
99
+
(mVal, _) <- eval env mExpr
100
+
case mVal of
101
+
RModule env' ->
102
+
case lookupEnv key env' of
103
+
Just val -> pureWithEnv val env
104
+
Nothing -> Left $ "module does not contain: " <> T.pack key
105
+
_ -> Left "expected module"
106
+
getFunc _ _ = Left "get expects a module and a string"
107
+
108
+
importFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)
109
+
importFunc _ _ = Left "cannot call raw import"
110
+
95
111
-- EVALUATION --
96
112
97
113
apply :: NlsRunValue -> [NlsRunValue] -> Env -> Eval (NlsRunValue, Env)
···
104
120
apply _ _ _ = Left "attempted to call non-function"
105
121
106
122
-- create a RFunction from a lambda expression
107
-
createLambda :: [String] -> [NlsAstValue] -> NlsRunValue
108
-
createLambda params body = RFunction wrapper
123
+
createLambda :: Env -> [String] -> [NlsAstValue] -> NlsRunValue
124
+
createLambda env params body = RFunction wrapper
109
125
where
110
126
wrapper :: [NlsRunValue] -> Env -> Eval (NlsRunValue, Env)
111
-
wrapper args env = do
127
+
wrapper args _ = do
112
128
if length args /= length params
113
129
then
114
130
Left
···
122
138
let env' = mergeFrame newFrame env
123
139
evalProgram env' body
124
140
141
+
-- evaluate a single ast value
125
142
eval :: Env -> NlsAstValue -> Eval (NlsRunValue, Env)
126
143
eval env (ANumber n) = pureWithEnv (RNumber n) env
127
144
eval env (AString s) = pureWithEnv (RString s) env
···
146
163
(vals, env'') <- mapAccumM eval env' args
147
164
apply func vals env''
148
165
166
+
-- evaluate a sequence of ast values
149
167
evalProgram :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)
150
168
evalProgram env [] = pure (RUnit, env)
151
169
evalProgram env [x] = eval env x
+71
-9
src/Main.hs
+71
-9
src/Main.hs
···
1
+
{-# LANGUAGE OverloadedStrings #-}
2
+
1
3
module Main (main) where
2
4
3
5
import qualified Data.Text as T
4
6
import qualified Data.Text.IO as TIO
5
7
import qualified Eval as E
6
8
import qualified Parser as P
7
-
import qualified Repl as R
8
9
import System.Environment (getArgs)
10
+
import System.IO
11
+
( hFlush,
12
+
isEOF,
13
+
stdout,
14
+
)
9
15
import Types
16
+
import qualified Util as U
17
+
18
+
-- load, parse, and evaluate a file
19
+
evalFile :: Env -> FilePath -> IO (Eval (NlsRunValue, Env))
20
+
evalFile env path = do
21
+
t <- TIO.readFile path
22
+
case P.parse t of
23
+
Left err -> pure $ Left err
24
+
Right ast -> evalTop env ast
25
+
26
+
-- evaluate top level ast, handling import
27
+
evalTop :: Env -> [NlsAstValue] -> IO (Eval (NlsRunValue, Env))
28
+
evalTop env [] = pure $ Right (RUnit, env)
29
+
evalTop env [x] =
30
+
case x of
31
+
AList (ASymbol "import" : [AString path, ASymbol name]) -> do
32
+
res <- evalFile E.baseEnv path
33
+
case res of
34
+
Left err -> pure $ Left err
35
+
Right (_, env') ->
36
+
case U.define name (RModule env') env of
37
+
Left err -> pure $ Left err
38
+
Right env'' -> pure $ Right (RUnit, env'')
39
+
AList (ASymbol "import" : _) -> pure $ Left "import expects a file path and symbol"
40
+
_ -> pure $ E.eval env x
41
+
evalTop env (x : xs) = do
42
+
res <- evalTop env [x]
43
+
case res of
44
+
Left err -> pure $ Left err
45
+
Right (_, env') -> evalTop env' xs
46
+
47
+
-- evaluate and print AST
48
+
evalMany :: Env -> [NlsAstValue] -> IO Env
49
+
evalMany env [] = pure env
50
+
evalMany env (x : xs) = do
51
+
res <- evalTop env [x]
52
+
case res of
53
+
Left err -> do
54
+
putStrLn $ "Error: " ++ T.unpack err
55
+
pure env
56
+
Right (val, env') -> do
57
+
print val
58
+
evalMany env' xs
59
+
60
+
repl :: Env -> IO ()
61
+
repl env = do
62
+
putStr "nls> "
63
+
hFlush stdout
64
+
eof <- isEOF
65
+
if eof
66
+
then putStrLn "\nGoodbye!"
67
+
else do
68
+
line <- getLine
69
+
let input = T.pack line
70
+
newEnv <- case P.parse input of
71
+
Left err -> do
72
+
putStrLn $ "Parse error: " ++ (T.unpack err)
73
+
pure env
74
+
Right ast -> evalMany env ast
75
+
repl newEnv
10
76
11
77
main :: IO ()
12
78
main = do
13
79
args <- getArgs
14
80
case args of
15
81
[filePath] -> do
16
-
t <- TIO.readFile filePath
17
-
case P.parse t of
82
+
res <- evalFile E.baseEnv filePath
83
+
case res of
18
84
Left err -> putStrLn (T.unpack err)
19
-
Right ast -> do
20
-
case E.evalProgram E.baseEnv ast of
21
-
Left err -> putStrLn (T.unpack err)
22
-
Right (RUnit, env) -> R.repl env
23
-
Right (result, _) -> print result
24
-
_ -> R.repl E.baseEnv
85
+
Right (val, _) -> print val
86
+
_ -> repl E.baseEnv
+23
-2
src/Parser.hs
+23
-2
src/Parser.hs
···
32
32
symbol :: T.Text -> NlsParser T.Text
33
33
symbol = L.symbol sc
34
34
35
+
-- split a string with character delimiter
36
+
splitOn :: Char -> String -> [String]
37
+
splitOn c str =
38
+
case break (== c) str of
39
+
(before, []) -> [before]
40
+
(before, _ : after) -> before : splitOn c after
41
+
42
+
-- make `get` ast
43
+
makeGet :: NlsAstValue -> String -> NlsAstValue
44
+
makeGet acc key = AList [ASymbol "get", acc, AString key]
45
+
46
+
-- desugar dotted expr into `get` sequence
47
+
desugarDotted :: String -> NlsAstValue
48
+
desugarDotted s =
49
+
case splitOn '.' s of
50
+
[] -> AString s -- this should never happen
51
+
(x : xs) -> foldl makeGet (ASymbol x) xs
52
+
35
53
parseSymbol :: NlsParser NlsAstValue
36
54
parseSymbol = do
37
55
first <- letterChar <|> oneOf ("!$%&|*+-/:<=>?@^_~" :: String)
38
-
rest <- many (alphaNumChar <|> oneOf ("!$%&|*+-/:<=>?@^_~" :: String))
39
-
pure $ ASymbol (first : rest)
56
+
rest <- many (alphaNumChar <|> oneOf ("!$%&|*+-/:<=>?@^_~." :: String))
57
+
let sym = first : rest
58
+
if elem '.' sym
59
+
then pure $ desugarDotted sym
60
+
else pure $ ASymbol sym
40
61
41
62
parseQuote :: NlsParser NlsAstValue
42
63
parseQuote = do
-40
src/Repl.hs
-40
src/Repl.hs
···
1
-
module Repl (repl) where
2
-
3
-
import qualified Data.Text as T
4
-
import qualified Eval as E
5
-
import qualified Parser as P
6
-
import System.IO
7
-
( hFlush,
8
-
isEOF,
9
-
stdout,
10
-
)
11
-
import Types
12
-
13
-
-- evaluate and print AST
14
-
evalMany :: Env -> [NlsAstValue] -> IO Env
15
-
evalMany env [] = pure env
16
-
evalMany env (x : xs) =
17
-
case E.eval env x of
18
-
Left err -> do
19
-
putStrLn $ "Error: " ++ T.unpack err
20
-
pure env
21
-
Right (val, env') -> do
22
-
print val
23
-
evalMany env' xs
24
-
25
-
repl :: Env -> IO ()
26
-
repl env = do
27
-
putStr "nls> "
28
-
hFlush stdout
29
-
eof <- isEOF
30
-
if eof
31
-
then putStrLn "\nGoodbye!"
32
-
else do
33
-
line <- getLine
34
-
let input = T.pack line
35
-
newEnv <- case P.parse input of
36
-
Left err -> do
37
-
putStrLn $ "Parse error: " ++ (T.unpack err)
38
-
pure env
39
-
Right ast -> evalMany env ast
40
-
repl newEnv
+2
src/Types.hs
+2
src/Types.hs
···
33
33
| RSymbol String
34
34
| RList [NlsRunValue]
35
35
| RFunction ([NlsRunValue] -> Env -> Eval (NlsRunValue, Env))
36
+
| RModule Env
36
37
| RUnit -- an empty value
37
38
38
39
instance Show NlsRunValue where
···
42
43
show (RSymbol s) = s
43
44
show (RList xs) = "(" ++ unwords (map show xs) ++ ")"
44
45
show (RFunction _) = "<function>"
46
+
show (RModule _) = "<module>"
45
47
show RUnit = "<empty>"
+6
src/Util.hs
+6
src/Util.hs
···
5
5
rToAValue,
6
6
lookupEnv,
7
7
define,
8
+
defineUnchecked,
8
9
undefine,
9
10
mergeFrame,
10
11
mapAccumM,
···
35
36
rToAValue (RBool False) = pure $ ASymbol "false"
36
37
rToAValue (RList xs) = AList <$> mapM rToAValue xs
37
38
rToAValue (RFunction _) = Left "cannot eval a function"
39
+
rToAValue (RModule _) = Left "cannot eval a module"
38
40
rToAValue RUnit = Left "cannot eval an empty unit"
39
41
40
42
-- lookup a key recursively in an environment
···
50
52
case M.lookup key (frame env) of
51
53
Just _ -> Left ("cannot shadow binding " <> T.pack key <> " in current frame")
52
54
Nothing -> Right env {frame = M.insert key val (frame env)}
55
+
56
+
-- define without checking shadow rules
57
+
defineUnchecked :: String -> NlsRunValue -> Env -> Env
58
+
defineUnchecked key val env = env {frame = M.insert key val (frame env)}
53
59
54
60
-- remove a binding from the current frame
55
61
undefine :: String -> Env -> Either T.Text Env