├── .gitignore ├── Setup.hs ├── license ├── lisp.cabal ├── lisp └── core.lisp ├── readme.md ├── src ├── Env.hs ├── Eval.hs ├── Main.hs ├── Parse.hs ├── Primitives.hs └── Types.hs ├── stack.yaml └── usage.txt /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | .idea/ 3 | .ideaHaskellLib/ 4 | lisp.iml -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /license: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Rein van der Woerd 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /lisp.cabal: -------------------------------------------------------------------------------- 1 | name: lisp 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/reinvdwoerd/lisp 6 | license: MIT 7 | author: Rein van der Woerd 8 | maintainer: reinvanderwoerd@me.com 9 | copyright: 2017 Rein van der Woerd 10 | category: Language 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | extra-source-files: readme.md 14 | 15 | executable lisp 16 | hs-source-dirs: src 17 | main-is: Main.hs 18 | other-modules: Eval, Env, Primitives, Parse, Types 19 | default-language: Haskell2010 20 | default-extensions: GeneralizedNewtypeDeriving 21 | build-depends: base >= 4.7 && < 5, 22 | transformers, 23 | parsec, 24 | mtl, 25 | haskeline-repl, 26 | monadplus, 27 | uri, 28 | lens, 29 | wreq, 30 | tostring, 31 | safe, 32 | either, 33 | uri, 34 | haskeline-repl, 35 | flow -------------------------------------------------------------------------------- /lisp/core.lisp: -------------------------------------------------------------------------------- 1 | (define a 10) 2 | 3 | (define nums '(1 2 3 4)) 4 | 5 | 6 | 7 | 8 | 9 | (define (inc x) 10 | (+ 1 x)) 11 | 12 | (define (id x) 13 | x) 14 | 15 | 16 | (define (compose f g) 17 | (lambda (x) (f (g x)))) 18 | 19 | (define (flip func) 20 | (lambda (x y) (func y x))) 21 | 22 | (define (second list) 23 | (first (rest list))) 24 | 25 | (define (last list) 26 | (first (reverse list))) 27 | 28 | (define (pair a b) 29 | '(~a ~b)) 30 | 31 | (define (first-two list) 32 | (pair (first list) (second list))) 33 | 34 | (define (empty? list) 35 | (= list '())) 36 | 37 | (define (pairs list) 38 | (define (iter acc remainder) 39 | (if (empty? remainder) 40 | (reverse acc) 41 | (iter (cons (first-two remainder) acc) 42 | (rest (rest remainder))))) 43 | (iter () list)) 44 | 45 | (define (pairs* . items) 46 | (pairs items)) 47 | 48 | (define (reduce f init seq) 49 | (if (empty? seq) 50 | init 51 | (reduce f (f init (first seq)) 52 | (rest seq)))) 53 | 54 | 55 | 56 | (define (mapping func) 57 | (lambda (acc x) 58 | (cons (func x) acc))) 59 | 60 | (define (map func list) 61 | (reverse (reduce (mapping func) '() list))) 62 | 63 | (define (list* . items) 64 | (reduce (flip cons) 65 | (first (reverse items)) 66 | (rest (reverse items)))) 67 | 68 | (define-syntax (unless test then) 69 | '(if (= ~test false) 70 | ~then 71 | nil)) 72 | 73 | (define-syntax (when test then) 74 | '(if ~test 75 | ~then 76 | nil)) 77 | 78 | 79 | (define (binding-vars bindings) 80 | (map first (pairs bindings))) 81 | 82 | (define (binding-vals bindings) 83 | (map second (pairs bindings))) 84 | 85 | 86 | (define-syntax (let bindings . body) 87 | (list* (list* 'lambda (binding-vars bindings) body) 88 | (binding-vals bindings))) 89 | 90 | (define (do . forms) 91 | (last forms)) 92 | 93 | (define (wrap-if acc clause) 94 | '(if ~(first clause) 95 | ~(second clause) 96 | ~acc)) 97 | 98 | (define-syntax (cond . clauses) 99 | (reduce wrap-if 'nil (reverse (pairs clauses)))) 100 | 101 | (define-syntax (trace form) 102 | '(let (result ~form) 103 | (print "'~form => ~'result") 104 | result)) 105 | 106 | (define (require path) 107 | (map eval (read-many (slurp path)))) 108 | 109 | 110 | (define (return-test) 111 | (call/cc 112 | (lambda (return) 113 | 1 (return 2) 3))) 114 | 115 | 116 | (define (dbg-test x) 117 | (debug)) 118 | 119 | (define-syntax (let/cc sym . body) 120 | (list 'call/cc (list* 'lambda '(~sym) body))) 121 | 122 | (define-syntax (define-readermacro start end sym) 123 | '(set! readtable (cons '((~~start ~~end) ~sym) readtable))) 124 | 125 | (define-readermacro "[" "]" list) 126 | (define-readermacro "{" "}" pairs) -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # Lisp 2 | 3 | My WIP Lisp implementation, used to try out ideas and better understand the design decisions involved in creating languages. 4 | The primary design goal is a simple, minimal and readable core. 5 | Implementation is explained on my [blog](http://reinvanderwoerd.nl/blog/2017/03/18/writing-a-lisp/). 6 | 7 | ### Currently supported features: 8 | * Haskeline-based REPL 9 | * Error messages 10 | * Enviroment inspection: `(env)` 11 | * Require-ing other files 12 | * Macro's 13 | * Lamda shorthand: `#{* 2 %}` 14 | * Variable arguments 15 | 16 | 17 | ### Planned features: 18 | * Comments 19 | * Even smaller core 20 | 21 | 22 | ### Try it 23 | 24 | $ git clone https://github.com/reinvdwoerd/lisp 25 | $ cd ./lisp 26 | $ stack install 27 | $ stack exec lisp 28 | 29 | lisp=> (require lisp/core) 30 | -------------------------------------------------------------------------------- /src/Env.hs: -------------------------------------------------------------------------------- 1 | module Env where 2 | 3 | import Control.Lens ((<&>)) 4 | import Control.Monad.State.Strict 5 | import Data.Either.Combinators 6 | import Data.IORef 7 | import Data.Maybe 8 | import Parse 9 | import Types 10 | 11 | -- run :: LispM a -> IO a 12 | 13 | 14 | newEnv :: [(String, LispVal)] -> IO Env 15 | newEnv vars = do 16 | e <- newIORef [] 17 | fromRight' <$> run (bindVars e vars) 18 | 19 | 20 | trace val = do 21 | liftIO $ putStrLn $ showVal val 22 | return val 23 | 24 | getReadtable :: Env -> LispM [(ReadtableKey, String)] 25 | getReadtable env = do 26 | List pairs <- getVar env "readtable" 27 | return $ map extractPair pairs 28 | where extractPair (List [String s, Symbol sym]) = 29 | (Prefix s, sym) 30 | extractPair (List [List [String start, String end], Symbol sym]) = 31 | (Between start end, sym) 32 | 33 | isBound :: Env -> String -> LispM Bool 34 | isBound envRef var = 35 | liftIO $ readIORef envRef <&> lookup var <&> isJust 36 | 37 | withVar :: Env -> String -> (IORef LispVal -> IO a) -> LispM a 38 | withVar envRef var f = do 39 | env <- liftIO $ readIORef envRef 40 | case lookup var env of 41 | Just val -> liftIO $ f val 42 | _ -> throwWithStack $ UnboundVar var 43 | 44 | getVar :: Env -> String -> LispM LispVal 45 | getVar envRef var = 46 | withVar envRef var readIORef 47 | 48 | getVars :: Env -> LispM [(String, LispVal)] 49 | getVars envRef = do 50 | env <- liftIO $ readIORef envRef 51 | let vars = map fst env 52 | vals <- traverse (getVar envRef) vars 53 | return $ zip vars vals 54 | 55 | 56 | setVar :: Env -> String -> LispVal -> LispM LispVal 57 | setVar envRef var value = do 58 | withVar envRef var (`writeIORef` value) 59 | return Nil 60 | 61 | 62 | 63 | defineVar :: Env -> String -> LispVal -> LispM LispVal 64 | defineVar envRef var value = do 65 | alreadyDefined <- isBound envRef var 66 | if alreadyDefined 67 | then do 68 | setVar envRef var value 69 | return $ Symbol var 70 | else do 71 | valueRef <- liftIO $ newIORef value 72 | env <- liftIO $ readIORef envRef 73 | liftIO $ writeIORef envRef ((var, valueRef) : env) 74 | return $ Symbol var 75 | 76 | bindVars :: Env -> [(String, LispVal)] -> LispM Env 77 | bindVars envRef bindings = liftIO $ readIORef envRef >>= extendEnv >>= newIORef 78 | where extendEnv env = traverse addBinding bindings <&> (++ env) 79 | addBinding (var, value) = do ref <- newIORef value 80 | return (var, ref) 81 | 82 | -------------------------------------------------------------------------------- /src/Eval.hs: -------------------------------------------------------------------------------- 1 | module Eval where 2 | 3 | import Control.Exception 4 | import Control.Monad.State.Strict 5 | import Data.Either.Combinators 6 | import Env 7 | import Parse 8 | import Safe 9 | import System.Console.Repl 10 | import Types 11 | 12 | push :: LispVal -> LispM () 13 | push val = do 14 | modify addFrame 15 | printStack "->" 16 | where addFrame xs = 17 | Callframe val : xs 18 | 19 | pop :: LispM () 20 | pop = do 21 | modify tailSafe 22 | printStack "<-" 23 | 24 | 25 | printStack :: String -> LispM () 26 | printStack msg = do 27 | stack <- get 28 | liftIO $ putStrLn $ msg ++ " " ++ unwords (map show (headSafe stack)) 29 | where headSafe [] = [] 30 | headSafe (x:xs) = [x] 31 | 32 | 33 | {- Eval -} 34 | eval :: Env -> LispVal -> LispM LispVal 35 | eval env val = 36 | case val of 37 | Symbol s -> 38 | getVar env s 39 | 40 | List [Symbol "quote", form] -> 41 | walk evalUnquotes form 42 | where evalUnquotes (List [Symbol "unquote", val]) = eval env val 43 | evalUnquotes val = return val 44 | 45 | List (fsym : args) -> do 46 | (Fn f) <- eval env fsym 47 | push val 48 | r <- if isMacro f then 49 | apply env (fnType f) args >>= eval env 50 | else 51 | evalMany env args >>= apply env (fnType f) 52 | pop 53 | return r 54 | 55 | _ -> 56 | return val 57 | 58 | 59 | evalMany env = traverse (eval env) 60 | evalBody env body = last <$> evalMany env body 61 | 62 | 63 | evalString, evalFile :: Env -> String -> IO () 64 | evalString = 65 | runWithCatch action 66 | where action env string = do 67 | readtable <- getReadtable env 68 | let r = readOne readtable string >>= eval env 69 | liftIO $ run r >>= either printVal printVal 70 | 71 | 72 | -- evalWithInfo = 73 | -- runWithCatch action 74 | -- where action env string = do 75 | -- readtable <- getReadtable env 76 | -- result <- readOne readtable string >>= eval env 77 | -- liftIO $ putStrLn $ showVal result ++ " : " ++ show result 78 | 79 | 80 | evalFile = 81 | runWithCatch action 82 | where action env file = do 83 | readtable <- getReadtable env 84 | liftIO (readFile file) >>= readMany readtable >>= evalMany env 85 | return () 86 | 87 | 88 | runWithCatch :: (Env -> String -> LispM ()) -> Env -> String -> IO () 89 | runWithCatch f env x = do 90 | let action = fromRight' <$> run (f env x) 91 | catch action (printError :: LispError -> IO ()) 92 | 93 | 94 | 95 | {- Apply -} 96 | apply :: Env -> FnType -> [LispVal] -> LispM LispVal 97 | apply env Primitive { purity = p } args = 98 | case p of 99 | Pure func -> 100 | return $ func args 101 | Impure func -> 102 | func env args 103 | 104 | apply env (Lisp params varargs body closure) args = 105 | if length params /= length args && not varargs then 106 | throwWithStack $ NumArgs (length params) (length args) 107 | else do 108 | envWithArgs <- bindVars closure $ zipParamsArgs params varargs args 109 | evalBody envWithArgs body 110 | 111 | zipParamsArgs :: [String] -> Bool -> [LispVal] -> [(String, LispVal)] 112 | zipParamsArgs params varargs args = 113 | if varargs then 114 | let 115 | (normalargs, varargs) = splitAt (length params - 1) args 116 | in 117 | zip (init params) normalargs ++ [(last params, List varargs)] 118 | else 119 | zip params args 120 | 121 | 122 | 123 | {- Fn -} 124 | makeFn :: Bool -> FnName -> [LispVal] -> [LispVal] -> Env -> LispVal 125 | makeFn isMacro name params body env = 126 | Fn $ FnRecord name isMacro $ Lisp stringParams varargs body env 127 | where stringParams = filter (/= ".") $ map extractString params 128 | extractString (Symbol s) = s 129 | varargs = case drop (length params - 2) params of 130 | [Symbol ".", Symbol vararg] -> True 131 | _ -> False 132 | 133 | 134 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Env 4 | import Eval 5 | import Primitives 6 | import System.Console.Repl 7 | import System.Environment 8 | 9 | 10 | 11 | main = do 12 | globalEnv <- newEnv primitives 13 | args <- getArgs 14 | case args of 15 | [file, "-i"] -> do 16 | evalFile globalEnv file 17 | interactive globalEnv 18 | [file] -> 19 | evalFile globalEnv file 20 | [] -> 21 | interactive globalEnv 22 | where interactive env = 23 | repl "lisp=> " (evalString env) 24 | 25 | 26 | -------------------------------------------------------------------------------- /src/Parse.hs: -------------------------------------------------------------------------------- 1 | module Parse (readOne, readMany, ReadtableKey(..)) where 2 | 3 | import Control.Applicative.Alternative (asum) 4 | import Control.Monad.Reader 5 | import Text.Parsec (ParsecT, runParserT) 6 | import Text.ParserCombinators.Parsec hiding (Parser, spaces) 7 | import Types 8 | 9 | data ReadtableKey = Between String String | Prefix String 10 | type ReadTable = [(ReadtableKey, String)] 11 | 12 | type Parser a = ParsecT String () (Reader ReadTable) a 13 | 14 | 15 | {- Whitespace -} 16 | spaces = skipMany1 space 17 | 18 | comment :: Parser () 19 | comment = do 20 | char ';' 21 | skipMany (noneOf "\n") 22 | 23 | 24 | {- Expression -} 25 | expr :: ReadTable -> Parser LispVal 26 | expr readtable = 27 | e 28 | where e = p <|> symbol <|> number <|> string' <|> list 29 | p = readTableParser readtable 30 | 31 | {- Lists -} 32 | list = do 33 | char '(' 34 | contents <- sepBy e spaces 35 | char ')' 36 | return $ List contents 37 | 38 | {- Strings -} 39 | literalString = 40 | String <$> many1 (noneOf ('\"' : readtableKeys)) 41 | where readtableKeys = concatMap extractPrefix $ filter isPrefix $ map fst readtable 42 | isPrefix (Prefix _) = True 43 | isPrefix _ = False 44 | extractPrefix (Prefix s) = s 45 | 46 | 47 | string' = do 48 | char '"' 49 | xs <- many (p <|> literalString) 50 | char '"' 51 | return $ List (Symbol "string-append" : xs) 52 | 53 | 54 | {- Symbols -} 55 | symbolChar = oneOf "!#$%&|*+-/:<=>?@^_." 56 | 57 | symbolStr = do 58 | first <- letter <|> symbolChar 59 | rest <- many (letter <|> digit <|> symbolChar) 60 | return $ first:rest 61 | 62 | symbol = do 63 | sym <- symbolStr 64 | return $ case sym of 65 | "true" -> Bool True 66 | "false" -> Bool False 67 | "nil" -> Nil 68 | _ -> Symbol sym 69 | 70 | {- Numbers -} 71 | number = 72 | (Number . read) <$> many1 digit 73 | 74 | {- Parsing -} 75 | readTableParser :: ReadTable -> Parser LispVal 76 | readTableParser readtable = 77 | asum $ map makeParser readtable 78 | where makeParser (Prefix s, sym) = do 79 | string s 80 | e <- expr readtable 81 | return $ List [Symbol sym, e] 82 | 83 | makeParser (Between start end, sym) = do 84 | string start 85 | contents <- sepBy (expr readtable) spaces 86 | string end 87 | return $ List (Symbol sym:contents) 88 | 89 | 90 | exprSurroundedByWhitespace = do 91 | readtable <- ask 92 | skipMany space 93 | e <- expr readtable 94 | skipMany space 95 | return e 96 | 97 | readOne :: ReadTable -> String -> LispM LispVal 98 | readOne = parseSyntaxError exprSurroundedByWhitespace 99 | 100 | readMany :: ReadTable -> String -> LispM [LispVal] 101 | readMany = parseSyntaxError $ many exprSurroundedByWhitespace 102 | 103 | parseSyntaxError :: Parser a -> ReadTable -> String -> LispM a 104 | parseSyntaxError p readtable code = 105 | case runReader (runParserT p () "lisp" code) readtable of 106 | Left e -> throwWithStack $ SyntaxError e 107 | Right v -> return v 108 | 109 | -------------------------------------------------------------------------------- /src/Primitives.hs: -------------------------------------------------------------------------------- 1 | module Primitives where 2 | 3 | import Control.Lens ((&), (<&>), (^.)) 4 | import qualified Control.Monad.State.Strict as State 5 | import Control.Monad.Trans 6 | import Data.List 7 | import Data.Maybe (fromJust) 8 | import Data.String.ToString 9 | import Env 10 | import Eval 11 | import Flow 12 | import Network.Wreq 13 | import Parse 14 | import System.Console.Repl 15 | import Text.URI 16 | import Types 17 | 18 | primitives :: [(String, LispVal)] 19 | primitives = purePrimitives ++ impurePrimitives ++ impurePrimitiveMacros ++ [("readtable", readtable)] 20 | 21 | readtable = 22 | toLisp [("~", "unquote"), 23 | ("'", "quote")] 24 | where toLisp = List . map toPair 25 | toPair (s, sym) = List [String s, Symbol sym] 26 | 27 | 28 | purePrimitives = 29 | wrapPrimitives False Pure 30 | [("+", numericBinop (+)), 31 | ("-", numericBinop (-)), 32 | ("*", numericBinop (*)), 33 | ("/", numericBinop div), 34 | ("mod", numericBinop mod), 35 | ("=", equals), 36 | ("and", boolBinop (&&)), 37 | ("or", boolBinop (||)), 38 | ("first", first), 39 | ("rest", rest), 40 | ("cons", cons), 41 | ("list", list), 42 | ("reverse", reverseList), 43 | ("string-append", stringAppend)] 44 | 45 | impurePrimitives = 46 | wrapPrimitives False Impure 47 | [("read", read'), 48 | ("read-many", readMany'), 49 | ("eval", eval'), 50 | ("unquote", eval'), 51 | ("env", env'), 52 | ("debug", debug), 53 | ("print", print'), 54 | ("slurp", slurp), 55 | ("spit", spit)] 56 | 57 | impurePrimitiveMacros = 58 | wrapPrimitives True Impure 59 | [("define", define False), 60 | ("define-syntax", define True), 61 | ("set!", set), 62 | ("lambda", lambda), 63 | ("if", if_), 64 | ("call/cc", callCC)] 65 | 66 | -- Wrap 67 | wrapPrimitives ismacro purity = 68 | map wrap 69 | where wrap (s, f) = (s, Fn $ FnRecord (Named s) ismacro $ Primitive $ purity f) 70 | 71 | wrapPrimitive ismacro purity f = Fn $ FnRecord Anonymous ismacro $ Primitive $ purity f 72 | 73 | -- Impure Functions 74 | read' env [String s] = do 75 | readtable <- getReadtable env 76 | readOne readtable s 77 | 78 | readMany' env [String s] = do 79 | readtable <- getReadtable env 80 | List <$> readMany readtable s 81 | 82 | eval' env (x:_) = 83 | eval env x 84 | 85 | env' env [] = 86 | fmap (List . map toPair) (getVars env) 87 | where toPair (var, val) = List [Symbol var, val] 88 | 89 | debug env [] = do 90 | liftIO $ repl "debug=> " $ evalString env 91 | return Nil 92 | 93 | print' _ [form] = do 94 | liftIO $ putStrLn $ showVal form 95 | return Nil 96 | 97 | -- Impure Macro's 98 | define isMacro env args = 99 | case args of 100 | [Symbol var, form] -> 101 | eval env form >>= defineVar env var 102 | List (Symbol var : params) : body -> 103 | makeFn isMacro (Named var) params body env & defineVar env var 104 | 105 | set env [Symbol var, form] = 106 | eval env form >>= setVar env var 107 | 108 | 109 | lambda env (List params : body) = 110 | return $ makeFn False Anonymous params body env 111 | 112 | if_ env [pred, conseq, alt] = do 113 | result <- eval env pred 114 | return $ case result of 115 | Bool False -> alt 116 | _ -> conseq 117 | 118 | shortCircuit' = wrapPrimitive False Impure sc 119 | where sc env [val] = do 120 | r <- eval env val 121 | shortCircuit r 122 | return r 123 | 124 | callCC env [l] = do 125 | callback <- eval env l 126 | cont <- makeCont 127 | eval env $ List [callback, cont] 128 | where makeCont = do 129 | contFnBody <- topFrame >>= walk replaceContForm 130 | return $ makeFn False Anonymous 131 | [Symbol "x"] 132 | [List [shortCircuit', contFnBody]] 133 | env 134 | 135 | extractCallframe (Callframe val) = 136 | val 137 | 138 | topFrame = 139 | State.get 140 | <&> reverse 141 | <&> map extractCallframe 142 | <&> find containsCallCCForm 143 | <&> fromJust 144 | 145 | containsCallCCForm val = 146 | case val of 147 | List [Symbol "call/cc", _] -> 148 | True 149 | List xs -> 150 | any containsCallCCForm xs 151 | _ -> 152 | False 153 | 154 | replaceContForm val = 155 | return $ case val of 156 | List [Symbol "call/cc", _] -> 157 | Symbol "x" 158 | _ -> 159 | val 160 | 161 | 162 | -- IO primitives 163 | slurp _ [String s] = 164 | String <$> liftIO result 165 | where result = 166 | case parseURI s >>= uriScheme of 167 | Just _ -> get s <&> (^. responseBody) <&> toString 168 | _ -> readFile s 169 | 170 | 171 | spit _ [String f, String s] = do 172 | liftIO $ writeFile f s 173 | return Nil 174 | 175 | 176 | -- Boolean 177 | equals vals = 178 | Bool $ all (== head vals) vals 179 | 180 | -- Varargs 181 | boolBinop op params = 182 | Bool $ foldl1 op $ map unpackBool params 183 | 184 | numericBinop op params = 185 | Number $ foldl1 op $ map unpackNum params 186 | 187 | 188 | -- List 189 | list = 190 | List 191 | 192 | first (List (x:xs):_) = 193 | x 194 | 195 | rest (List (x:xs):_) = 196 | List xs 197 | 198 | rest [List x] = 199 | List x 200 | 201 | cons (x:List xs : _) = 202 | List (x:xs) 203 | 204 | reverseList (List xs : _) = 205 | List (reverse xs) 206 | 207 | 208 | -- String 209 | stringAppend :: [LispVal] -> LispVal 210 | stringAppend = 211 | String . concatMap stringVal 212 | 213 | 214 | -- 215 | -- numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> LispVal 216 | -- numBoolBinop op params = Val.Bool $ foldl1 op $ map unpackNum params 217 | -- 218 | -- boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> LispVal 219 | -- boolBoolBinop op params = Val.Bool $ foldl1 op $ map unpackBool params 220 | 221 | -- Unpack 222 | 223 | unpackNum :: LispVal -> Integer 224 | unpackNum (Number n) = n 225 | 226 | unpackBool:: LispVal -> Bool 227 | unpackBool (Bool b) = b 228 | 229 | 230 | 231 | stringVal (String s) = s 232 | stringVal v = showVal v 233 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import Control.Exception 4 | import Control.Monad.State.Strict 5 | import Control.Monad.Trans.Either 6 | import Data.IORef 7 | import Data.Typeable 8 | import Text.ParserCombinators.Parsec (ParseError) 9 | 10 | 11 | {- Monad Stack 12 | Either for short-circuiting continuations 13 | CallstackIO for stacktraces 14 | -} 15 | newtype LispM a = LispM 16 | { unLispM :: EitherT LispVal (StateT Callstack IO) a } 17 | deriving (Monad, Functor, Applicative, MonadIO, MonadState Callstack) 18 | 19 | 20 | run :: LispM a -> IO (Either LispVal a) 21 | run m = 22 | evalStateT (runEitherT (unLispM m)) [] 23 | 24 | 25 | {- Short circuit evaluation order, abandoning current stack -} 26 | shortCircuit :: LispVal -> LispM () 27 | shortCircuit = LispM . left 28 | 29 | 30 | {- Callstack -} 31 | newtype Callframe = Callframe LispVal 32 | type Callstack = [Callframe] 33 | 34 | 35 | instance Show Callframe where 36 | show (Callframe val) = 37 | showVal val 38 | 39 | 40 | {- Env -} 41 | type Env = IORef [(String, IORef LispVal)] 42 | 43 | 44 | {- Error -} 45 | throwWithStack :: ErrorType -> LispM a 46 | throwWithStack e = do 47 | stack <- get 48 | liftIO $ throw $ LispError e stack 49 | 50 | type Expected = LispVal 51 | type Got = LispVal 52 | 53 | 54 | 55 | data LispError = LispError ErrorType Callstack 56 | deriving (Typeable) 57 | 58 | data ErrorType = UnboundVar String 59 | | SyntaxError ParseError 60 | | NumArgs Int Int 61 | | TypeMismatch Expected Got 62 | | Default String 63 | deriving (Typeable) 64 | 65 | 66 | instance Exception LispError 67 | 68 | instance Show ErrorType where 69 | show (UnboundVar var) = 70 | "Unbound Var: " ++ var 71 | show (SyntaxError parseError) = 72 | "Syntax Error: " ++ show parseError 73 | show (NumArgs expected vals) = 74 | "Wrong number of arguments: expected " ++ show expected ++ ", got " ++ show vals 75 | 76 | instance Show LispError where 77 | show (LispError errType stack) = 78 | show errType ++ "\n" 79 | ++ unlines (map show stack) 80 | 81 | 82 | 83 | {- Val -} 84 | type Arguments = [LispVal] 85 | 86 | data FnName = Anonymous 87 | | Named String 88 | deriving (Show) 89 | 90 | data Purity = Pure ([LispVal] -> LispVal) 91 | | Impure (Env -> [LispVal] -> LispM LispVal) 92 | 93 | data FnType 94 | = Primitive { purity :: Purity } 95 | | Lisp { params :: [String], 96 | varargs :: Bool, 97 | body :: [LispVal], 98 | closure :: Env } 99 | 100 | 101 | data Fn = FnRecord { name :: FnName, 102 | isMacro :: Bool, 103 | fnType :: FnType } 104 | deriving (Show) 105 | 106 | 107 | 108 | data LispVal = Symbol String 109 | | List [LispVal] 110 | | Number Integer 111 | | String String 112 | | Bool Bool 113 | | Nil 114 | | Fn Fn 115 | deriving (Show) 116 | 117 | -- TODO: unpack 118 | 119 | instance Show FnType where 120 | show Primitive{} = "Primitive {..}" 121 | show Lisp{} = "Lisp {..}" 122 | 123 | instance Eq LispVal where 124 | Symbol a == Symbol b = 125 | a == b 126 | Number a == Number b = 127 | a == b 128 | List a == List b = 129 | a == b 130 | Bool a == Bool b = 131 | a == b 132 | Nil == Nil = 133 | True 134 | _ == _ = 135 | False 136 | 137 | 138 | {- Traversal -} 139 | walk :: (LispVal -> LispM LispVal) -> LispVal -> LispM LispVal 140 | walk f val = do 141 | result <- f val 142 | case result of 143 | List items -> 144 | List <$> traverse (walk f) items 145 | _ -> 146 | return result 147 | 148 | replace :: LispVal -> LispVal -> LispVal -> LispM LispVal 149 | replace from to = 150 | walk swap 151 | where swap val 152 | | val == from = return to 153 | | otherwise = return val 154 | 155 | {- Show -} 156 | printVal = putStrLn . showVal 157 | 158 | showVal :: LispVal -> String 159 | showVal val = 160 | case val of 161 | Symbol s -> s 162 | List list -> "(" ++ showListContents list ++ ")" 163 | Number n -> show n 164 | String s -> "\"" ++ s ++ "\"" 165 | Bool True -> "true" 166 | Bool False -> "false" 167 | Nil -> "nil" 168 | Fn f -> showFn f 169 | 170 | 171 | showFn :: Fn -> String 172 | showFn FnRecord { fnType = fnType, isMacro = isMacro } = 173 | case fnType of 174 | Primitive {} -> 175 | "" 176 | Lisp {params = params, varargs = varargs, body = body} -> 177 | "(lambda " ++ showParams params varargs ++ " " ++ showListContents body ++ ")" 178 | 179 | showListContents = 180 | unwords . map showVal 181 | 182 | showParams params varargs 183 | | varargs && (length params == 1) = 184 | head params 185 | 186 | | varargs = 187 | "(" ++ unwords (init params) ++ " . " ++ last params ++ ")" 188 | 189 | | otherwise = 190 | "(" ++ unwords params ++ ")" 191 | 192 | showName name = 193 | case name of 194 | Named s -> s 195 | Anonymous -> "" 196 | 197 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - '.' 5 | extra-deps: 6 | - haskeline-repl-0.4.0.0 7 | - uri-0.1.6.4 8 | resolver: lts-8.5 9 | -------------------------------------------------------------------------------- /usage.txt: -------------------------------------------------------------------------------- 1 | Usage: 2 | lisp 3 | lisp 4 | lisp --interactive 5 | 6 | Options: 7 | -i, --interactive Start a repl session --------------------------------------------------------------------------------