From c790672cc244ac4caba1bda3572829a6c6862891 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Sun, 27 Oct 2019 09:48:52 -0700
Subject: move everything to namespace directories
---
com/simatime/language/bs.hs | 12 ++
com/simatime/language/bs/cli.hs | 52 +++++++
com/simatime/language/bs/eval.hs | 241 +++++++++++++++++++++++++++++++++
com/simatime/language/bs/expr.hs | 154 +++++++++++++++++++++
com/simatime/language/bs/parser.hs | 121 +++++++++++++++++
com/simatime/language/bs/primitives.hs | 183 +++++++++++++++++++++++++
com/simatime/language/bs/repl.hs | 33 +++++
com/simatime/language/bs/test.hs | 2 +
8 files changed, 798 insertions(+)
create mode 100644 com/simatime/language/bs.hs
create mode 100644 com/simatime/language/bs/cli.hs
create mode 100644 com/simatime/language/bs/eval.hs
create mode 100644 com/simatime/language/bs/expr.hs
create mode 100644 com/simatime/language/bs/parser.hs
create mode 100644 com/simatime/language/bs/primitives.hs
create mode 100644 com/simatime/language/bs/repl.hs
create mode 100644 com/simatime/language/bs/test.hs
(limited to 'com/simatime/language')
diff --git a/com/simatime/language/bs.hs b/com/simatime/language/bs.hs
new file mode 100644
index 0000000..a810706
--- /dev/null
+++ b/com/simatime/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/com/simatime/language/bs/cli.hs b/com/simatime/language/bs/cli.hs
new file mode 100644
index 0000000..4c48c86
--- /dev/null
+++ b/com/simatime/language/bs/cli.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Language.Bs.Cli (
+ run
+) where
+
+import Data.String
+import Data.Text.IO as TIO
+import Language.Bs.Eval -- evalFile :: T.Text -> IO ()
+import Language.Bs.Repl -- Repl.mainLoop :: IO ()
+import Options.Applicative
+import Protolude
+import System.Directory
+
+-- 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/com/simatime/language/bs/eval.hs b/com/simatime/language/bs/eval.hs
new file mode 100644
index 0000000..290170b
--- /dev/null
+++ b/com/simatime/language/bs/eval.hs
@@ -0,0 +1,241 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Language.Bs.Eval (
+ evalText
+, evalFile
+, runParseTest
+, safeExec
+, runASTinEnv
+, basicEnv
+, fileToEvalForm
+, textToEvalForm
+, getFileContents
+) where
+
+import Control.Exception
+import Control.Monad.Reader
+import qualified Data.Map as Map
+import Data.String
+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 Protolude
+import System.Directory
+
+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
+
+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 -> Eval Expr
+textToEvalForm input = either (throw . ParseError . show ) evalBody $ readExpr input
+
+evalText :: T.Text -> IO () --REPL
+evalText textExpr = do
+ res <- runASTinEnv basicEnv $ textToEvalForm 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/com/simatime/language/bs/expr.hs b/com/simatime/language/bs/expr.hs
new file mode 100644
index 0000000..a39c7b6
--- /dev/null
+++ b/com/simatime/language/bs/expr.hs
@@ -0,0 +1,154 @@
+{-# 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 expr ->
+ textStrict "not a function"
+ <$$> pretty expr
+
+ 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/com/simatime/language/bs/parser.hs b/com/simatime/language/bs/parser.hs
new file mode 100644
index 0000000..3044a60
--- /dev/null
+++ b/com/simatime/language/bs/parser.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Language.Bs.Parser (
+ readExpr
+, readExprFile
+) where
+
+import Control.Monad (fail)
+import Control.Monad (mzero)
+import Data.Char (digitToInt)
+import Data.Functor.Identity (Identity)
+import Data.String
+import qualified Data.Text as T
+import Language.Bs.Expr
+import Protolude hiding ((<|>), try)
+import Text.Parsec
+import qualified Text.Parsec.Language as Lang
+import Text.Parsec.Text
+import qualified Text.Parsec.Token as Tok
+
+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 identity
+ <|> return identity
+
+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/com/simatime/language/bs/primitives.hs b/com/simatime/language/bs/primitives.hs
new file mode 100644
index 0000000..c074c59
--- /dev/null
+++ b/com/simatime/language/bs/primitives.hs
@@ -0,0 +1,183 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- | bs primitives
+--
+-- I would like to reduce the number of primitives in the language to some
+-- minimal number, like SKI combinator or Nock instructions. I'm not sure what
+-- the minimal number is. The idea is to move primitives from here into core.scm
+-- over time.
+module Language.Bs.Primitives where
+
+import Control.Exception
+import Control.Monad.Except
+import Data.Text as T
+import Data.Text.IO as TIO
+import Language.Bs.Expr
+import Network.HTTP
+import Protolude
+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 h = do
+ exists <- doesFileExist $ T.unpack fileName
+ if exists
+ then (TIO.hGetContents h) >>= (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 h = do
+ canWrite <- hIsWritable h
+ if canWrite
+ then (TIO.hPutStr h 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/com/simatime/language/bs/repl.hs b/com/simatime/language/bs/repl.hs
new file mode 100644
index 0000000..64ffaa2
--- /dev/null
+++ b/com/simatime/language/bs/repl.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Language.Bs.Repl (
+mainLoop
+) where
+
+import Control.Monad.Trans
+import Data.String
+import Data.Text as T
+import Language.Bs.Eval
+import Protolude
+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/com/simatime/language/bs/test.hs b/com/simatime/language/bs/test.hs
new file mode 100644
index 0000000..4a40036
--- /dev/null
+++ b/com/simatime/language/bs/test.hs
@@ -0,0 +1,2 @@
+-- TODO
+module Language.Bs.Test where
--
cgit v1.2.3