diff options
Diffstat (limited to 'Biz/Language')
| -rw-r--r-- | Biz/Language/Bs.hs | 13 | ||||
| -rw-r--r-- | Biz/Language/Bs/Cli.hs | 64 | ||||
| -rw-r--r-- | Biz/Language/Bs/Eval.hs | 224 | ||||
| -rw-r--r-- | Biz/Language/Bs/Expr.hs | 139 | ||||
| -rw-r--r-- | Biz/Language/Bs/Parser.hs | 129 | ||||
| -rw-r--r-- | Biz/Language/Bs/Primitives.hs | 188 | ||||
| -rw-r--r-- | Biz/Language/Bs/Repl.hs | 36 | ||||
| -rw-r--r-- | Biz/Language/Bs/Test.hs | 2 |
8 files changed, 0 insertions, 795 deletions
diff --git a/Biz/Language/Bs.hs b/Biz/Language/Bs.hs deleted file mode 100644 index f2d4c9d..0000000 --- a/Biz/Language/Bs.hs +++ /dev/null @@ -1,13 +0,0 @@ --- 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/Biz/Language/Bs/Cli.hs b/Biz/Language/Bs/Cli.hs deleted file mode 100644 index d2ac1e4..0000000 --- a/Biz/Language/Bs/Cli.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# 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/Biz/Language/Bs/Eval.hs b/Biz/Language/Bs/Eval.hs deleted file mode 100644 index 1198a3e..0000000 --- a/Biz/Language/Bs/Eval.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# 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/Biz/Language/Bs/Expr.hs b/Biz/Language/Bs/Expr.hs deleted file mode 100644 index 2452622..0000000 --- a/Biz/Language/Bs/Expr.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -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/Biz/Language/Bs/Parser.hs b/Biz/Language/Bs/Parser.hs deleted file mode 100644 index 574536d..0000000 --- a/Biz/Language/Bs/Parser.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# 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/Biz/Language/Bs/Primitives.hs b/Biz/Language/Bs/Primitives.hs deleted file mode 100644 index 4c70499..0000000 --- a/Biz/Language/Bs/Primitives.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# 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/Biz/Language/Bs/Repl.hs b/Biz/Language/Bs/Repl.hs deleted file mode 100644 index 24f1bcd..0000000 --- a/Biz/Language/Bs/Repl.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# 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/Biz/Language/Bs/Test.hs b/Biz/Language/Bs/Test.hs deleted file mode 100644 index 4a40036..0000000 --- a/Biz/Language/Bs/Test.hs +++ /dev/null @@ -1,2 +0,0 @@ --- TODO -module Language.Bs.Test where |