diff options
Diffstat (limited to 'com/simatime/language/bs')
| -rw-r--r-- | com/simatime/language/bs/cli.hs | 52 | ||||
| -rw-r--r-- | com/simatime/language/bs/eval.hs | 241 | ||||
| -rw-r--r-- | com/simatime/language/bs/expr.hs | 154 | ||||
| -rw-r--r-- | com/simatime/language/bs/parser.hs | 121 | ||||
| -rw-r--r-- | com/simatime/language/bs/primitives.hs | 183 | ||||
| -rw-r--r-- | com/simatime/language/bs/repl.hs | 33 | ||||
| -rw-r--r-- | com/simatime/language/bs/test.hs | 2 |
7 files changed, 0 insertions, 786 deletions
diff --git a/com/simatime/language/bs/cli.hs b/com/simatime/language/bs/cli.hs deleted file mode 100644 index 4c48c86..0000000 --- a/com/simatime/language/bs/cli.hs +++ /dev/null @@ -1,52 +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/com/simatime/language/bs/eval.hs b/com/simatime/language/bs/eval.hs deleted file mode 100644 index 290170b..0000000 --- a/com/simatime/language/bs/eval.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# 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 deleted file mode 100644 index a39c7b6..0000000 --- a/com/simatime/language/bs/expr.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# 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 deleted file mode 100644 index 3044a60..0000000 --- a/com/simatime/language/bs/parser.hs +++ /dev/null @@ -1,121 +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/com/simatime/language/bs/primitives.hs b/com/simatime/language/bs/primitives.hs deleted file mode 100644 index c074c59..0000000 --- a/com/simatime/language/bs/primitives.hs +++ /dev/null @@ -1,183 +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/com/simatime/language/bs/repl.hs b/com/simatime/language/bs/repl.hs deleted file mode 100644 index 64ffaa2..0000000 --- a/com/simatime/language/bs/repl.hs +++ /dev/null @@ -1,33 +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/com/simatime/language/bs/test.hs b/com/simatime/language/bs/test.hs deleted file mode 100644 index 4a40036..0000000 --- a/com/simatime/language/bs/test.hs +++ /dev/null @@ -1,2 +0,0 @@ --- TODO -module Language.Bs.Test where |