summaryrefslogtreecommitdiff
path: root/Biz/Language
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2020-04-15 10:06:24 -0700
committerBen Sima <ben@bsima.me>2020-04-15 10:07:02 -0700
commitafa9d701538b9e56622a0bfdf8e04aa358c9cd82 (patch)
treedee95c3955b3fe3d11e80d89823660d28eee0587 /Biz/Language
parentf4b8c0df041b063c0b47d2ec6c818a9c202fd833 (diff)
Reformatting
Now I'm using ormolu instead of brittany for Haskell formatting now. Figured I should just make all of these big changes at once.
Diffstat (limited to 'Biz/Language')
-rw-r--r--Biz/Language/Bs.hs5
-rw-r--r--Biz/Language/Bs/Cli.hs46
-rw-r--r--Biz/Language/Bs/Eval.hs183
-rw-r--r--Biz/Language/Bs/Expr.hs157
-rw-r--r--Biz/Language/Bs/Parser.hs84
-rw-r--r--Biz/Language/Bs/Primitives.hs179
-rw-r--r--Biz/Language/Bs/Repl.hs11
7 files changed, 331 insertions, 334 deletions
diff --git a/Biz/Language/Bs.hs b/Biz/Language/Bs.hs
index a810706..f2d4c9d 100644
--- a/Biz/Language/Bs.hs
+++ b/Biz/Language/Bs.hs
@@ -1,8 +1,9 @@
-- https://github.com/write-you-a-scheme-v2/scheme
-- https://github.com/justinethier/husk-scheme
module Language.Bs
- ( module X
- ) where
+ ( module X,
+ )
+where
import Language.Bs.Cli as X
import Language.Bs.Eval as X
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