├── .gitignore ├── Main.hs ├── README.md ├── Wisp ├── Core.hs ├── Interpreter.hs ├── Predicates.hs ├── Primitives.hs ├── Reader.hs ├── STL.hs └── Types.hs ├── repl └── test └── test.wisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | Main 4 | repl 5 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Wisp.Interpreter 4 | import System.Console.GetOpt 5 | import System.Environment 6 | import System.Exit 7 | 8 | options :: [OptDescr (IO ())] 9 | options = [ Option "" ["repl"] 10 | (NoArg repl) 11 | "start wisp REPL" 12 | ] 13 | 14 | main :: IO () 15 | main = do 16 | opts <- getArgs >>= return . getOpt Permute options 17 | case opts of 18 | (os,fs,[]) -> do 19 | sequence_ os 20 | terp <- interpreter 21 | progs <- mapM readFile fs 22 | outs <- mapM (terp . ("(do "++) . (++")")) progs 23 | mapM_ putStr outs 24 | _ -> exitFailure 25 | 26 | repl :: IO () 27 | repl = interpreter >>= loop 28 | where 29 | loop i = getLine >>= i >>= putStrLn >> loop i 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | wisp 2 | ==== 3 | wisp is a tiny interpreted lisp written is haskell & easily embedded into larger haskell programs, e.g., as a scripting language. it includes a superset of the following features: 4 | 5 | - full lexical closures 6 | - tail-call optimization 7 | - macros 8 | - first-class continuations 9 | - pattern matching (on lists) 10 | - automatic currying 11 | 12 | the wisp interpreter 13 | ==================== 14 | 15 | wisp lives in the ST (optionally IO) monad. separate interpreters with completely segregated environments can be run concurrently. wisp has a few IO facilities, but they're completely sandboxed and can't accidentally affect the host program or environment. 16 | 17 | -------------------------------------------------------------------------------- /Wisp/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Wisp.Core (eval, apply) where 3 | 4 | import Wisp.Types 5 | import Wisp.Predicates 6 | import qualified Data.HashTable.ST.Cuckoo as H 7 | import Data.HashTable.Class (fromList) 8 | import Control.Monad 9 | import Control.Monad.Reader 10 | 11 | 12 | eval :: Value s -- the thing being evaluated 13 | -> Frame s -- the evaluation context 14 | -> Continue s 15 | 16 | eval (Sym s) f c = findBinding s f >>= maybe nameError (c . fst) 17 | where 18 | nameError = wispErr $ "ERROR: unable to resolve symbol: " ++ unpack s 19 | 20 | eval (Lst (SF m:ps)) f c = specialForm m ps f c 21 | 22 | eval (Lst (o:ps)) f c = eval o f go 23 | where 24 | go fn = if macro fn then apply fn ps $ \r -> eval r f c 25 | else evalArgs fn ps [] 26 | 27 | evalArgs fn [] es = apply fn (reverse es) c 28 | evalArgs fn (a:as) es = eval a f $ evalArgs fn as . (:es) 29 | 30 | eval v _ c = c v 31 | 32 | 33 | 34 | apply :: Value s -- the value being applied 35 | -> [Value s] -- the arguments 36 | -> Continue s 37 | 38 | apply p@Prim{} [] 39 | | satisfied p = call p [] 40 | | otherwise = ($p) 41 | 42 | apply p@Prim{argSpec = spec} (a:as) 43 | | spec `admits` a = Prim admit (call p . (a:)) `apply` as 44 | | otherwise = const $ wispErr $ "ERROR: bad type: " ++ show a 45 | where 46 | admit = spec {count = max 0 (pred $ count spec), guards = drop 1 $ guards spec} 47 | 48 | apply fn@Fn{} as = either (const . wispErr) funcall $ destructure (Lst bound) (Lst as) 49 | where 50 | funcall kvs c = do 51 | f <- wispST (fromList kvs) >>= return . F (Just $ closure fn) 52 | let fn' = fn{params = unbound, closure = f} 53 | if satisfied fn' then eval (body fn') f c else c fn' 54 | 55 | (bound, unbound) = if length as >= nPos then (params fn, []) 56 | else splitAt (length as) (params fn) 57 | nPos = length . fst . posVarArgs $ params fn 58 | 59 | apply v _ = const . wispErr $ "ERROR: can't apply value: " ++ show v 60 | 61 | 62 | -- helper fns 63 | 64 | -- | Traverse a binding pattern together with a set of values, an return 65 | -- a list of bindings or an error. 66 | destructure :: Value s -- the binding pattern 67 | -> Value s -- the values to be bound 68 | -> Either String [(Symbol, Value s)] -- an error or a list of bindings 69 | 70 | destructure (Sym s) v = Right [(s,v)] 71 | 72 | destructure l0@(Lst l) v0@(Lst v) 73 | | (req, Just s) <- posVarArgs l = do 74 | let (pn,vn) = splitAt (length req) v 75 | pos <- destructure (Lst req) (Lst pn) 76 | var <- destructure s (Lst vn) 77 | return $ var ++ pos 78 | | length l == length v = fmap concat . sequence $ zipWith destructure l v 79 | | otherwise = structError l0 v0 80 | 81 | destructure p v = structError p v 82 | 83 | structError p v = Left . unwords $ 84 | [ "ERROR: structure mismatch in pattern:" , show p , "<-" , show v ] 85 | 86 | 87 | -- | Search for a binding visible from a frame. Return the value and the 88 | -- frame in which it is bound, or Nothing. 89 | findBinding :: Symbol -> Frame s -> Wisp s (Maybe (Value s, Frame s)) 90 | findBinding nm f = wispST (H.lookup (bindings f) nm) 91 | >>= maybe iter (return . return . (,f)) 92 | where iter = maybe (return Nothing) (findBinding nm) (parent f) 93 | 94 | 95 | -- | Return the positional & variadic parameters of a parameter list. 96 | -- If multiple variadic parameters are supplied, ignores all but the first 97 | -- one. 98 | posVarArgs :: [Value s] -> ([Value s], Maybe (Value s)) 99 | posVarArgs p = case break (== Sym (pack "&")) p of 100 | (ps,_:v:_) -> (ps, Just v) 101 | _ -> (p, Nothing) 102 | 103 | 104 | -- | Special form handler. 105 | specialForm :: Form -- the special form 106 | -> [Value s] -- the arguments 107 | -> Frame s -- the calling context 108 | -> Continue s -- continuation 109 | 110 | specialForm Do (p:ps) f c = eval p f $ 111 | if null ps then c else const (specialForm Do ps f c) 112 | 113 | specialForm If [cond,y,n] f c = eval cond f $ \res -> 114 | eval (if res == Bln False then n else y) f c 115 | 116 | specialForm Lambda (Lst ps:b) f c = c $ Fn ps False (Lst $ SF Do:b) f 117 | specialForm Macro (Lst ps:b) f c = c $ Fn ps True (Lst $ SF Do:b) f 118 | 119 | specialForm Quote [v] _ c = c v 120 | 121 | specialForm Quasiquote [val] f cont = spliceV val cont 122 | where 123 | spliceV (Lst [SF Splice, v]) = eval v f 124 | spliceV (Lst l) = spliceL l [] 125 | spliceV v = ($v) 126 | spliceL [] l' c = c $ Lst l' 127 | spliceL (Lst l:t) vs c 128 | | [SF Merge, v] <- l = eval v f $ \v' -> case v' of 129 | Lst l' -> spliceL t (vs ++ l') c 130 | _ -> wispErr $ "ERROR: can't merge non-list: " ++ show v' 131 | | otherwise = spliceV (Lst l) $ \l' -> spliceL t (vs ++ [l']) c 132 | spliceL (v:t) vs c = spliceL t (vs ++ [v]) c 133 | 134 | specialForm Splice _ _ _ = wispErr "ERROR: splice outside quasiquoted expression" 135 | specialForm Merge _ _ _ = wispErr "ERROR: merge outside quasiquoted expression" 136 | 137 | specialForm Def [s, xp] f c = eval xp f $ \v -> 138 | either wispErr (def v) $ destructure s v 139 | where 140 | bindV = uncurry $ H.insert $ bindings f 141 | def v kvs = do 142 | wispST $ mapM_ bindV kvs 143 | c v 144 | 145 | specialForm Set [Sym s, xp] f c = findBinding s f >>= maybe nameError setV 146 | where 147 | nameError = wispErr $ "ERROR: set: free or immutable variable: " ++ unpack s 148 | setV (_, tf) = eval xp f $ \v -> do 149 | wispST $ H.insert (bindings tf) s v 150 | c v 151 | 152 | specialForm Undef [Sym s] f c = findBinding s f >>= maybe nameError unbind 153 | where 154 | nameError = wispErr $ "ERROR: undef: free or immutable variable: " ++ unpack s 155 | unbind (v, tf) = do 156 | wispST $ H.delete (bindings tf) s 157 | c v 158 | 159 | specialForm Catch (handler:xps) f c = eval handler f $ \h -> 160 | let h' e = apply h [Str e] c in 161 | local (\e -> e{abort=h'}) $ eval (Lst $ SF Do:xps) f c 162 | 163 | specialForm sf _ _ _ = wispErr $ "ERROR: syntax error in special form: " ++ show sf 164 | 165 | -------------------------------------------------------------------------------- /Wisp/Interpreter.hs: -------------------------------------------------------------------------------- 1 | -- simple embedded wisp interpreters 2 | module Wisp.Interpreter 3 | ( interpreter 4 | , interpreter' 5 | ) where 6 | 7 | import Wisp.Types 8 | import Wisp.Core 9 | import Wisp.Primitives 10 | import Wisp.Reader 11 | import Control.Monad.ST 12 | import Control.Monad.Reader 13 | import Control.Monad.Writer 14 | import System.Random 15 | 16 | type Interpreter m = String -> m String 17 | 18 | 19 | interpreter :: IO (Interpreter IO) 20 | interpreter = newStdGen >>= stToIO . interpreter' >>= return . (stToIO.) 21 | 22 | 23 | interpreter' :: StdGen -> ST s (Interpreter (ST s)) 24 | interpreter' gen = do 25 | tl <- mkToplevel 26 | let env = Env tl reportError mempty gen 27 | Right val = parseWisp "(fn (s) (print (str (eval (read s)))))" 28 | 29 | (rep,_) <- runWriterT $ runReaderT (eval val tl return) env 30 | 31 | return $ \v -> 32 | fmap (show . snd) . runWriterT $ 33 | runReaderT (apply rep [Str v] return) env 34 | 35 | where 36 | reportError s = do 37 | tell $ output s 38 | return $ Str s 39 | 40 | 41 | -------------------------------------------------------------------------------- /Wisp/Predicates.hs: -------------------------------------------------------------------------------- 1 | module Wisp.Predicates 2 | ( (|||) 3 | , anyValue 4 | , number 5 | , string 6 | , symbol 7 | , bool 8 | , list 9 | , primitive 10 | , macro 11 | , function 12 | , applicable 13 | , integer 14 | , float 15 | , strings 16 | , numbers 17 | , integers 18 | , floats 19 | , bools 20 | , functions 21 | , macros 22 | , symbols 23 | , lists 24 | , primitives 25 | , arguments 26 | , admits 27 | , satisfied 28 | ) where 29 | 30 | import Wisp.Types 31 | 32 | (|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) 33 | p1 ||| p2 = \s -> p1 s || p2 s 34 | 35 | anyValue = const True 36 | 37 | string (Str _) = True 38 | string _ = False 39 | 40 | integer (Int _) = True 41 | integer _ = False 42 | 43 | float (Flt _) = True 44 | float _ = False 45 | 46 | number = integer ||| float 47 | 48 | bool (Bln _) = True 49 | bool _ = False 50 | 51 | function Fn{isMacro = m} = not m 52 | function _ = False 53 | 54 | macro Fn{isMacro = m} = m 55 | macro _ = False 56 | 57 | applicable = function ||| macro ||| primitive 58 | 59 | symbol (Sym _) = True 60 | symbol _ = False 61 | 62 | list (Lst _) = True 63 | list _ = False 64 | 65 | primitive (Prim _ _) = True 66 | primitive _ = False 67 | 68 | strings = repeat string 69 | numbers = repeat number 70 | integers = repeat integer 71 | floats = repeat float 72 | bools = repeat bool 73 | functions = repeat function 74 | macros = repeat macro 75 | symbols = repeat symbol 76 | lists = repeat list 77 | primitives = repeat primitive 78 | arguments = [] 79 | 80 | satisfied :: Value s -> Bool 81 | satisfied Prim{argSpec = as} = count as == 0 82 | satisfied Fn{params = ps} = length ps == 0 83 | 84 | admits :: ArgSpec -> Value s -> Bool 85 | Exactly 0 _ `admits` _ = False 86 | spec `admits` arg 87 | | null $ guards spec = True 88 | | otherwise = head (guards spec) arg 89 | 90 | -------------------------------------------------------------------------------- /Wisp/Primitives.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, PatternGuards, TupleSections #-} 2 | module Wisp.Primitives (mkToplevel) where 3 | 4 | import Wisp.Types 5 | import Wisp.Predicates 6 | import Wisp.Core 7 | import Wisp.Reader 8 | import Wisp.STL 9 | import Control.Monad 10 | import Control.Monad.ST 11 | import Control.Monad.Reader 12 | import Control.Monad.Writer 13 | import Data.HashTable.Class (fromList) 14 | import System.Random 15 | 16 | mkToplevel :: ST s (Frame s) 17 | mkToplevel = do 18 | base <- return . F Nothing =<< bs 19 | let e = Env base (error . show) "" (mkStdGen 0) 20 | _ <- runWriterT $ runReaderT (eval stl base return) e 21 | return base 22 | where 23 | bs = fromList $ 24 | [ (pack "+", math (+)) 25 | , (pack "-", math (-)) 26 | , (pack "*", math (*)) 27 | , (pack "/", p_div) 28 | , (pack "=", p_eq) 29 | , (pack "apply", p_apply) 30 | , (pack "eval", p_eval) 31 | , (pack "str", p_str) 32 | , (pack "symbol", p_sym) 33 | , (pack "int", p_int) 34 | , (pack "error", p_err) 35 | , (pack "arity", p_arity) 36 | , (pack "bool?", check bool ) 37 | , (pack "integer?", check integer) 38 | , (pack "string?", check string ) 39 | , (pack "number?", check number ) 40 | , (pack "func?", check function ) 41 | , (pack "list?", check list ) 42 | , (pack "symbol?", check symbol ) 43 | , (pack "primitive?", check primitive ) 44 | , (pack "macro?", check macro ) 45 | , (pack "<", p_lt) 46 | , (pack "call/cc", p_call_cc) 47 | , (pack "read", p_read) 48 | , (pack "print", p_print) 49 | , (pack "rand", p_rand) 50 | , (pack "mod", p_mod) 51 | , (pack "get-line", p_get_line) 52 | , (pack "get-char", p_get_char) 53 | , (pack "get-input", p_get_input) 54 | ] 55 | 56 | ylppa = flip ($) 57 | 58 | -- PRIMITIVE FN COMBINATORS 59 | -- | Predicate wrapper for variadic typechecking functions. 60 | check p = Prim (anyNumber arguments) $ ylppa . Bln . all p 61 | 62 | -- PRIMITIVE FUNCTIONS 63 | 64 | -- | string coercion 65 | p_str = Prim (anyNumber arguments) $ ylppa . Str . concatMap stringify 66 | where 67 | stringify (Str s) = s 68 | stringify v = show v 69 | 70 | -- | call-with-current-continuation 71 | p_call_cc = Prim (Exactly 1 [applicable]) $ \(a:_) -> 72 | return . cc >>= apply a 73 | where 74 | cc c = Prim (Exactly 1 arguments) $ const . c . head 75 | 76 | -- | equality 77 | p_eq = Prim (anyNumber arguments) $ \vs -> 78 | ylppa . Bln . and . zipWith (==) vs $ drop 1 vs 79 | 80 | -- | apply 81 | p_apply = Prim (Exactly 2 [applicable, list]) $ \[a, Lst l] -> apply a l 82 | 83 | p_eval = Prim (Exactly 1 arguments) $ \[v] c -> 84 | asks toplevel >>= \tl -> eval v tl c 85 | 86 | -- | integer coercion 87 | p_int = Prim (Exactly 1 numbers) $ ylppa . intg 88 | where 89 | intg [Flt f] = Int $ floor f 90 | intg [n] = n 91 | 92 | -- | raise an error 93 | p_err = Prim (Exactly 1 strings) $ \[Str e] _ -> 94 | wispErr $ "ERROR: " ++ e 95 | 96 | -- | get fn arity 97 | p_arity = Prim (Exactly 1 [function ||| macro]) $ 98 | ylppa . Int . fromIntegral . length . takeWhile (/= splat) . params . head 99 | where 100 | splat = Sym $ pack "&" 101 | 102 | -- | string -> symbol coercion 103 | p_sym = Prim (Exactly 1 strings) $ \[Str s] -> 104 | ylppa (Sym $ pack s) 105 | 106 | -- | division 107 | p_div = Prim (AtLeast 1 numbers) $ \(h:t) c -> 108 | either wispErr c $ foldM s_div h t 109 | 110 | -- | Parse a string into wisp data. 111 | p_read = Prim (Exactly 1 strings) $ \[Str s] c -> 112 | either (wispErr . show) c $ parseWisp s 113 | 114 | 115 | 116 | -- Sandboxed basic IO operations via reader/writer monads. 117 | 118 | io_get :: (String -> Maybe (String, String)) -> Value s 119 | io_get fn = Prim (Exactly 0 arguments) $ \_ c -> 120 | asks input >>= \i -> case fn i of 121 | Just (k,ks) -> local (\e -> e{input=ks}) $ c (Str k) 122 | _ -> wispErr "ERROR: end of input" 123 | 124 | p_get_line = io_get $ \i -> 125 | if null i then Nothing 126 | else let (l,ls) = break (=='\n') i in return (l, drop 1 ls) 127 | 128 | p_get_char = io_get $ \i -> 129 | if null i then Nothing 130 | else return ([head i], tail i) 131 | 132 | p_get_input = io_get $ return . (,"") 133 | 134 | p_print = Prim (anyNumber arguments) $ \args c -> 135 | apply p_str args $ \str@(Str s) -> tell (output s) >> c str 136 | 137 | 138 | -- Math operations. 139 | 140 | -- | Wrapper for variadic math operations on arbitrary numeric types 141 | math :: (forall a. Num a => a -> a -> a) -> Value s 142 | math op = Prim (AtLeast 1 numbers) $ ylppa . foldl1 (s_num_op op) 143 | 144 | -- | Polymorphic binary math op application. Handles coercion between numeric 145 | -- types. 146 | s_num_op :: (forall a. Num a => a -> a -> a) -> Value s -> Value s -> Value s 147 | s_num_op (?) s1 s2 = case (s1, s2) of 148 | (Int a, Int b) -> Int $ a ? b 149 | (Int a, Flt b) -> Flt $ fromIntegral a ? b 150 | (Flt a, Int b) -> Flt $ a ? fromIntegral b 151 | (Flt a, Flt b) -> Flt $ a ? b 152 | 153 | -- | Division within & across numeric types. 154 | s_div :: Value s -> Value s -> Either String (Value s) 155 | s_div s1 s2 156 | | s2 == Int 0 || s2 == Flt 0 = Left "ERROR: divide by zero" 157 | | otherwise = return $ case (s1, s2) of 158 | (Int a, Int b) -> Int $ quot a b 159 | (Int a, Flt b) -> Flt $ fromIntegral a / b 160 | (Flt a, Int b) -> Flt $ a / fromIntegral b 161 | (Flt a, Flt b) -> Flt $ a / b 162 | 163 | p_mod = Prim (Exactly 2 integers) $ \[Int a, Int b] -> 164 | ylppa . Int $ a `mod` b 165 | 166 | -- | Comparison. 167 | p_lt = Prim (Exactly 2 numbers) $ \ns -> ylppa $ Bln $ case ns of 168 | [Int a, Int b] -> a < b 169 | [Int a, Flt b] -> fromIntegral a < b 170 | [Flt a, Int b] -> a < fromIntegral b 171 | [Flt a, Flt b] -> a < b 172 | 173 | p_rand = Prim (Exactly 0 arguments) $ \_ c -> do 174 | gen <- asks randomSeed 175 | let (i,ng) = random gen 176 | local (\e -> e{randomSeed=ng}) $ c $ Int i 177 | 178 | -------------------------------------------------------------------------------- /Wisp/Reader.hs: -------------------------------------------------------------------------------- 1 | module Wisp.Reader (parseWisp) where 2 | 3 | import Wisp.Types 4 | import Text.ParserCombinators.Parsec hiding (count) 5 | import Control.Applicative hiding ((<|>), many, optional) 6 | 7 | parseWisp :: String -> Either ParseError (Value s) 8 | parseWisp = parse wisp "" 9 | 10 | wisp :: GenParser Char st (Value s) 11 | wisp = optional whitespace *> expr <* optional whitespace 12 | where 13 | 14 | whitespace = many1 $ oneOf " \n\t\r" 15 | 16 | expr = nakedExpr <|> quotedExpr <|> quasiquotedExpr <|> splicedExpr <|> mergedExpr 17 | 18 | nakedExpr = sexp <|> atom 19 | 20 | quotedExpr = (\v -> Lst [SF Quote, v]) `fmap` (quote *> expr) 21 | where quote = char '\'' 22 | 23 | quasiquotedExpr = (\v -> Lst [SF Quasiquote, v]) `fmap` (qquote *> expr) 24 | where qquote = char '`' 25 | 26 | splicedExpr = (\v -> Lst [SF Splice, v]) `fmap` (splice *> expr) 27 | where splice = char ',' 28 | 29 | mergedExpr = (\v -> Lst [SF Merge, v]) `fmap` (splice *> expr) 30 | where splice = char '@' 31 | 32 | sexp = fmap Lst $ char '(' *> optional (whitespace <|> comment) *> (fm <|> ls) <* char ')' 33 | fm = (:) <$> specialForm <*> ls 34 | ls = expr `sepEndBy` many (whitespace <|> comment) 35 | 36 | comment = char ';' *> many (noneOf "\n") <* char '\n' 37 | 38 | atom = str <|> number <|> symbol <|> true <|> false 39 | 40 | escaped c r = try $ string ['\\', c] >> return r 41 | 42 | str = Str `fmap` (char '"' *> many stringContents <* char '"') 43 | where stringContents = escaped '"' '"' 44 | <|> escaped 'n' '\n' 45 | <|> escaped 'r' '\r' 46 | <|> escaped 't' '\t' 47 | <|> escaped '\\' '\\' 48 | <|> noneOf "\\\"" 49 | 50 | specialForm = sf "if" If 51 | <|> sf "do" Do 52 | <|> sf "fn" Lambda 53 | <|> sf "def" Def 54 | <|> sf "set" Set 55 | <|> sf "macro" Macro 56 | <|> sf "quote" Quote 57 | <|> sf "quasiquote" Quasiquote 58 | <|> sf "splice" Splice 59 | <|> sf "merge" Merge 60 | <|> sf "undef" Undef 61 | <|> sf "catch" Catch 62 | 63 | sf s f = try $ string s >> whitespace >> return (SF f) 64 | 65 | symbol = (Sym . pack) `fmap` ((:) <$> symC <*> many (digit <|> symC)) 66 | where symC = oneOf (['a'..'z'] ++ ['A'..'Z'] ++ "_+-=*/.!?:<>&$^|{}[]%~") 67 | 68 | number = (Flt . read) `fmap` try dec 69 | <|> (Int . read) `fmap` try neg 70 | <|> (Int . read) `fmap` pos 71 | 72 | where pos = many1 digit 73 | neg = (:) <$> char '-' <*> pos 74 | dec = (++) <$> (pos <|> neg) <*> ((:) <$> char '.' <*> pos) 75 | 76 | true = fmap Bln $ try (string "#t") >> return True 77 | false = fmap Bln $ try (string "#f") >> return False 78 | 79 | -------------------------------------------------------------------------------- /Wisp/STL.hs: -------------------------------------------------------------------------------- 1 | module Wisp.STL (stl) where 2 | 3 | import Wisp.Reader 4 | 5 | stl = case parseWisp l of 6 | Right v -> v 7 | Left err -> error $ show err 8 | where 9 | l = unlines $ 10 | [ "(do" 11 | , " (def defm (macro (name args & body)" 12 | , " `(def ,name (macro ,args @body))))" 13 | , " (defm defn (name args & body)" 14 | , " `(def ,name (fn ,args @body)))" 15 | , " (defn list (& as) as)" 16 | , " (defn loop (f) (f) (loop f))" 17 | , " (defn id (n) n)" 18 | , " (defn println (s) (print s \"\n\"))" 19 | , " (defm cond (& cases)" 20 | , " (fold (fn (l c)" 21 | , " `(if ,(car c)" 22 | , " (do @(cdr c))" 23 | , " ,l))" 24 | , " '(error \"cond: fell through\")" 25 | , " (reverse cases)))" 26 | 27 | , " (defm let (binds & body)" 28 | , " `((fn ,(map car binds) @body) @(map cadr binds)))" 29 | 30 | , " (defn member (e lst)" 31 | , " (cond ((null? lst) #f)" 32 | , " ((= (car lst) e) lst)" 33 | , " (#t (member e (cdr lst)))))" 34 | 35 | , " (defn length (l)" 36 | , " (if (null? l)" 37 | , " 0" 38 | , " (+ 1 (length (cdr l)))))" 39 | 40 | , " (defn null? (l)" 41 | , " (if (list? l)" 42 | , " (= l '())" 43 | , " (error (str \"ERROR: Bad type: \" l))))" 44 | 45 | , " (defn flip (f a b) (f b a))" 46 | 47 | , " (defn comp (f g)" 48 | , " (fn (n) (f (g n))))" 49 | 50 | , " (defn car (l)" 51 | , " (if (null? l)" 52 | , " (error \"car: null list\")" 53 | , " (apply (fn (h & _) h)" 54 | , " l)))" 55 | 56 | , " (defn cdr (l)" 57 | , " (if (null? l)" 58 | , " l" 59 | , " (apply (fn (_ & t) t)" 60 | , " l)))" 61 | 62 | , " (defn /= (a b) (not (= a b)))" 63 | , " (defn > (a b) (and (not (= a b))" 64 | , " (not (< a b))))" 65 | , " (defn >= (a b) (or (= a b) (> a b)))" 66 | , " (defn <= (a b) (or (= a b) (< a b)))" 67 | 68 | , " (def caar (comp car car))" 69 | , " (def cadr (comp car cdr))" 70 | , " (def cddr (comp cdr cdr))" 71 | , " (def cdar (comp cdr car))" 72 | 73 | , " (def caaar (comp car caar))" 74 | , " (def caadr (comp car cadr))" 75 | , " (def cadar (comp car cdar))" 76 | , " (def caddr (comp car cddr))" 77 | , " (def cdaar (comp cdr caar))" 78 | , " (def cdadr (comp cdr cadr))" 79 | , " (def cddar (comp cdr cdar))" 80 | , " (def cdddr (comp cdr cddr))" 81 | 82 | , " (defn assoc (v l)" 83 | , " (cond ((null? l) #f)" 84 | , " ((= v (caar l)) (cadar l))" 85 | , " (#t (assoc v (cdr l)))))" 86 | 87 | , " (defn map (op l)" 88 | , " (if (null? l)" 89 | , " l" 90 | , " (cons (op (car l))" 91 | , " (map op (cdr l)))))" 92 | 93 | , " (defn filter (p l)" 94 | , " (cond ((null? l) l)" 95 | , " ((p (car l))" 96 | , " (cons (car l)" 97 | , " (filter p (cdr l))))" 98 | , " (#t (filter p (cdr l)))))" 99 | 100 | , " (defn fold (op acc l)" 101 | , " (if (null? l)" 102 | , " acc" 103 | , " (fold op (op acc (car l)) (cdr l))))" 104 | 105 | , " (defn cons (new-car new-cdr)" 106 | , " (if (list? new-cdr)" 107 | , " `(,new-car @new-cdr)" 108 | , " (error (str \"Bad type: \" new-cdr))))" 109 | 110 | , " (defn not (v) (if v #f #t))" 111 | , " (defn && (a b) (if a b a))" 112 | , " (defn || (a b) (if a a b))" 113 | , " (defm and (& clauses)" 114 | , " (let (((cls1 & clss) (reverse clauses)))" 115 | , " (fold (fn (prev cur) `(let ((current-clause ,cur)) (if current-clause ,prev current-clause))) cls1 clss)))" 116 | , " (defm or (& clauses)" 117 | , " (let (((cls1 & clss) (reverse clauses)))" 118 | , " (fold (fn (prev cur) `(let ((current-clause ,cur)) (if current-clause current-clause ,prev))) cls1 clss)))" 119 | 120 | , " (defn reverse (l)" 121 | , " (defn inner (acc l)" 122 | , " (if (null? l)" 123 | , " acc" 124 | , " (inner (cons (car l) acc)" 125 | , " (cdr l))))" 126 | , " (inner '() l))" 127 | 128 | , " (defn inc (n) (+ n 1))" 129 | , " (defn dec (n) (- n 1))" 130 | , " (defn id (n) n)" 131 | , " (defn const (x) (fn (y) x))" 132 | 133 | , " (defn rem (a b)" 134 | , " (- a (* b (/ a b))))" 135 | 136 | , " (def floor int)" 137 | 138 | , " (defn ceil (n)" 139 | , " (let ((f (floor n)))" 140 | , " (if (= n f) f (inc f))))" 141 | 142 | , " (defn abs (n)" 143 | , " (if (< n 0)" 144 | , " (* n -1)" 145 | , " n))" 146 | 147 | , " (defn append (l1 l2)" 148 | , " (if (null? l1)" 149 | , " l2" 150 | , " (cons (car l1)" 151 | , " (append (cdr l1) l2))))" 152 | 153 | , " (defn juxt (f g)" 154 | , " (fn (& t)" 155 | , " (list (apply f t)" 156 | , " (apply g t))))" 157 | 158 | , " (defn join (strs j)" 159 | , " (fold (fn (s1 s2) (str s1 j s2)) (car strs) (cdr strs)))" 160 | 161 | , " (defn println (s) (print s \"\n\"))" 162 | 163 | , " (defm test (suite & ts)" 164 | , " (if (list? suite)" 165 | , " (set ts (cons suite ts))" 166 | , " (print \"Testing \" suite \" \"))" 167 | , " (defn pass () (print \".\"))" 168 | , " (defn fail () (print \"X\"))" 169 | , " (def failures '())" 170 | , " (map (fn (x)" 171 | , " (let (((doc t) x))" 172 | , " (if (eval t)" 173 | , " (pass)" 174 | , " (do (set failures (cons doc failures))" 175 | , " (fail)))))" 176 | , " ts)" 177 | , " (if (null? failures)" 178 | , " (do (println \" ok!\") #t)" 179 | , " (do" 180 | , " (println (str \"\n\" (length failures) \" failure(s): \"))" 181 | , " (map println failures)" 182 | , " #f)))" 183 | , ")" 184 | , ")" 185 | ] 186 | 187 | -------------------------------------------------------------------------------- /Wisp/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, TupleSections, FlexibleInstances #-} 2 | module Wisp.Types 3 | ( Wisp 4 | , Env(..) 5 | , Symbol 6 | , Value(..) 7 | , Frame(..) 8 | , Form(..) 9 | , Output(..) 10 | , wispErr 11 | , wispST 12 | , pack 13 | , unpack 14 | , ArgSpec(..) 15 | , Continue 16 | , anyNumber 17 | , output 18 | ) where 19 | 20 | import qualified Data.HashTable.ST.Cuckoo as HT 21 | import Data.ByteString (ByteString) 22 | import Data.ByteString.Char8 (pack, unpack) 23 | import Control.Monad.ST 24 | import Control.Monad.Reader 25 | import Control.Monad.Writer 26 | import System.Random 27 | import Data.Monoid 28 | 29 | 30 | type Continue s = (Value s -> Wisp s (Value s)) -> Wisp s (Value s) 31 | 32 | type Symbol = ByteString 33 | 34 | type Wisp s a = ReaderT (Env s) (WriterT (Output Char) (ST s)) a 35 | 36 | data Env s = Env { toplevel :: Frame s 37 | , abort :: String -> Wisp s (Value s) 38 | , input :: String 39 | , randomSeed :: StdGen 40 | } 41 | 42 | newtype Output a = Output ([a] -> [a]) 43 | 44 | instance Monoid (Output a) where 45 | mempty = Output id 46 | mappend (Output a) (Output b) = Output $ a . b 47 | 48 | instance Show (Output Char) where 49 | show (Output o) = o "" 50 | 51 | output :: [a] -> Output a 52 | output = Output . (++) 53 | 54 | 55 | wispErr :: String -> Wisp s (Value s) 56 | wispErr e = asks abort >>= ($ e ++ "\n") 57 | 58 | wispST :: ST s a -> Wisp s a 59 | wispST = ReaderT . const . WriterT . fmap (,mempty) 60 | 61 | data ArgSpec = Exactly { count :: Int, guards :: forall s. [Value s -> Bool]} 62 | | AtLeast { count :: Int, guards :: forall s. [Value s -> Bool]} 63 | 64 | anyNumber = AtLeast 0 65 | 66 | data Frame s = F { parent :: Maybe (Frame s) 67 | , bindings :: HT.HashTable s Symbol (Value s) 68 | } 69 | 70 | data Value s = Int Int 71 | | Lst [Value s] 72 | | Sym Symbol 73 | | Bln Bool 74 | | Str String 75 | | Flt Double 76 | | Fn { params :: [Value s] 77 | , isMacro :: Bool 78 | , body :: Value s 79 | , closure :: Frame s 80 | } 81 | | Prim { argSpec :: ArgSpec 82 | , call :: [Value s] -> Continue s 83 | } 84 | | SF Form 85 | 86 | data Form = Do | If | Lambda | Def | Set | Macro | Quote | Quasiquote | Splice | Merge | Undef | Catch deriving Eq 87 | 88 | instance Show Form where 89 | show Do = "do" 90 | show If = "if" 91 | show Lambda = "fn" 92 | show Def = "def" 93 | show Set = "set" 94 | show Macro = "macro" 95 | show Quote = "quote" 96 | show Quasiquote = "quasiquote" 97 | show Splice = "splice" 98 | show Merge = "merge" 99 | show Undef = "undef" 100 | show Catch = "catch" 101 | 102 | instance Show (Value s) where 103 | show (Int i) = show i 104 | show (Flt f) = show f 105 | show (Bln b) = if b then "#t" else "#f" 106 | show (Lst l) = "(" ++ unwords (map show l) ++ ")" 107 | show (Sym s) = unpack s 108 | show (Str s) = show s 109 | show (SF f) = show f 110 | show (Prim as _) = "#" 111 | show (Fn{params = ps}) = "#" 112 | 113 | instance Eq (Value s) where 114 | Int a == Int b = a == b 115 | Lst a == Lst b = a == b 116 | Sym a == Sym b = a == b 117 | Str a == Str b = a == b 118 | Bln a == Bln b = a == b 119 | Flt a == Flt b = a == b 120 | Int a == Flt b = fromIntegral a == b 121 | Flt a == Int b = a == fromIntegral b 122 | SF a == SF b = a == b 123 | _ == _ = False 124 | 125 | instance Show ArgSpec where 126 | show (Exactly n _) = "exactly " ++ show n 127 | show (AtLeast n _) = "at least " ++ show n 128 | 129 | -------------------------------------------------------------------------------- /repl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | import Wisp 3 | 4 | main :: IO () 5 | main = interpreter >>= loop 6 | where 7 | loop i = getLine >>= i >>= putStrLn >> loop i 8 | 9 | -------------------------------------------------------------------------------- /test/test.wisp: -------------------------------------------------------------------------------- 1 | (test "math functions" 2 | ("equality" 3 | (and (= 1 1.0) 4 | (= 1 1) 5 | (= 1.0 1) 6 | (= 1.0 1.0) 7 | (not (= 1 2)) 8 | (not (= 1.6 -312542)))) 9 | 10 | ("integer division" 11 | (= 1 (/ 3 2))) 12 | 13 | ("floating point division" 14 | (= 1.5 15 | (/ 3 2.0) 16 | (/ 3.0 2) 17 | (/ 3.0 2.0)))) 18 | 19 | (test "library functions" 20 | 21 | ("map" 22 | (= (map inc '(1 2 3)) '(2 3 4))) 23 | 24 | ("fold" 25 | (= (fold (flip cons) '() '(1 2 3 4 5)) '(5 4 3 2 1))) 26 | 27 | ("filter" 28 | (= (filter number? '(1 2 'a "wat" (pfffff))) '(1 2))) 29 | 30 | ("comp" 31 | (= '(#t) ((comp list symbol?) 'sym))) 32 | 33 | ("type predicates" 34 | (and (list? '(1)) 35 | (number? 72165972.451) 36 | (string? "no way bro") 37 | (symbol? 'hahawow) 38 | (bool? #f) 39 | (not (string? 'wat)) 40 | (not (list? "glug")) 41 | (not (primitive? list)) 42 | (primitive? +) 43 | (not (number? "pew pew pew"))))) 44 | 45 | (test "currying" 46 | ("currying" 47 | (let ((ap (fn (op a b) (op a b)))) 48 | (and (= (+ 1 2) (((ap +) 1) 2)) 49 | (= "abc" ((ap str) "a" "bc")) 50 | (= '(a (b c)) (((ap list) 'a) '(b c)))))) 51 | 52 | ("let, currying, and scoping" 53 | (let ((a 1) (b 2) (c 3) (add3 (fn (c d e) (+ c d e)))) 54 | (and (= a 1) 55 | (= b 2) 56 | (= c 3) 57 | (= 6 (add3 a b c)) 58 | (= 6 (((add3 a) b) c)))))) 59 | 60 | (test "list destructuring" 61 | ("destructuring" 62 | (let (((a (b c) & d) '(1 (2 3) 4 5 6))) 63 | (and (= 1 a) 64 | (= 2 b) 65 | (= 3 c) 66 | (= '(4 5 6) d)))) 67 | 68 | ("destructuring with currying" 69 | (let ((f (fn (a (b & c)) (list a b c)))) 70 | (= '(1 2 (3)) ((f 1) '(2 3))))) 71 | 72 | ("destructuring in definitions" 73 | (do 74 | (def (a b c (d e) & f) '(1 2 3 (4 5) 6 7 8)) 75 | (and (= a 1) 76 | (= b 2) 77 | (= c 3) 78 | (= d 4) 79 | (= e 5) 80 | (= f '(6 7 8)))))) 81 | 82 | (test "continuations" 83 | ("escaping" 84 | (do (def ok #t) 85 | (and (= 7 (call/cc (fn (cc) 1 2 (cc 7) (set ok #f)))) 86 | ok)))) 87 | 88 | --------------------------------------------------------------------------------