├── .gitignore
├── README.md
├── main.hs
├── run.sh
└── spec.hs


/.gitignore:
--------------------------------------------------------------------------------
1 | .*.swp
2 | *.hi
3 | *.o
4 | main
5 | .liquid
6 | 
7 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # Background
 2 | This project aims to write a Scheme using Haskell. It follows the [Write Yourself a Scheme in 48 Hours](https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours) Tutorial.
 3 | 
 4 | ### Related Twitch Streams 
 5 | |Part 1   |Part 1.5 | Part 2  |
 6 | |---------|---------|---------|
 7 | |[<img src="https://static-cdn.jtvnw.net/cf_vods/d2nvs31859zcd8/adccee82df67487d86be_georgehotz_2368789169_148112716//thumb/thumb0-320x180.jpg">](https://www.twitch.tv/videos/698538222) | [<img src="https://static-cdn.jtvnw.net/cf_vods/d2nvs31859zcd8/0308129917f003ef9898_georgehotz_2400084145_150068709//thumb/thumb0-320x180.jpg">](https://www.twitch.tv/videos/703470743)  | [<img src="https://static-cdn.jtvnw.net/cf_vods/d2nvs31859zcd8/8241bf1c7e1cc82ef94c_georgehotz_2404664993_150355018//thumb/thumb0-320x180.jpg">](https://www.twitch.tv/videos/704147445) |
 8 | 
 9 | ## What is a Scheme?
10 | A Scheme is a statically scoped and properly tail-recursive dialect of the Lisp programming language.  
11 | You can read more about it [here](https://groups.csail.mit.edu/mac/projects/scheme/) or on [Wikipedia](https://en.wikipedia.org/wiki/Scheme_(programming_language)).
12 | 
13 | # Getting Started
14 | To run the project you should install `ghc` or `ghci`, the interactive haskell environment. 
15 | You can download it from the haskell website: [https://www.haskell.org/downloads/](https://www.haskell.org/downloads/).
16 | 
17 | After installation you can either run the file `run.sh` or edit and recompile the `main.hs` file through `ghci`.
18 | 
19 | To run examples you can follow the book [Structure and Interpretation of Computer Programs](https://mitpress.mit.edu/sites/default/files/sicp/full-text/book/book.html).  
20 | This project should currently be up to 1.1.7 in Chapter 1.
21 | 
22 | Tests are defined in the `spec.hs` file. Feel free to add more!
23 | 
24 | # Next Steps
25 | |Name               |Status   |
26 | |-------------------|---------|
27 | |Add float support  | 👷 TODO |
28 | |Add "cond" support | 👷 TODO |
29 | 
30 | 
31 | 
32 | 


--------------------------------------------------------------------------------
/main.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances #-} 
  2 | 
  3 | module Main where
  4 | import Text.ParserCombinators.Parsec hiding (spaces)
  5 | import System.Environment
  6 | import Control.Monad
  7 | import Numeric
  8 | import System.IO
  9 | import Control.Monad.IO.Class
 10 | import Data.IORef
 11 | 
 12 | -- ****** Environment ******
 13 | 
 14 | type Env = IORef [(String, IORef LispVal)]
 15 | 
 16 | instance Show (IORef a) where
 17 |     show _ = "<ioref>"
 18 | 
 19 | nullEnv :: IO Env
 20 | nullEnv = newIORef []
 21 | 
 22 | isBound :: Env -> String -> IO Bool
 23 | isBound envRef var = readIORef envRef >>= return . maybe False
 24 |   (const True) . lookup var
 25 | 
 26 | getVar :: Env -> String -> IO LispVal
 27 | getVar envRef var = do
 28 |   env <- readIORef envRef
 29 |   -- maybe :: b -> (a -> b) -> Maybe a -> b
 30 |   maybe undefined
 31 |         readIORef
 32 |         (lookup var env)
 33 | 
 34 | {-
 35 | setVar :: Env -> String -> LispVal
 36 | setVar envRef var value = do
 37 |   env <- liftIO $ readIORef envRef
 38 |   (liftIO . (flip writeIORef value)) (lookup var env)
 39 |   return value
 40 | 
 41 | defineVar :: Env -> String -> LispVal
 42 | defineVar envRef var value = do
 43 |   alreadyDefined <- liftIO $ isBound envRef var
 44 |   if alreadyDefined
 45 |     then setVar envRef var value >> return value
 46 |     else liftIO $ do
 47 |       valueRef <- newIORef value
 48 |       env <- readIORef envRef
 49 |       writeIORef envRef ((var, valueRef) : env)
 50 |       return value
 51 | -}
 52 | 
 53 | defineVar :: Env -> String -> LispVal -> IO LispVal
 54 | defineVar envRef var value = do
 55 |   valueRef <- newIORef value
 56 |   env <- readIORef envRef
 57 |   writeIORef envRef ((var, valueRef) : env)
 58 |   return value
 59 | 
 60 | 
 61 | -- ****** Data Types ******
 62 | 
 63 | 
 64 | data LispVal = Atom String
 65 |              | List [LispVal]
 66 |              | DottedList [LispVal] LispVal
 67 |              | Number Integer
 68 |              | Float Float
 69 |              | String String
 70 |              | Bool Bool
 71 |              | PrimitiveFunc ([LispVal] -> LispVal)
 72 |              | Func { params :: [String], vararg :: (Maybe String),
 73 |                       body :: [LispVal], closure :: Env }
 74 |              deriving Show
 75 | 
 76 | instance Show ([LispVal] -> LispVal) where
 77 |     show _ = "<primitive>"
 78 | 
 79 | -- ****** Parser ******
 80 | 
 81 | parseString :: Parser LispVal
 82 | parseString = do
 83 |                 char '"'
 84 |                 x <- many (noneOf "\"")
 85 |                 char '"'
 86 |                 return $ String x
 87 | 
 88 | 
 89 | parseAtom :: Parser LispVal
 90 | parseAtom = do
 91 |               first <- letter <|> symbol
 92 |               rest <- many (letter <|> digit <|> symbol)
 93 |               let atom = first:rest
 94 |               return $ case atom of
 95 |                 "#t" -> Bool True
 96 |                 "#f" -> Bool False
 97 |                 _    -> Atom atom
 98 | 
 99 | 
100 | parseNumber :: Parser LispVal
101 | parseNumber = do
102 |   x <- many1 digit
103 |   return $ Number $ read x
104 | -- parseNumber = liftM (Number . read) $ many1 digit
105 | 
106 | parseFloat :: Parser LispVal
107 | parseFloat = do
108 |   x <- many1 digit 
109 |   char '.'
110 |   y <- many1 digit
111 |   let atom = (x ++ "." ++ y)
112 |   return $ Float $ read atom
113 | 
114 | parseExpr :: Parser LispVal
115 | parseExpr = parseAtom
116 |         <|> parseString
117 |         <|> try parseFloat
118 |         <|> parseNumber
119 |         <|> parseQuoted
120 |         <|> do char '('
121 |                x <- try parseList <|> parseDottedList
122 |                char ')'
123 |                return x
124 | 
125 | parseList :: Parser LispVal
126 | parseList = liftM List $ sepBy parseExpr spaces
127 | 
128 | parseDottedList :: Parser LispVal
129 | parseDottedList = do
130 |   head <- endBy parseExpr spaces
131 |   tail <- char '.' >> spaces >> parseExpr
132 |   return $ DottedList head tail
133 | 
134 | parseQuoted :: Parser LispVal
135 | parseQuoted = do
136 |   char '\''
137 |   x <- parseExpr
138 |   return $ List [Atom "quote", x]
139 | 
140 | spaces :: Parser ()
141 | spaces = skipMany1 space
142 | 
143 | symbol :: Parser Char
144 | symbol = oneOf "!#$%&|*+-/:<=>?@^_~"
145 | 
146 | readExpr :: String -> LispVal
147 | readExpr input = case parse parseExpr "lisp" input of
148 |   Left err -> String $ "No match: " ++ show err
149 |   Right val -> val
150 | 
151 | -- ****** Eval ******
152 | 
153 | unpackNum :: LispVal -> Integer
154 | unpackNum (Number n) = n
155 | unpackNum (Bool True) = 1
156 | unpackNum (Bool False) = 0
157 | -- no weak typing
158 | 
159 | unpackStr :: LispVal -> String
160 | unpackStr (String s) = s
161 | 
162 | unpackAtom :: LispVal -> String
163 | unpackAtom (Atom s) = s
164 | 
165 | unpackBool :: LispVal -> Bool
166 | unpackBool (Bool b) = b
167 | 
168 | numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> LispVal
169 | numericBinop op params = Number $ foldl1 op $ map unpackNum params
170 | 
171 | compareBinop [Atom x, Atom y] = (Bool (x==y))
172 | compareBinop _ = (Bool False)
173 | 
174 | boolBinop :: (LispVal -> a) -> (a -> a -> Bool) -> [LispVal] -> LispVal
175 | boolBinop unpacker op [x, y] = Bool $ (unpacker x) `op` (unpacker y)
176 | 
177 | numBoolBinop = boolBinop unpackNum
178 | strBoolBinop = boolBinop unpackStr
179 | boolBoolBinop = boolBinop unpackBool
180 | 
181 | primitives :: [(String, [LispVal] -> LispVal)]
182 | primitives = [("+", numericBinop (+)),
183 |               ("-", numericBinop (-)),
184 |               ("*", numericBinop (*)),
185 |               ("/", numericBinop div),
186 |               ("mod", numericBinop mod),
187 |               ("quotient", numericBinop quot),
188 |               ("remainder", numericBinop rem),
189 |               ("=", numBoolBinop (==)),
190 |               ("<", numBoolBinop (<)),
191 |               (">", numBoolBinop (>)),
192 |               ("/=", numBoolBinop (/=)),
193 |               (">=", numBoolBinop (>=)),
194 |               ("<=", numBoolBinop (<=)),
195 |               ("&&", boolBoolBinop (&&)),
196 |               ("||", boolBoolBinop (||)),
197 |               ("string=?", strBoolBinop (==)),
198 |               ("string<?", strBoolBinop (<)),
199 |               ("string>?", strBoolBinop (>)),
200 |               ("string<=?", strBoolBinop (<=)),
201 |               ("string>=?", strBoolBinop (>=)),
202 |               ("eq?", compareBinop)]
203 | 
204 | 
205 | primitiveBindings :: IO Env
206 | primitiveBindings = do
207 |   env <- nullEnv
208 |   mapM (makePrimitiveFunc env) primitives
209 |   return env
210 |   where makePrimitiveFunc env (var, func) = defineVar env var (PrimitiveFunc func)
211 | 
212 | apply :: LispVal -> [LispVal] -> IO LispVal
213 | apply (PrimitiveFunc func) args = return $ func args
214 | apply (Func params vararg body closure) args = do 
215 |   mapM (bindVar closure) (zip params args)
216 |   -- TODO: why is body a list? I don't think this is always right
217 |   eval closure (body !! 0)
218 |   where bindVar env (p, arg) = defineVar env p arg
219 |   
220 | 
221 | -- return $ (Bool False)
222 | 
223 | {-
224 | apply (Atom func) args = return $ maybe
225 |   (Bool False)
226 |   ($ args)
227 |   (lookup func primitives)
228 | -}
229 | 
230 | makeFunc varargs env params body = return $ Func (map unpackAtom params) varargs body env
231 | makeNormalFunc = makeFunc Nothing
232 | 
233 | eval :: Env -> LispVal -> IO LispVal
234 | eval _ val@(Float _) = return val
235 | eval _ val@(String _) = return val
236 | eval _ val@(Number _) = return val
237 | eval _ val@(Bool _) = return val
238 | eval _ (List [Atom "quote", val]) = return val
239 | eval env (Atom id) = getVar env id
240 | eval env (List [Atom "define", Atom var, form]) = 
241 |   eval env form >>= defineVar env var
242 | eval env (List (Atom "define" : List (Atom var : params) : body)) =
243 |   makeNormalFunc env params body >>= defineVar env var
244 | eval env (List [Atom "if", pred, conseq, alt]) = do
245 |   result <- eval env pred
246 |   case result of
247 |     Bool False -> eval env alt
248 |     otherwise -> eval env conseq
249 | eval env (List (Atom "cond" : pairs)) = evalCond pairs
250 |     where evalCond (List [Atom "else", value] : []) = eval env value
251 |           evalCond (List [condition, value] : rest) = do
252 |             conditionResult <- eval env condition
253 |             case conditionResult of
254 |                 Bool False -> evalCond rest
255 |                 _ -> eval env value
256 |           evalCond [] = pure $ Atom ""
257 | eval env (List (Atom func : args)) = do
258 |  x <- mapM (eval env) args
259 |  f <- (getVar env func)
260 |  apply f x
261 | 
262 | --eval env (List (Atom func : args)) = do
263 | -- x <- mapM (eval env) args
264 | -- apply (Atom func) x
265 | --eval env (List (Atom func : args)) = return $ apply func $ mapM (eval env) args
266 | 
267 | -- ****** REPL ******
268 | 
269 | readPrompt :: String -> IO String
270 | readPrompt prompt = putStr prompt >> hFlush stdout >> getLine
271 | 
272 | evalString :: Env -> String -> IO String
273 | evalString env expr = liftM show $ eval env $ readExpr expr
274 | 
275 | evalAndPrint :: Env -> String -> IO ()
276 | evalAndPrint env expr = evalString env expr >>= putStrLn
277 | 
278 | until_ pred prompt action = do
279 |   result <- prompt
280 |   if pred result
281 |     then return ()
282 |     else action result >> until_ pred prompt action
283 | 
284 | main :: IO ()
285 | main = do
286 |   env <- primitiveBindings
287 |   until_ (== "quit") (readPrompt "Lisp>>> ") (evalAndPrint env)
288 | 
289 | 


--------------------------------------------------------------------------------
/run.sh:
--------------------------------------------------------------------------------
1 | #!/bin/bash -e
2 | ghc main.hs 
3 | rlwrap ./main
4 | 


--------------------------------------------------------------------------------
/spec.hs:
--------------------------------------------------------------------------------
 1 | module Spec where
 2 | 
 3 | import Main hiding (main)
 4 | import Test.Hspec
 5 | import Data.Foldable
 6 | 
 7 | test exprs expected = it (last exprs) $ do
 8 |     env <- primitiveBindings
 9 |     for_ (init exprs) $ evalString env
10 |     result <- evalString env (last exprs)
11 |     shouldBe result expected
12 | 
13 | main :: IO ()
14 | main = hspec $ do
15 |   describe "tests" $ do
16 |     test ["(+ 137 349)"] "Number 486"
17 |     test ["(+ (* 3 (+ (* 2 4) (+ 3 5))) (+ (- 10 7) 6))"] "Number 57"
18 |     test ["(define size 2)", "size"] "Number 2"
19 |     test ["(define (square x) (* x x))", "(square 4)"] "Number 16"
20 |     test ["(define (square x) (* x x))", "(square (square 3))"] "Number 81"
21 |     test ["(define (square x) (* x x))",
22 |           "(define (sum-of-squares x y) (+ (square x) (square y)))",
23 |           "(sum-of-squares 3 4)"] "Number 25"
24 |     test ["(if #t 7 3)"] "Number 7"
25 |     test ["(if #f 7 3)"] "Number 3"
26 |     test ["(define (abs x) (if (< x 0) (- x) x))",
27 |           "(+ (abs 5) (abs (- 5)))"] "Number 10"
28 |     test ["(define (abs x) (cond ((> x 0) x) ((= x 0) 0) ((< x 0) (- x))))",
29 |           "(abs (- 1))"] "Number 1"
30 |     test ["(define (abs x) (cond ((< x 0) (- x)) (else x)))",
31 |           "(abs (- 10))"] "Number 10"
32 |     test ["(cond (1 1) (else 2))"] "Number 1" -- currently produces "Number 2"
33 |     -- analogous test for `if`
34 |     test ["(if 1 1 2)"] "Number 1"
35 | 
36 |     -- parsing has some problems with spaces
37 |     test ["( * 2 2 )"] "Number 4" -- currently a parse error
38 | 
39 |     -- the stuff below might technically be more like 1.1.8 stuff,
40 |     -- so not strictly within chapter 1.1.7
41 | 
42 |     -- this is why "body" is a list
43 |     test ["(define (forthpower n) (define m (* n n)) (* m m))",
44 |           "(forthpower 3)"] "Number 81" -- currently produces "Number 9"
45 | 
46 |     -- parameter definitions should not leak
47 |     test ["(define (square x) (* x x))",
48 |           "(define x 42)",
49 |           "(square 5)",
50 |           "x"] "Number 42" -- currently produces "Number 5"
51 |     test ["(define (square x) (* x x))",
52 |           "(define (fithpower x) (* (square (square x)) x))",
53 |           "(fithpower 4)"] "Number 1024" -- currently produces "Number 4096"
54 | 
55 |     -- and in general, local definitions should only be visible inside of the function
56 |     test ["(define m 42)",
57 |           "(define (forthpower n) (define m (* n n)) (* m m))",
58 |           "(forthpower 3)",
59 |           "m"] "Number 42" -- currently produces "Number 9"
60 | 


--------------------------------------------------------------------------------