diff options
Diffstat (limited to 'com/simatime/language')
| -rw-r--r-- | com/simatime/language/bs.hs | 12 | ||||
| -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 |
8 files changed, 798 insertions, 0 deletions
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 |