Add semi-working bs

14 files changed, 958 insertions, 0 deletions

diff --git a/apex/Bs.hs b/apex/Bs.hs
new file mode 100644
index 0000000..0f57bc3
--- /dev/null
+++ b/apex/Bs.hs
@@ -0,0 +1,6 @@
+module Bs where
+
+import Language.Bs.Cli (run)
+
+main :: IO ()
+main = run
diff --git a/lore/Language/Bs.hs b/lore/Language/Bs.hs
new file mode 100644
index 0000000..a810706
--- /dev/null
+++ b/lore/Language/Bs.hs
@@ -0,0 +1,12 @@
+-- https://github.com/write-you-a-scheme-v2/scheme
+-- https://github.com/justinethier/husk-scheme
+module Language.Bs
+  ( module X
+  ) where
+
+import Language.Bs.Cli as X
+import Language.Bs.Eval as X
+import Language.Bs.Expr as X
+import Language.Bs.Parser as X
+import Language.Bs.Primitives as X
+import Language.Bs.Repl as X
diff --git a/lore/Language/Bs/Cli.hs b/lore/Language/Bs/Cli.hs
new file mode 100644
index 0000000..eddb97d
--- /dev/null
+++ b/lore/Language/Bs/Cli.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Bs.Cli (
+  run
+) where
+
+import Language.Bs.Eval -- evalFile :: T.Text -> IO ()
+import Language.Bs.Repl -- Repl.mainLoop :: IO ()
+import System.Directory
+import Data.Text.IO as TIO
+import Options.Applicative
+
+-- SOURCES
+--http://book.realworldhaskell.org/read/io.html
+-- https://github.com/pcapriotti/optparse-applicative
+-- https://hackage.haskell.org/package/optparse-applicative
+
+runScript ::  FilePath -> IO ()
+runScript fname = do
+  exists <- doesFileExist fname
+  if exists
+  then TIO.readFile fname >>= evalFile fname
+  else TIO.putStrLn "File does not exist."
+
+data LineOpts = UseReplLineOpts | RunScriptLineOpts String
+
+parseLineOpts :: Parser LineOpts
+parseLineOpts = runScriptOpt <|> runReplOpt
+  where
+    runScriptOpt =
+      RunScriptLineOpts <$> strOption (long "script"
+                                       <> short 's'
+                                       <> metavar "SCRIPT"
+                                       <> help "File containing the script you want to run")
+    runReplOpt =
+      UseReplLineOpts <$ flag' () (long "repl"
+                                   <> short 'r'
+                                   <> help "Run as interavtive read/evaluate/print/loop")
+
+schemeEntryPoint :: LineOpts -> IO ()
+schemeEntryPoint UseReplLineOpts = mainLoop --repl
+schemeEntryPoint (RunScriptLineOpts script) = runScript script
+
+run :: IO ()
+run = execParser opts >>= schemeEntryPoint
+  where
+    opts = info (helper <*> parseLineOpts)
+      ( fullDesc
+     <> header "Executable binary for Write You A Scheme v2.0"
+     <> progDesc "contains an entry point for both running scripts and repl" )
diff --git a/lore/Language/Bs/Eval.hs b/lore/Language/Bs/Eval.hs
new file mode 100644
index 0000000..8246d7b
--- /dev/null
+++ b/lore/Language/Bs/Eval.hs
@@ -0,0 +1,253 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Bs.Eval (
+  evalText,
+  evalFile,
+  runParseTest,
+  safeExec,
+  runASTinEnv,
+  basicEnv,
+  fileToEvalForm,
+  textToEvalForm,
+  getFileContents
+) where
+
+import Control.Exception
+import Control.Monad.Reader
+import Data.Map as Map
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import Language.Bs.Expr
+import Language.Bs.Parser
+import Language.Bs.Primitives
+import System.Directory
+import Text.Parsec
+
+funcEnv :: Map.Map T.Text Expr
+funcEnv = Map.fromList $ primEnv
+  <> [ ("read" , IFun $ IFunc $ unop readFn)
+     , ("parse", IFun $ IFunc $ unop parseFn)
+     , ("eval", IFun $ IFunc $ unop eval)
+     , ("show", IFun $ IFunc $ unop (return . Tape . ppexpr))
+     ]
+
+basicEnv :: Env
+basicEnv = Env Map.empty funcEnv
+
+readFn :: Expr -> Eval Expr
+readFn (Tape txt) = lineToEvalForm txt
+readFn  val       = throw $ TypeMismatch "read expects string, instead got:" val
+
+parseFn :: Expr -> Eval Expr
+parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt
+parseFn val        = throw $ TypeMismatch "parse expects string, instead got:" val
+
+safeExec :: IO a -> IO (Either String a)
+safeExec m = do
+  result <- Control.Exception.try m
+  case result of
+    Left (eTop :: SomeException) ->
+      case fromException eTop of
+        Just (enclosed :: LispError) ->
+          return $ Left (show enclosed)
+        Nothing ->
+          return $ Left (show eTop)
+    Right val ->
+      return $ Right val
+
+runASTinEnv :: Env -> Eval b -> IO b
+runASTinEnv code action = runReaderT (unEval action) code
+
+lineToEvalForm :: T.Text -> Eval Expr
+lineToEvalForm input = either (throw . ParseError . show  )  eval $ readExpr input
+
+evalFile :: FilePath -> T.Text -> IO () -- program file
+evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print
+
+fileToEvalForm :: FilePath -> T.Text -> Eval Expr
+fileToEvalForm filePath input = either (throw . ParseError . show )  evalBody $ readExprFile filePath input
+
+runParseTest :: T.Text -> T.Text -- for view AST
+runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input
+
+sTDLIB :: FilePath
+sTDLIB = "lore/core.scm"
+
+endOfList :: Expr -> Expr -> Expr
+endOfList (List x) expr = List $ x ++ [expr]
+endOfList n _  = throw $ TypeMismatch  "failure to get variable: " n
+
+parseWithLib :: T.Text -> T.Text -> Either ParseError Expr
+parseWithLib std inp = do
+  stdlib <- readExprFile sTDLIB std
+  expr   <- readExpr inp
+  return $ endOfList stdlib expr
+
+
+getFileContents :: FilePath -> IO T.Text
+getFileContents fname = do
+  exists <- doesFileExist fname
+  if exists then TIO.readFile  fname else return "File does not exist."
+
+textToEvalForm :: T.Text -> T.Text -> Eval Expr
+textToEvalForm std input = either (throw . ParseError . show )  evalBody $ parseWithLib std input
+
+evalText :: T.Text -> IO () --REPL
+evalText textExpr = do
+  stdlib <- getFileContents sTDLIB
+  res <- runASTinEnv basicEnv $ textToEvalForm stdlib textExpr
+  print res
+
+getVar :: Expr ->  Eval Expr
+getVar (Atom atom) = do
+  Env{..} <- ask
+  case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions
+      Just x  -> return x
+      Nothing -> throw $ UnboundVar atom
+getVar n = throw $ TypeMismatch  "failure to get variable: " n
+
+ensureAtom :: Expr -> Eval Expr
+ensureAtom n@(Atom _) = return n
+ensureAtom n@(List _) = throw $ TypeMismatch "got list" n
+ensureAtom n = throw $ TypeMismatch "expected an atomic value" n
+
+extractVar :: Expr -> T.Text
+extractVar (Atom atom) = atom
+extractVar n = throw $ TypeMismatch "expected an atomic value" n
+
+getEven :: [t] -> [t]
+getEven [] = []
+getEven (x:xs) = x : getOdd xs
+
+getOdd :: [t] -> [t]
+getOdd [] = []
+getOdd (_:xs) = getEven xs
+
+applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr
+applyFunc expr params args = bindArgsEval params args expr
+
+bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr
+bindArgsEval params args expr = do
+  Env{..} <- ask
+  let newVars = zipWith (\a b -> (extractVar a,b)) params args
+  let (newEnv, newFenv) =  Map.partition (not . isFunc) $ Map.fromList newVars
+  local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr
+
+isFunc :: Expr -> Bool
+isFunc (List ((Atom "lambda"):_)) = True
+isFunc _  = False
+
+eval :: Expr -> Eval Expr
+eval (List [Atom "dumpEnv", x]) = do
+  Env{..} <- ask
+  liftIO $ print $ toList env
+  liftIO $ print $ toList fenv
+  eval x
+eval (Numb i)   = return $ Numb i
+eval (Tape s)   = return $ Tape s
+eval (Bool b)   = return $ Bool b
+eval (List [])  = return Nil
+eval Nil        = return Nil
+eval n@(Atom _) = getVar n
+
+eval (List [Atom "showSF", rest])      = return . Tape . T.pack $ show rest
+eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest
+
+eval (List [Atom "quote", val]) = return val
+
+eval (List [Atom "if", pred_, then_, else_]) = do
+  ifRes <- eval pred_
+  case ifRes of
+    (Bool True)  -> eval then_
+    (Bool False) -> eval else_
+    _ ->
+      throw $ BadSpecialForm "if's first arg must eval into a boolean"
+eval (List ( (:) (Atom "if") _)) =
+  throw $ BadSpecialForm "(if <bool> <s-expr> <s-expr>)"
+
+eval (List [Atom "begin", rest]) = evalBody rest
+eval (List ((:) (Atom "begin") rest )) = evalBody $ List rest
+
+-- top-level define
+-- TODO: how to make this eval correctly?
+eval (List [Atom "define", List (name:args), body]) = do
+  Env{..} <- ask
+  _ <- eval body
+  bindArgsEval (name:args) [body] name
+
+eval (List [Atom "define", name, body]) = do
+  Env{..} <- ask
+  _ <- eval body
+  bindArgsEval [name] [body] name
+
+eval (List [Atom "let", List pairs, expr]) = do
+  Env{..} <- ask
+  atoms <- mapM ensureAtom $ getEven pairs
+  vals  <- mapM eval       $ getOdd  pairs
+  bindArgsEval atoms vals expr
+
+eval (List (Atom "let":_) ) =
+  throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let <pairs> <s-expr>)"
+
+
+eval (List [Atom "lambda", List params, expr]) = do
+  ctx <- ask
+  return  $ Func (IFunc $ applyFunc expr params) ctx
+eval (List (Atom "lambda":_) ) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda <params> <s-expr>)"
+
+
+-- needed to get cadr, etc to work
+eval (List [Atom "cdr", List [Atom "quote", List (_:xs)]]) =
+  return $ List xs
+eval (List [Atom "cdr", arg@(List (x:xs))]) =
+  case x of
+      -- proxy for if the list can be evaluated
+      Atom _ -> do
+        val <- eval arg
+        eval $ List [Atom "cdr", val]
+      _ -> return $ List xs
+
+
+eval (List [Atom "car", List [Atom "quote", List (x:_)]]) =
+  return $  x
+eval (List [Atom "car", arg@(List (x:_))]) =
+  case x of
+      Atom _ -> do
+        val <- eval arg
+        eval $ List [Atom "car", val]
+      _ -> return $ x
+
+
+eval (List ((:) x xs)) = do
+  Env{..} <- ask
+  funVar <- eval x
+  xVal <- mapM eval xs
+  case funVar of
+      (IFun (IFunc internalFn)) ->
+          internalFn xVal
+
+      (Func (IFunc definedFn) (Env benv _)) ->
+          local (const $ Env benv fenv) $ definedFn xVal
+
+      _ ->
+          throw $ NotFunction funVar
+
+updateEnv :: T.Text -> Expr -> Env -> Env
+updateEnv var e@(IFun _)   Env{..} =  Env env $ Map.insert var e fenv
+updateEnv var e@(Func _ _) Env{..} = Env env $ Map.insert var e fenv
+updateEnv var e            Env{..} = Env (Map.insert var e env) fenv
+
+evalBody :: Expr -> Eval Expr
+evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do
+  evalVal <- eval defExpr
+  ctx <- ask
+  local (const $ updateEnv var evalVal ctx) $ eval rest
+
+evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do
+  evalVal <- eval defExpr
+  ctx <- ask
+  local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest
+
+evalBody x = eval x
diff --git a/lore/Language/Bs/Expr.hs b/lore/Language/Bs/Expr.hs
new file mode 100644
index 0000000..d386d0e
--- /dev/null
+++ b/lore/Language/Bs/Expr.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Language.Bs.Expr where
+
+import Data.String (String)
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHC.Show
+import Protolude hiding (show)
+import qualified Text.PrettyPrint.Leijen.Text as PP
+import Text.PrettyPrint.Leijen.Text hiding ((<$>))
+
+type Ctx = Map Text Expr
+data Env = Env { env :: Ctx, fenv :: Ctx }
+    deriving (Eq)
+
+newtype Eval a = Eval { unEval :: ReaderT Env IO a }
+    deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO)
+
+data IFunc = IFunc { fn :: [Expr] -> Eval Expr }
+    deriving (Typeable)
+
+instance Eq IFunc where
+    (==) _ _ = False
+
+data Expr
+  = Atom Text
+  | List [Expr]
+  | Numb Integer
+  | Tape Text
+  | IFun IFunc -- TODO: call this Kern
+  | Func IFunc Env
+  | Bool Bool
+  | Nil
+  deriving (Typeable, Eq)
+
+instance Show Expr where
+    show = T.unpack . ppexpr
+
+data LispErrorType
+  = NumArgs Integer [Expr]
+  | LengthOfList Text Int
+  | ExpectedList Text
+  | ParseError String
+  | TypeMismatch Text Expr
+  | BadSpecialForm Text
+  | NotFunction Expr
+  | UnboundVar Text
+  | Default Expr
+  | ReadFileError Text
+  deriving (Typeable)
+
+data LispError = LispError Expr LispErrorType
+
+instance Show LispErrorType where
+    show = T.unpack . ppexpr
+
+instance Show LispError where
+    show = T.unpack . ppexpr
+
+instance Exception LispErrorType
+instance Exception LispError
+
+ppexpr :: Pretty a => a -> Text
+ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x))
+
+--prettyList :: [Doc] -> Doc
+--prettyList = encloseSep lparen rparen PP.space
+
+instance Pretty Expr where
+    pretty v =
+        case v of
+            Atom a ->
+                textStrict a
+
+            List ls ->
+                prettyList $ fmap pretty ls
+
+            Numb n ->
+                integer n
+
+            Tape t ->
+                textStrict "\"" <> textStrict t <> textStrict "\""
+
+            IFun _ ->
+                textStrict "<internal function>"
+
+            Func _ _ ->
+                textStrict "<lambda function>"
+
+            Bool True ->
+                textStrict "#t"
+
+            Bool False ->
+                textStrict "#f"
+
+            Nil ->
+                textStrict "'()"
+
+instance Pretty LispErrorType where
+  pretty err = case err of
+      NumArgs i args ->
+          textStrict "number of arguments"
+          <$$> textStrict "expected"
+          <+> textStrict (T.pack $ show i)
+          <$$> textStrict "received"
+          <+> textStrict (T.pack $ show $ length args)
+
+
+      LengthOfList txt i ->
+          textStrict "length of list in:"
+          <+> textStrict txt
+          <$$> textStrict "length:"
+          <+> textStrict (T.pack $ show i)
+
+      ParseError txt ->
+          textStrict "cannot parse expr:"
+          <+> textStrict (T.pack txt)
+
+      TypeMismatch txt expr ->
+          textStrict "type mismatch:"
+          <$$> textStrict txt
+          <$$> pretty expr
+
+      BadSpecialForm txt ->
+          textStrict "bad special form:"
+          <$$> textStrict txt
+
+      NotFunction _ ->
+          textStrict "not a function"
+
+      UnboundVar txt ->
+          textStrict "unbound variable:"
+          <$$> textStrict txt
+
+      Default _ ->
+          textStrict "default error"
+
+      ReadFileError txt ->
+          textStrict "error reading file:"
+          <$$> textStrict txt
+
+      ExpectedList txt ->
+          textStrict "expected list:"
+          <$$> textStrict txt
+
+instance Pretty LispError where
+  pretty (LispError expr typ) =
+      textStrict "error evaluating:"
+      <$$> indent 4 (pretty expr)
+      <$$> pretty typ
diff --git a/lore/Language/Bs/Parser.hs b/lore/Language/Bs/Parser.hs
new file mode 100644
index 0000000..6e004ef
--- /dev/null
+++ b/lore/Language/Bs/Parser.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Bs.Parser (
+  readExpr,
+  readExprFile
+) where
+
+import Language.Bs.Expr
+import Text.Parsec
+import Text.Parsec.Text
+import qualified Text.Parsec.Token as Tok
+import qualified Text.Parsec.Language as Lang
+import Data.Functor.Identity (Identity)
+import qualified Data.Text as T
+import Data.Char (digitToInt)
+import Control.Monad (mzero)
+
+lexer :: Tok.GenTokenParser T.Text () Identity
+lexer = Tok.makeTokenParser style
+
+style :: Tok.GenLanguageDef T.Text () Identity
+style = Lang.emptyDef {
+  Tok.commentStart = "#|"
+  , Tok.commentEnd = "|#"
+  , Tok.commentLine = ";"
+  , Tok.opStart = mzero
+  , Tok.opLetter = mzero
+  , Tok.identStart = letter <|> oneOf "!$%&*/:<=>?^_~"
+  , Tok.identLetter = digit <|> letter <|> oneOf "!$%&*/:<=>?^_~+-.@"
+  }
+
+parens :: Parser a -> Parser a
+parens = Tok.parens lexer
+
+whitespace :: Parser ()
+whitespace = Tok.whiteSpace lexer
+
+lexeme :: Parser a -> Parser a
+lexeme = Tok.lexeme lexer
+
+quoted :: Parser a -> Parser a
+quoted p = try (char '\'') *> p
+
+identifier :: Parser T.Text
+identifier = T.pack <$> (Tok.identifier lexer <|> specialIdentifier) <?> "identifier"
+  where
+  specialIdentifier :: Parser String
+  specialIdentifier = lexeme $ try $
+    string "-" <|> string "+" <|> string "..."
+
+-- | The @Radix@ type consists of a base integer (e.g. @10@) and a parser for
+-- digits in that base (e.g. @digit@).
+type Radix = (Integer, Parser Char)
+
+-- | Parse an integer, given a radix as output by @radix@.
+-- Copied from Text.Parsec.Token
+numberWithRadix :: Radix -> Parser Integer
+numberWithRadix (base, baseDigit) = do
+  digits <- many1 baseDigit
+  let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits
+  seq n (return n)
+
+decimal :: Parser Integer
+decimal = Tok.decimal lexer
+
+-- | Parse a sign, return either @id@ or @negate@ based on the sign parsed.
+-- Copied from Text.Parsec.Token
+sign :: Parser (Integer -> Integer)
+sign = char '-' *> return negate
+   <|> char '+' *> return id
+   <|> return id
+
+intRadix :: Radix -> Parser Integer
+intRadix r = sign <*> numberWithRadix r
+
+textLiteral :: Parser T.Text
+textLiteral = T.pack <$> Tok.stringLiteral lexer
+
+nil :: Parser ()
+nil = try ((char '\'') *> string "()") *> return () <?> "nil"
+
+hashVal :: Parser Expr
+hashVal = lexeme $ char '#'
+  *> (char 't' *> return (Bool True)
+  <|> char 'f' *> return (Bool False)
+  <|> char 'b' *> (Numb <$> intRadix (2, oneOf "01"))
+  <|> char 'o' *> (Numb <$> intRadix (8, octDigit))
+  <|> char 'd' *> (Numb <$> intRadix (10, digit))
+  <|> char 'x' *> (Numb <$> intRadix (16, hexDigit))
+  <|> oneOf "ei" *> fail "Unsupported: exactness"
+  <|> char '(' *> fail "Unsupported: vector"
+  <|> char '\\' *> fail "Unsupported: char")
+
+
+lispVal :: Parser Expr
+lispVal = hashVal
+  <|> Nil <$ nil
+  <|> Numb <$> try (sign <*> decimal)
+  <|> Atom <$> identifier
+  <|> Tape <$> textLiteral
+  <|> _Quote <$> quoted lispVal
+  <|> List <$> parens manyExpr
+
+manyExpr :: Parser [Expr]
+manyExpr = lispVal `sepBy` whitespace
+
+_Quote :: Expr -> Expr
+_Quote x = List [Atom "quote", x]
+
+contents :: Parser a -> ParsecT T.Text () Identity a
+contents p = whitespace *> lexeme p <* eof
+
+readExpr :: T.Text -> Either ParseError Expr
+readExpr = parse (contents lispVal) "<stdin>"
+
+readExprFile :: SourceName -> T.Text -> Either ParseError Expr
+readExprFile = parse (contents (List <$> manyExpr))
diff --git a/lore/Language/Bs/Primitives.hs b/lore/Language/Bs/Primitives.hs
new file mode 100644
index 0000000..a2de7bb
--- /dev/null
+++ b/lore/Language/Bs/Primitives.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Bs.Primitives where
+
+import Control.Exception hiding (handle)
+import Control.Monad.Except
+import Data.Text as T
+import Data.Text.IO as TIO
+import Language.Bs.Expr
+import Network.HTTP
+import System.Directory
+import System.IO
+
+type Prim   = [(T.Text, Expr)]
+type Unary  = Expr -> Eval Expr
+type Binary = Expr -> Expr -> Eval Expr
+
+mkF :: ([Expr] -> Eval Expr) -> Expr
+mkF = IFun . IFunc
+
+primEnv :: Prim
+primEnv = [
+    ("+"            , mkF $ binopFold (numOp    (+))  (Numb 0) )
+  , ("*"            , mkF $ binopFold (numOp    (*))  (Numb 1) )
+  , ("string-append", mkF $ binopFold (strOp    (<>)) (Tape "") )
+  , ("-"            , mkF $ binop $    numOp    (-))
+  , ("<"            , mkF $ binop $    numCmp   (<))
+  , ("<="           , mkF $ binop $    numCmp   (<=))
+  , (">"            , mkF $ binop $    numCmp   (>))
+  , (">="           , mkF $ binop $    numCmp   (>=))
+  , ("=="           , mkF $ binop $    numCmp   (==))
+  , ("even?"        , mkF $ unop $     numBool   even)
+  , ("odd?"         , mkF $ unop $     numBool   odd)
+  , ("neg?"         , mkF $ unop $     numBool (< 0))
+  , ("pos?"         , mkF $ unop $     numBool (> 0))
+  , ("eq?"          , mkF $ binop eqCmd )
+  , ("null?"        , mkF $ unop (eqCmd Nil) )
+  , ("bl-eq?"       , mkF $ binop $ eqOp (==))
+  , ("and"          , mkF $ binopFold (eqOp (&&)) (Bool True))
+  , ("or"           , mkF $ binopFold (eqOp (||)) (Bool False))
+  , ("not"          , mkF $ unop $ notOp)
+  , ("cons"         , mkF $ Language.Bs.Primitives.cons)
+  , ("cdr"          , mkF $ Language.Bs.Primitives.cdr)
+  , ("car"          , mkF $ Language.Bs.Primitives.car)
+  , ("quote"        , mkF $ quote)
+  , ("file?"        , mkF $ unop fileExists)
+  , ("slurp"        , mkF $ unop slurp)
+  , ("wslurp"       , mkF $ unop wSlurp)
+  , ("put"          , mkF $ binop put)
+  ]
+
+unop :: Unary -> [Expr] -> Eval Expr
+unop op [x]    = op x
+unop _ args    = throw $ NumArgs 1 args
+
+binop :: Binary -> [Expr] -> Eval Expr
+binop op [x,y]  = op x y
+binop _  args   = throw $ NumArgs 2 args
+
+fileExists :: Expr  -> Eval Expr
+fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt)
+fileExists val          = throw $ TypeMismatch "read expects string, instead got: " val
+
+slurp :: Expr  -> Eval Expr
+slurp (Tape txt) = liftIO $ wFileSlurp txt
+slurp val          =  throw $ TypeMismatch "read expects string, instead got: " val
+
+wFileSlurp :: T.Text -> IO Expr
+wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go
+  where go = readTextFile fileName
+
+openURL :: T.Text -> IO Expr
+openURL x = do
+  req  <- simpleHTTP (getRequest $ T.unpack x)
+  body <- getResponseBody req
+  return $ Tape $ T.pack body
+
+wSlurp :: Expr -> Eval Expr
+wSlurp (Tape txt) =  liftIO  $  openURL txt
+wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val
+
+readTextFile :: T.Text -> Handle -> IO Expr
+readTextFile fileName handle = do
+  exists <- doesFileExist $ T.unpack fileName
+  if exists
+  then (TIO.hGetContents handle) >>= (return . Tape)
+  else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
+
+put :: Expr -> Expr -> Eval Expr
+put (Tape file) (Tape msg) =  liftIO $ wFilePut file msg
+put (Tape _)  val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val
+put val  _ = throw $ TypeMismatch "put expects string, instead got: " val
+
+wFilePut :: T.Text -> T.Text -> IO Expr
+wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go
+  where go = putTextFile fileName msg
+
+putTextFile :: T.Text -> T.Text -> Handle -> IO Expr
+putTextFile fileName msg handle = do
+  canWrite <- hIsWritable handle
+  if canWrite
+  then (TIO.hPutStr handle msg) >> (return $ Tape msg)
+  else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
+
+binopFold :: Binary -> Expr -> [Expr] -> Eval Expr
+binopFold op farg args = case args of
+    []-> throw $ NumArgs 2 args
+    [a,b]  -> op a b
+    _ -> foldM op farg args
+
+numBool :: (Integer -> Bool) -> Expr -> Eval Expr
+numBool op (Numb x) = return $ Bool $ op x
+numBool _   x       = throw $ TypeMismatch "numeric op " x
+
+numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr
+numOp op (Numb x) (Numb y) = return $ Numb $ op x  y
+numOp _  Nil      (Numb y) = return $ Numb y
+numOp _  (Numb x) Nil      = return $ Numb x
+numOp _  x        (Numb _) = throw $ TypeMismatch "numeric op" x
+numOp _  (Numb _)  y       = throw $ TypeMismatch "numeric op" y
+numOp _  x         _       = throw $ TypeMismatch "numeric op" x
+
+strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr
+strOp op (Tape x) (Tape y) = return $ Tape $ op x y
+strOp _  Nil      (Tape y) = return $ Tape y
+strOp _  (Tape x) Nil      = return $ Tape x
+strOp _  x        (Tape _) = throw $ TypeMismatch "string op" x
+strOp _  (Tape _) y        = throw $ TypeMismatch "string op" y
+strOp _  x        _        = throw $ TypeMismatch "string op" x
+
+eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr
+eqOp op (Bool x) (Bool y) = return $ Bool $ op x y
+eqOp _  x        (Bool _) = throw $ TypeMismatch "bool op" x
+eqOp _  (Bool _)  y       = throw $ TypeMismatch "bool op" y
+eqOp _  x         _       = throw $ TypeMismatch "bool op" x
+
+numCmp :: (Integer -> Integer -> Bool) -> Expr -> Expr -> Eval Expr
+numCmp op (Numb x) (Numb y) = return . Bool $ op x  y
+numCmp _  x        (Numb _) = throw $ TypeMismatch "numeric op" x
+numCmp _  (Numb _) y        = throw $ TypeMismatch "numeric op" y
+numCmp _  x        _        = throw $ TypeMismatch "numeric op" x
+
+notOp :: Expr -> Eval Expr
+notOp (Bool True) = return $ Bool False
+notOp (Bool False) = return $ Bool True
+notOp x = throw $ TypeMismatch " not expects Bool" x
+
+eqCmd :: Expr -> Expr -> Eval Expr
+eqCmd (Atom x) (Atom y) = return . Bool $ x == y
+eqCmd (Numb x) (Numb y) = return . Bool $ x == y
+eqCmd (Tape x) (Tape y) = return . Bool $ x == y
+eqCmd (Bool x) (Bool y) = return . Bool $ x == y
+eqCmd  Nil      Nil     = return $ Bool True
+eqCmd  _        _       = return $ Bool False
+
+cons :: [Expr] -> Eval Expr
+cons [x,(List ys)] = return $ List $ x:ys
+cons [x,y]         = return $ List [x,y]
+cons _  = throw $ ExpectedList "cons, in second argument"
+
+car :: [Expr] -> Eval Expr
+car [List []    ] = return Nil
+car [List (x:_)]  = return x
+car []            = return Nil
+car _             = throw $ ExpectedList "car"
+
+cdr :: [Expr] -> Eval Expr
+cdr [List (_:xs)] = return $ List xs
+cdr [List []]     = return Nil
+cdr []            = return Nil
+cdr _             = throw $ ExpectedList "cdr"
+
+quote :: [Expr] -> Eval Expr
+quote [List xs]   = return $ List $ Atom "quote" : xs
+quote [expr]      = return $ List $ Atom "quote" : [expr]
+quote args        = throw $ NumArgs 1 args
diff --git a/lore/Language/Bs/Repl.hs b/lore/Language/Bs/Repl.hs
new file mode 100644
index 0000000..bd8acca
--- /dev/null
+++ b/lore/Language/Bs/Repl.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Bs.Repl (
+  mainLoop,
+) where
+
+import Language.Bs.Eval
+import Data.Text as T
+import Control.Monad.Trans
+import System.Console.Haskeline
+
+type Repl a = InputT IO a
+
+mainLoop :: IO ()
+mainLoop = runInputT defaultSettings repl
+
+repl :: Repl ()
+repl = do
+  minput <- getInputLine "bs> "
+  case minput of
+    Nothing -> outputStrLn "bye."
+    Just input -> liftIO (process input) >> repl
+    --Just input -> (liftIO $ processToAST input) >> repl
+
+process :: String -> IO ()
+process str = do
+  res <- safeExec $ evalText $ T.pack str
+  either putStrLn return res
+
+processToAST :: String -> IO ()
+processToAST str = print $ runParseTest $ T.pack str
diff --git a/lore/Language/Bs/Test.hs b/lore/Language/Bs/Test.hs
new file mode 100644
index 0000000..4a40036
--- /dev/null
+++ b/lore/Language/Bs/Test.hs
@@ -0,0 +1,2 @@
+-- TODO
+module Language.Bs.Test where
diff --git a/lore/core.scm b/lore/core.scm
new file mode 100644
index 0000000..4cb8100
--- /dev/null
+++ b/lore/core.scm
@@ -0,0 +1,61 @@
+;; standard library for bs
+
+(define (not x)            (if x #f #t))
+
+(define (null? obj)        (if (eqv? obj '()) #t #f))
+(define (list objs)        objs)
+(define (identity obj)     obj)
+(define (flip f)           (lambda (x y) (f y x)))
+(define (curry f a)        (lambda (b) (apply f (cons a (list b)))))
+(define (compose f g)      (lambda (x) (f (apply g x))))
+(define zero?              (curry = 0))
+(define positive?          (curry < 0))
+(define negative?          (curry > 0))
+(define (odd? n)           (= (mod n 2) 1))
+(define (even? n)          (= (mod n 2) 0))
+
+(define (foldr f end lst)
+  (if (null? lst)
+    end
+    (f (car lst) (foldr f end (cdr lst)))))
+
+(define (foldl f acc lst)
+  (if (null? lst)
+    acc
+    (foldl f (f acc (car lst)) (cdr lst))))
+
+(define fold   foldl)
+(define reduce foldr)
+
+(define (unfold f init pred)
+  (if (pred init)
+    (cons init '())
+    (cons init (unfold f (f init) pred))))
+
+(define (mem* pred op)
+  (lambda (acc next)
+    (if (and (not acc) (pred (op next)))
+      next
+      acc)))
+
+(define (sum lst)          (fold + 0 lst))
+(define (produce lst)      (fold * 0 1 lst))
+
+(define (max nums)
+  (fold (lambda (x y) (if (> x y) x y))
+        (car nums) (cdr nums)))
+
+(define (min nums)
+  (fold (lambda (x y) (if (< x y) x y))
+        (car nums) (cdr nums)))
+
+(define (length lst)       (fold (lambda (x y) (+ x 1)) 0 lst))
+(define (reverse lst)      (fold (flip cons) '() lst))
+(define (memq obj lst)     (fold (mem* (curry eq? obj) identity) #f lst))
+(define (memv obj lst)     (fold (mem* (curry eqv? obj) identity) #f lst))
+(define (member obj lst)   (fold (mem* (curry equal? obj) identity) #f lst))
+(define (assq obj alist)   (fold (mem* (curry eq? obj) car) #f alist))
+(define (assv obj alist)   (fold (mem* (curry eqv? obj) car) #f alist))
+(define (assoc obj alist)  (fold (mem* (curry equal? obj) car) #f alist))
+(define (map f lst)        (foldr (lambda (x y) (cons (f x) y)) '() lst))
+(define (filter pred lst)  (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
diff --git a/lore/sicp/meta.scm b/lore/sicp/meta.scm
new file mode 100644
index 0000000..94dc784
--- /dev/null
+++ b/lore/sicp/meta.scm
@@ -0,0 +1,20 @@
+(define (eval exp env)
+  (cond
+    ((self-evaluating? exp) exp)
+    ((variable? exp) (lookup-variable-value exp env))
+    ((quoted? exp) (text-of-quotation exp))
+    ((assignment? exp) (eval-assignment exp env))
+    ((definition? exp) (eval-definition exp env))
+    ((if? exp) (eval-if exp env))
+    ((lambda? exp)
+     (make-procedure (lambda-parameters exp)
+                     (lambda-body exp)
+                     env))
+    ((begin? exp)
+     (eval-sequence (begin-actions exp) env))
+    ((cond? exp) (eval (cond->if exp) env))
+    ((application? exp)
+     (apply (eval (operator exp) env)
+            (list-of-values (operands exp) env)))
+    (else
+      (error "Unknown expression type -- EVAL" exp))))
diff --git a/lore/sicp/set.scm b/lore/sicp/set.scm
new file mode 100644
index 0000000..3d60c5c
--- /dev/null
+++ b/lore/sicp/set.scm
@@ -0,0 +1,42 @@
+;; A set module, based on binary trees (from sicp)
+
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+
+(define (make-tree entry left right)
+  (list entry left right))
+
+(define (element-of-set? x set)
+  (cond ((null? set) #f)
+        ((= x (entry set)) #t)
+        ((< x (entry set))
+         (element-of-set? x (left-branch set)))
+        ((> x (entry set))
+         (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+  (cond ((null? set) (make-tree x '() '()))
+        ((= x (entry set)) set)
+        ((< x (entry set))
+         (make-tree (entry set)
+                    (adjoin-set x (left-branch set))
+                    (right-branch set)))
+        ((> x (entry set))
+         (make-tree (entry set)
+                    (left-branch set)
+                    (adjoin-set x (right-branch set))))))
+
+(define (intersection-set set1 set2)
+  (if (or (null? set1) (null? set2))
+    '()
+    (let ((x1 (car set1))
+          (x2 (car set2)))
+      (cond ((= x1 x2)
+             (cons x1
+                   (intersection-set (cdr set1)
+                                     (cdr set2))))
+            ((< x1 x2)
+             (intersection-set (cdr set1) set2))
+            ((< x2 x1)
+             (intersection-set set1 (cdr set2)))))))
diff --git a/pack/bs.nix b/pack/bs.nix
new file mode 100644
index 0000000..3d6b7ee
--- /dev/null
+++ b/pack/bs.nix
@@ -0,0 +1,37 @@
+{ nixpkgs }:
+with nixpkgs;
+let
+  ghc = pkgs.haskell.packages.ghc844.ghcWithPackages (hp: with hp; [
+    containers
+    directory
+    haskeline
+    HTTP
+    mtl
+    optparse-applicative
+    parsec
+    protolude
+    text
+    transformers
+    wl-pprint-text
+  ]);
+  entrypoint = "Bs";
+in
+stdenv.mkDerivation rec {
+  name = "bs";
+  version = "0";
+  src = ../.;
+  nativeBuildInputs = [
+    ghc
+  ];
+  strictDeps = true;
+  buildPhase = ''
+    ${ghc}/bin/ghc \
+      -iapex -ilore \
+      -main-is ${entrypoint} --make apex/${entrypoint}.hs \
+      -o bild/${name}
+  '';
+  installPhase = ''
+    mkdir -p $out/bin
+    cp bild/${name} $out/bin/${name}
+  '';
+}
diff --git a/pack/default.nix b/pack/default.nix
index ee92fde..3c48884 100644
--- a/pack/default.nix
+++ b/pack/default.nix
@@ -4,4 +4,5 @@
 {
   fathom = import ./fathom.nix { inherit nixpkgs; };
   ibb = import ./ibb.nix { inherit nixpkgs; };
+  bs = import ./bs.nix { inherit nixpkgs; };
 }