summaryrefslogtreecommitdiff
path: root/lore
diff options
context:
space:
mode:
Diffstat (limited to 'lore')
-rw-r--r--lore/Language/Bs.hs12
-rw-r--r--lore/Language/Bs/Cli.hs49
-rw-r--r--lore/Language/Bs/Eval.hs253
-rw-r--r--lore/Language/Bs/Expr.hs153
-rw-r--r--lore/Language/Bs/Parser.hs117
-rw-r--r--lore/Language/Bs/Primitives.hs175
-rw-r--r--lore/Language/Bs/Repl.hs30
-rw-r--r--lore/Language/Bs/Test.hs2
-rw-r--r--lore/core.scm61
-rw-r--r--lore/sicp/meta.scm20
-rw-r--r--lore/sicp/set.scm42
11 files changed, 914 insertions, 0 deletions
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)))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-30 20:22:14 +0000