diff options
Diffstat (limited to 'Biz/Language/Bs')
| -rw-r--r-- | Biz/Language/Bs/Cli.hs | 46 | ||||
| -rw-r--r-- | Biz/Language/Bs/Eval.hs | 183 | ||||
| -rw-r--r-- | Biz/Language/Bs/Expr.hs | 157 | ||||
| -rw-r--r-- | Biz/Language/Bs/Parser.hs | 84 | ||||
| -rw-r--r-- | Biz/Language/Bs/Primitives.hs | 179 | ||||
| -rw-r--r-- | Biz/Language/Bs/Repl.hs | 11 |
6 files changed, 328 insertions, 332 deletions
diff --git a/Biz/Language/Bs/Cli.hs b/Biz/Language/Bs/Cli.hs index 4c48c86..d2ac1e4 100644 --- a/Biz/Language/Bs/Cli.hs +++ b/Biz/Language/Bs/Cli.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Cli ( - run -) where + +module Language.Bs.Cli + ( run, + ) +where import Data.String import Data.Text.IO as TIO @@ -17,12 +19,12 @@ import System.Directory -- https://github.com/pcapriotti/optparse-applicative -- https://hackage.haskell.org/package/optparse-applicative -runScript :: FilePath -> IO () +runScript :: FilePath -> IO () runScript fname = do exists <- doesFileExist fname if exists - then TIO.readFile fname >>= evalFile fname - else TIO.putStrLn "File does not exist." + then TIO.readFile fname >>= evalFile fname + else TIO.putStrLn "File does not exist." data LineOpts = UseReplLineOpts | RunScriptLineOpts String @@ -30,14 +32,21 @@ 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") + 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") + UseReplLineOpts + <$ flag' + () + ( long "repl" + <> short 'r' + <> help "Run as interavtive read/evaluate/print/loop" + ) schemeEntryPoint :: LineOpts -> IO () schemeEntryPoint UseReplLineOpts = mainLoop --repl @@ -46,7 +55,10 @@ 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" ) + 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 index 290170b..1198a3e 100644 --- a/Biz/Language/Bs/Eval.hs +++ b/Biz/Language/Bs/Eval.hs @@ -1,19 +1,21 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Eval ( - evalText -, evalFile -, runParseTest -, safeExec -, runASTinEnv -, basicEnv -, fileToEvalForm -, textToEvalForm -, getFileContents -) where + +module Language.Bs.Eval + ( evalText, + evalFile, + runParseTest, + safeExec, + runASTinEnv, + basicEnv, + fileToEvalForm, + textToEvalForm, + getFileContents, + ) +where import Control.Exception import Control.Monad.Reader @@ -28,23 +30,25 @@ 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)) - ] +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 +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 +parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val safeExec :: IO a -> IO (Either String a) safeExec m = do @@ -63,13 +67,13 @@ 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 +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 +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 @@ -77,23 +81,23 @@ 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." + 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 +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 :: Expr -> Eval Expr getVar (Atom atom) = do - Env{..} <- ask + 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 + 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 @@ -106,136 +110,115 @@ extractVar n = throw $ TypeMismatch "expected an atomic value" n getEven :: [t] -> [t] getEven [] = [] -getEven (x:xs) = x : getOdd xs +getEven (x : xs) = x : getOdd xs getOdd :: [t] -> [t] getOdd [] = [] -getOdd (_:xs) = getEven xs +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 + 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 +isFunc (List ((Atom "lambda") : _)) = True +isFunc _ = False eval :: Expr -> Eval Expr eval (List [Atom "dumpEnv", x]) = do - Env{..} <- ask + 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 (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 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 True) -> eval then_ (Bool False) -> eval else_ _ -> throw $ BadSpecialForm "if's first arg must eval into a boolean" -eval (List ( (:) (Atom "if") _)) = +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 - +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 (List [Atom "define", List (name : args), body]) = do + Env {..} <- ask _ <- eval body - bindArgsEval (name:args) [body] name - + bindArgsEval (name : args) [body] name eval (List [Atom "define", name, body]) = do - Env{..} <- ask + Env {..} <- ask _ <- eval body bindArgsEval [name] [body] name - eval (List [Atom "let", List pairs, expr]) = do - Env{..} <- ask + Env {..} <- ask atoms <- mapM ensureAtom $ getEven pairs - vals <- mapM eval $ getOdd pairs + vals <- mapM eval $ getOdd pairs bindArgsEval atoms vals expr - -eval (List (Atom "let":_) ) = +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>)" - - + 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)]]) = +eval (List [Atom "cdr", List [Atom "quote", List (_ : xs)]]) = return $ List xs -eval (List [Atom "cdr", arg@(List (x: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:_))]) = + -- 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 - - + Atom _ -> do + val <- eval arg + eval $ List [Atom "car", val] + _ -> return $ x eval (List ((:) x xs)) = do - Env{..} <- ask + 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 + (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 +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 index a39c7b6..2452622 100644 --- a/Biz/Language/Bs/Expr.hs +++ b/Biz/Language/Bs/Expr.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + module Language.Bs.Expr where import Data.String (String) @@ -13,17 +14,18 @@ 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 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) +data IFunc = IFunc {fn :: [Expr] -> Eval Expr} + deriving (Typeable) instance Eq IFunc where - (==) _ _ = False + (==) _ _ = False data Expr = Atom Text @@ -37,7 +39,7 @@ data Expr deriving (Typeable, Eq) instance Show Expr where - show = T.unpack . ppexpr + show = T.unpack . ppexpr data LispErrorType = NumArgs Integer [Expr] @@ -55,12 +57,13 @@ data LispErrorType data LispError = LispError Expr LispErrorType instance Show LispErrorType where - show = T.unpack . ppexpr + show = T.unpack . ppexpr instance Show LispError where - show = T.unpack . ppexpr + show = T.unpack . ppexpr instance Exception LispErrorType + instance Exception LispError ppexpr :: Pretty a => a -> Text @@ -70,85 +73,67 @@ ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x)) --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 "'()" + 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 + 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:" + textStrict "error evaluating:" <$$> indent 4 (pretty expr) <$$> pretty typ diff --git a/Biz/Language/Bs/Parser.hs b/Biz/Language/Bs/Parser.hs index 3044a60..574536d 100644 --- a/Biz/Language/Bs/Parser.hs +++ b/Biz/Language/Bs/Parser.hs @@ -1,10 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Parser ( - readExpr -, readExprFile -) where + +module Language.Bs.Parser + ( readExpr, + readExprFile, + ) +where import Control.Monad (fail) import Control.Monad (mzero) @@ -23,15 +25,16 @@ 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 "!$%&*/:<=>?^_~+-.@" - } +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 @@ -48,9 +51,10 @@ 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 "..." + 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@). @@ -61,7 +65,7 @@ type Radix = (Integer, Parser Char) numberWithRadix :: Radix -> Parser Integer numberWithRadix (base, baseDigit) = do digits <- many1 baseDigit - let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits seq n (return n) decimal :: Parser Integer @@ -70,9 +74,10 @@ 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 +sign = + char '-' *> return negate + <|> char '+' *> return identity + <|> return identity intRadix :: Radix -> Parser Integer intRadix r = sign <*> numberWithRadix r @@ -84,26 +89,29 @@ 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") - +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 +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 diff --git a/Biz/Language/Bs/Primitives.hs b/Biz/Language/Bs/Primitives.hs index c074c59..4c70499 100644 --- a/Biz/Language/Bs/Primitives.hs +++ b/Biz/Language/Bs/Primitives.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} + -- | bs primitives -- -- I would like to reduce the number of primitives in the language to some @@ -18,134 +19,138 @@ import Protolude import System.Directory import System.IO -type Prim = [(T.Text, Expr)] -type Unary = Expr -> Eval Expr +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_) +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 +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 +binop op [x, y] = op x y +binop _ args = throw $ NumArgs 2 args -fileExists :: Expr -> Eval Expr +fileExists :: Expr -> Eval Expr fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt) -fileExists val = throw $ TypeMismatch "read expects string, instead got: " val +fileExists val = throw $ TypeMismatch "read expects string, instead got: " val -slurp :: Expr -> Eval Expr +slurp :: Expr -> Eval Expr slurp (Tape txt) = liftIO $ wFileSlurp txt -slurp val = throw $ TypeMismatch "read expects string, instead got: " val +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 + where + go = readTextFile fileName openURL :: T.Text -> IO Expr openURL x = do - req <- simpleHTTP (getRequest $ T.unpack x) + 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 (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] + 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 +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 + 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] + 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 + [] -> 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 +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 +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 +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 +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 +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 @@ -157,27 +162,27 @@ 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 +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" +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" +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" +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 +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 index 64ffaa2..24f1bcd 100644 --- a/Biz/Language/Bs/Repl.hs +++ b/Biz/Language/Bs/Repl.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Repl ( -mainLoop -) where + +module Language.Bs.Repl + ( mainLoop, + ) +where import Control.Monad.Trans import Data.String @@ -22,7 +24,8 @@ repl = do case minput of Nothing -> outputStrLn "bye." Just input -> (liftIO $ process input) >> repl - --Just input -> (liftIO $ processToAST input) >> repl + +--Just input -> (liftIO $ processToAST input) >> repl process :: String -> IO () process str = do |