summaryrefslogtreecommitdiff
path: root/Biz
diff options
context:
space:
mode:
Diffstat (limited to 'Biz')
-rw-r--r--Biz/Ibb/Client.hs1
-rw-r--r--Biz/Ibb/Core.hs6
-rw-r--r--Biz/Ibb/Influencers.hs2
-rw-r--r--Biz/Ibb/Keep.hs6
-rw-r--r--Biz/Ibb/Look.hs4
-rw-r--r--Biz/Ibb/Server.hs18
-rw-r--r--Biz/Language/Bs.hs13
-rw-r--r--Biz/Language/Bs/Cli.hs64
-rw-r--r--Biz/Language/Bs/Eval.hs224
-rw-r--r--Biz/Language/Bs/Expr.hs139
-rw-r--r--Biz/Language/Bs/Parser.hs129
-rw-r--r--Biz/Language/Bs/Primitives.hs188
-rw-r--r--Biz/Language/Bs/Repl.hs36
-rw-r--r--Biz/Language/Bs/Test.hs2
14 files changed, 14 insertions, 818 deletions
diff --git a/Biz/Ibb/Client.hs b/Biz/Ibb/Client.hs
index 89e0ffc..c3dae4b 100644
--- a/Biz/Ibb/Client.hs
+++ b/Biz/Ibb/Client.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
diff --git a/Biz/Ibb/Core.hs b/Biz/Ibb/Core.hs
index 2c1fbae..007d835 100644
--- a/Biz/Ibb/Core.hs
+++ b/Biz/Ibb/Core.hs
@@ -83,7 +83,7 @@ data Action
deriving (Show, Eq)
home :: Model -> View Action
-home m = see m
+home = see
handlers :: Model -> View Action
handlers = home
@@ -134,7 +134,7 @@ seePerson person =
[]
[ a_
[ class_ "fab fa-twitter",
- href_ $ "https://twitter.com/" <> (ms $ _twitter person)
+ href_ $ "https://twitter.com/" <> ms (_twitter person)
]
[],
a_ [class_ "fas fa-globe", href_ $ ms $ _website person] []
@@ -151,7 +151,7 @@ seeBook book =
[]
[ a_
[ class_ "text-dark",
- href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book)
+ href_ $ "https://www.amazon.com/dp/" <> ms (_amznref book)
]
[text $ ms $ _title book]
]
diff --git a/Biz/Ibb/Influencers.hs b/Biz/Ibb/Influencers.hs
index cf53cc0..08ce3e8 100644
--- a/Biz/Ibb/Influencers.hs
+++ b/Biz/Ibb/Influencers.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Biz.Ibb.Influencers where
diff --git a/Biz/Ibb/Keep.hs b/Biz/Ibb/Keep.hs
index d546aae..8ee1228 100644
--- a/Biz/Ibb/Keep.hs
+++ b/Biz/Ibb/Keep.hs
@@ -27,7 +27,7 @@ import qualified Data.Text as Text
-- * Keep
-- | Main database. Need to think of a better name for this.
-data IbbKeep
+newtype IbbKeep
= IbbKeep
{ _people :: IxSet Person
}
@@ -79,9 +79,7 @@ newPerson name blurb = do
}
getPeople :: Int -> Acid.Query IbbKeep [Person]
-getPeople n = do
- keep <- ask
- return $ take n $ IxSet.toList $ _people keep
+getPeople n = take n $ IxSet.toList $ _people keep </ ask
-- * Index @Book@
diff --git a/Biz/Ibb/Look.hs b/Biz/Ibb/Look.hs
index 1ab12c1..50cda9e 100644
--- a/Biz/Ibb/Look.hs
+++ b/Biz/Ibb/Look.hs
@@ -26,8 +26,8 @@ main = do
justifyContent center
flexDirection column
fontFamily ["GillSans", "Calibri", "Trebuchet"] [sansSerif]
- headings ? do
- fontFamily
+ headings
+ ? fontFamily
[ "Palatino",
"Palatino Linotype",
"Hoefler Text",
diff --git a/Biz/Ibb/Server.hs b/Biz/Ibb/Server.hs
index b5a7464..e87c55a 100644
--- a/Biz/Ibb/Server.hs
+++ b/Biz/Ibb/Server.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
@@ -57,11 +55,11 @@ import System.Environment (lookupEnv)
main :: IO ()
main = do
say "rise: ibb"
- staticDir <- fromMaybe "static" <$> lookupEnv "STATIC_DIR" :: IO [Char]
- port <- read <$> fromMaybe "3000" <$> lookupEnv "PORT" :: IO Int
+ staticDir <- fromMaybe "static" <$> lookupEnv "STATIC_DIR" :: IO String
+ port <- (read . fromMaybe "3000" <$> lookupEnv "PORT") :: IO Int
keep <- Keep.openLocal "_keep/"
say "port: 3000"
- run port $ logStdout $ compress $ app staticDir $ keep
+ run port $ logStdout $ compress $ app staticDir keep
where
compress = gzip def {gzipFiles = GzipCompress}
@@ -75,8 +73,7 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
L.meta_ [L.charset_ "utf-8"]
jsRef "/static/ibb.js"
cssRef "/css/main.css"
- L.body_ $ do
- page
+ L.body_ page
where
page = L.toHtml x
jsRef href =
@@ -100,8 +97,7 @@ handle404 _ respond =
$ responseLBS status404 [("Content-Type", "text/html")]
$ renderBS
$ toHtml
- $ HtmlPage
- $ notfound
+ $ HtmlPage notfound
newtype CSS
= CSS
@@ -128,7 +124,7 @@ type Routes =
cssHandlers :: Server CssRoute
cssHandlers = return . Lazy.toStrict . Clay.render $ Look.main
-app :: [Char] -> AcidState Keep.IbbKeep -> Application
+app :: String -> AcidState Keep.IbbKeep -> Application
app staticDir keep =
serve (Proxy @Routes) $
static
@@ -137,7 +133,7 @@ app staticDir keep =
:<|> apiHandlers keep
:<|> Tagged handle404
where
- static = serveDirectoryWith (defaultWebAppSettings $ staticDir)
+ static = serveDirectoryWith (defaultWebAppSettings staticDir)
type ApiRoutes = "people" :> Get '[JSON] [Person]
diff --git a/Biz/Language/Bs.hs b/Biz/Language/Bs.hs
deleted file mode 100644
index f2d4c9d..0000000
--- a/Biz/Language/Bs.hs
+++ /dev/null
@@ -1,13 +0,0 @@
--- https://github.com/write-you-a-scheme-v2/scheme
--- https://github.com/justinethier/husk-scheme
-module Language.Bs
- ( module X,
- )
-where
-
-import Language.Bs.Cli as X
-import Language.Bs.Eval as X
-import Language.Bs.Expr as X
-import Language.Bs.Parser as X
-import Language.Bs.Primitives as X
-import Language.Bs.Repl as X
diff --git a/Biz/Language/Bs/Cli.hs b/Biz/Language/Bs/Cli.hs
deleted file mode 100644
index d2ac1e4..0000000
--- a/Biz/Language/Bs/Cli.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Bs.Cli
- ( run,
- )
-where
-
-import Data.String
-import Data.Text.IO as TIO
-import Language.Bs.Eval -- evalFile :: T.Text -> IO ()
-import Language.Bs.Repl -- Repl.mainLoop :: IO ()
-import Options.Applicative
-import Protolude
-import System.Directory
-
--- SOURCES
---http://book.realworldhaskell.org/read/io.html
--- https://github.com/pcapriotti/optparse-applicative
--- https://hackage.haskell.org/package/optparse-applicative
-
-runScript :: FilePath -> IO ()
-runScript fname = do
- exists <- doesFileExist fname
- if exists
- then TIO.readFile fname >>= evalFile fname
- else TIO.putStrLn "File does not exist."
-
-data LineOpts = UseReplLineOpts | RunScriptLineOpts String
-
-parseLineOpts :: Parser LineOpts
-parseLineOpts = runScriptOpt <|> runReplOpt
- where
- runScriptOpt =
- RunScriptLineOpts
- <$> strOption
- ( long "script"
- <> short 's'
- <> metavar "SCRIPT"
- <> help "File containing the script you want to run"
- )
- runReplOpt =
- UseReplLineOpts
- <$ flag'
- ()
- ( long "repl"
- <> short 'r'
- <> help "Run as interavtive read/evaluate/print/loop"
- )
-
-schemeEntryPoint :: LineOpts -> IO ()
-schemeEntryPoint UseReplLineOpts = mainLoop --repl
-schemeEntryPoint (RunScriptLineOpts script) = runScript script
-
-run :: IO ()
-run = execParser opts >>= schemeEntryPoint
- where
- opts =
- info
- (helper <*> parseLineOpts)
- ( fullDesc
- <> header "Executable binary for Write You A Scheme v2.0"
- <> progDesc "contains an entry point for both running scripts and repl"
- )
diff --git a/Biz/Language/Bs/Eval.hs b/Biz/Language/Bs/Eval.hs
deleted file mode 100644
index 1198a3e..0000000
--- a/Biz/Language/Bs/Eval.hs
+++ /dev/null
@@ -1,224 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Bs.Eval
- ( evalText,
- evalFile,
- runParseTest,
- safeExec,
- runASTinEnv,
- basicEnv,
- fileToEvalForm,
- textToEvalForm,
- getFileContents,
- )
-where
-
-import Control.Exception
-import Control.Monad.Reader
-import qualified Data.Map as Map
-import Data.String
-import qualified Data.Text as T
-import qualified Data.Text.IO as TIO
-import Language.Bs.Expr
-import Language.Bs.Parser
-import Language.Bs.Primitives
-import Protolude
-import System.Directory
-
-funcEnv :: Map.Map T.Text Expr
-funcEnv =
- Map.fromList $
- primEnv
- <> [ ("read", IFun $ IFunc $ unop readFn),
- ("parse", IFun $ IFunc $ unop parseFn),
- ("eval", IFun $ IFunc $ unop eval),
- ("show", IFun $ IFunc $ unop (return . Tape . ppexpr))
- ]
-
-basicEnv :: Env
-basicEnv = Env Map.empty funcEnv
-
-readFn :: Expr -> Eval Expr
-readFn (Tape txt) = lineToEvalForm txt
-readFn val = throw $ TypeMismatch "read expects string, instead got:" val
-
-parseFn :: Expr -> Eval Expr
-parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt
-parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val
-
-safeExec :: IO a -> IO (Either String a)
-safeExec m = do
- result <- Control.Exception.try m
- case result of
- Left (eTop :: SomeException) ->
- case fromException eTop of
- Just (enclosed :: LispError) ->
- return $ Left (show enclosed)
- Nothing ->
- return $ Left (show eTop)
- Right val ->
- return $ Right val
-
-runASTinEnv :: Env -> Eval b -> IO b
-runASTinEnv code action = runReaderT (unEval action) code
-
-lineToEvalForm :: T.Text -> Eval Expr
-lineToEvalForm input = either (throw . ParseError . show) eval $ readExpr input
-
-evalFile :: FilePath -> T.Text -> IO () -- program file
-evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print
-
-fileToEvalForm :: FilePath -> T.Text -> Eval Expr
-fileToEvalForm filePath input = either (throw . ParseError . show) evalBody $ readExprFile filePath input
-
-runParseTest :: T.Text -> T.Text -- for view AST
-runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input
-
-getFileContents :: FilePath -> IO T.Text
-getFileContents fname = do
- exists <- doesFileExist fname
- if exists then TIO.readFile fname else return "File does not exist."
-
-textToEvalForm :: T.Text -> Eval Expr
-textToEvalForm input = either (throw . ParseError . show) evalBody $ readExpr input
-
-evalText :: T.Text -> IO () --REPL
-evalText textExpr = do
- res <- runASTinEnv basicEnv $ textToEvalForm textExpr
- print res
-
-getVar :: Expr -> Eval Expr
-getVar (Atom atom) = do
- Env {..} <- ask
- case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions
- Just x -> return x
- Nothing -> throw $ UnboundVar atom
-getVar n = throw $ TypeMismatch "failure to get variable: " n
-
-ensureAtom :: Expr -> Eval Expr
-ensureAtom n@(Atom _) = return n
-ensureAtom n@(List _) = throw $ TypeMismatch "got list" n
-ensureAtom n = throw $ TypeMismatch "expected an atomic value" n
-
-extractVar :: Expr -> T.Text
-extractVar (Atom atom) = atom
-extractVar n = throw $ TypeMismatch "expected an atomic value" n
-
-getEven :: [t] -> [t]
-getEven [] = []
-getEven (x : xs) = x : getOdd xs
-
-getOdd :: [t] -> [t]
-getOdd [] = []
-getOdd (_ : xs) = getEven xs
-
-applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr
-applyFunc expr params args = bindArgsEval params args expr
-
-bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr
-bindArgsEval params args expr = do
- Env {..} <- ask
- let newVars = zipWith (\a b -> (extractVar a, b)) params args
- let (newEnv, newFenv) = Map.partition (not . isFunc) $ Map.fromList newVars
- local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr
-
-isFunc :: Expr -> Bool
-isFunc (List ((Atom "lambda") : _)) = True
-isFunc _ = False
-
-eval :: Expr -> Eval Expr
-eval (List [Atom "dumpEnv", x]) = do
- Env {..} <- ask
- liftIO $ print $ toList env
- liftIO $ print $ toList fenv
- eval x
-eval (Numb i) = return $ Numb i
-eval (Tape s) = return $ Tape s
-eval (Bool b) = return $ Bool b
-eval (List []) = return Nil
-eval Nil = return Nil
-eval n@(Atom _) = getVar n
-eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest
-eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest
-eval (List [Atom "quote", val]) = return val
-eval (List [Atom "if", pred_, then_, else_]) = do
- ifRes <- eval pred_
- case ifRes of
- (Bool True) -> eval then_
- (Bool False) -> eval else_
- _ ->
- throw $ BadSpecialForm "if's first arg must eval into a boolean"
-eval (List ((:) (Atom "if") _)) =
- throw $ BadSpecialForm "(if <bool> <s-expr> <s-expr>)"
-eval (List [Atom "begin", rest]) = evalBody rest
-eval (List ((:) (Atom "begin") rest)) = evalBody $ List rest
--- top-level define
--- TODO: how to make this eval correctly?
-eval (List [Atom "define", List (name : args), body]) = do
- Env {..} <- ask
- _ <- eval body
- bindArgsEval (name : args) [body] name
-eval (List [Atom "define", name, body]) = do
- Env {..} <- ask
- _ <- eval body
- bindArgsEval [name] [body] name
-eval (List [Atom "let", List pairs, expr]) = do
- Env {..} <- ask
- atoms <- mapM ensureAtom $ getEven pairs
- vals <- mapM eval $ getOdd pairs
- bindArgsEval atoms vals expr
-eval (List (Atom "let" : _)) =
- throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let <pairs> <s-expr>)"
-eval (List [Atom "lambda", List params, expr]) = do
- ctx <- ask
- return $ Func (IFunc $ applyFunc expr params) ctx
-eval (List (Atom "lambda" : _)) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda <params> <s-expr>)"
--- needed to get cadr, etc to work
-eval (List [Atom "cdr", List [Atom "quote", List (_ : xs)]]) =
- return $ List xs
-eval (List [Atom "cdr", arg@(List (x : xs))]) =
- case x of
- -- proxy for if the list can be evaluated
- Atom _ -> do
- val <- eval arg
- eval $ List [Atom "cdr", val]
- _ -> return $ List xs
-eval (List [Atom "car", List [Atom "quote", List (x : _)]]) =
- return $ x
-eval (List [Atom "car", arg@(List (x : _))]) =
- case x of
- Atom _ -> do
- val <- eval arg
- eval $ List [Atom "car", val]
- _ -> return $ x
-eval (List ((:) x xs)) = do
- Env {..} <- ask
- funVar <- eval x
- xVal <- mapM eval xs
- case funVar of
- (IFun (IFunc internalFn)) ->
- internalFn xVal
- (Func (IFunc definedFn) (Env benv _)) ->
- local (const $ Env benv fenv) $ definedFn xVal
- _ ->
- throw $ NotFunction funVar
-
-updateEnv :: T.Text -> Expr -> Env -> Env
-updateEnv var e@(IFun _) Env {..} = Env env $ Map.insert var e fenv
-updateEnv var e@(Func _ _) Env {..} = Env env $ Map.insert var e fenv
-updateEnv var e Env {..} = Env (Map.insert var e env) fenv
-
-evalBody :: Expr -> Eval Expr
-evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do
- evalVal <- eval defExpr
- ctx <- ask
- local (const $ updateEnv var evalVal ctx) $ eval rest
-evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do
- evalVal <- eval defExpr
- ctx <- ask
- local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest
-evalBody x = eval x
diff --git a/Biz/Language/Bs/Expr.hs b/Biz/Language/Bs/Expr.hs
deleted file mode 100644
index 2452622..0000000
--- a/Biz/Language/Bs/Expr.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Bs.Expr where
-
-import Data.String (String)
-import Data.Text (Text)
-import qualified Data.Text as T
-import GHC.Show
-import Protolude hiding (show)
-import qualified Text.PrettyPrint.Leijen.Text as PP
-import Text.PrettyPrint.Leijen.Text hiding ((<$>))
-
-type Ctx = Map Text Expr
-
-data Env = Env {env :: Ctx, fenv :: Ctx}
- deriving (Eq)
-
-newtype Eval a = Eval {unEval :: ReaderT Env IO a}
- deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO)
-
-data IFunc = IFunc {fn :: [Expr] -> Eval Expr}
- deriving (Typeable)
-
-instance Eq IFunc where
- (==) _ _ = False
-
-data Expr
- = Atom Text
- | List [Expr]
- | Numb Integer
- | Tape Text
- | IFun IFunc -- TODO: call this Kern
- | Func IFunc Env
- | Bool Bool
- | Nil
- deriving (Typeable, Eq)
-
-instance Show Expr where
- show = T.unpack . ppexpr
-
-data LispErrorType
- = NumArgs Integer [Expr]
- | LengthOfList Text Int
- | ExpectedList Text
- | ParseError String
- | TypeMismatch Text Expr
- | BadSpecialForm Text
- | NotFunction Expr
- | UnboundVar Text
- | Default Expr
- | ReadFileError Text
- deriving (Typeable)
-
-data LispError = LispError Expr LispErrorType
-
-instance Show LispErrorType where
- show = T.unpack . ppexpr
-
-instance Show LispError where
- show = T.unpack . ppexpr
-
-instance Exception LispErrorType
-
-instance Exception LispError
-
-ppexpr :: Pretty a => a -> Text
-ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x))
-
---prettyList :: [Doc] -> Doc
---prettyList = encloseSep lparen rparen PP.space
-
-instance Pretty Expr where
- pretty v =
- case v of
- Atom a ->
- textStrict a
- List ls ->
- prettyList $ fmap pretty ls
- Numb n ->
- integer n
- Tape t ->
- textStrict "\"" <> textStrict t <> textStrict "\""
- IFun _ ->
- textStrict "<internal function>"
- Func _ _ ->
- textStrict "<lambda function>"
- Bool True ->
- textStrict "#t"
- Bool False ->
- textStrict "#f"
- Nil ->
- textStrict "'()"
-
-instance Pretty LispErrorType where
- pretty err = case err of
- NumArgs i args ->
- textStrict "number of arguments"
- <$$> textStrict "expected"
- <+> textStrict (T.pack $ show i)
- <$$> textStrict "received"
- <+> textStrict (T.pack $ show $ length args)
- LengthOfList txt i ->
- textStrict "length of list in:"
- <+> textStrict txt
- <$$> textStrict "length:"
- <+> textStrict (T.pack $ show i)
- ParseError txt ->
- textStrict "cannot parse expr:"
- <+> textStrict (T.pack txt)
- TypeMismatch txt expr ->
- textStrict "type mismatch:"
- <$$> textStrict txt
- <$$> pretty expr
- BadSpecialForm txt ->
- textStrict "bad special form:"
- <$$> textStrict txt
- NotFunction expr ->
- textStrict "not a function"
- <$$> pretty expr
- UnboundVar txt ->
- textStrict "unbound variable:"
- <$$> textStrict txt
- Default _ ->
- textStrict "default error"
- ReadFileError txt ->
- textStrict "error reading file:"
- <$$> textStrict txt
- ExpectedList txt ->
- textStrict "expected list:"
- <$$> textStrict txt
-
-instance Pretty LispError where
- pretty (LispError expr typ) =
- textStrict "error evaluating:"
- <$$> indent 4 (pretty expr)
- <$$> pretty typ
diff --git a/Biz/Language/Bs/Parser.hs b/Biz/Language/Bs/Parser.hs
deleted file mode 100644
index 574536d..0000000
--- a/Biz/Language/Bs/Parser.hs
+++ /dev/null
@@ -1,129 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Bs.Parser
- ( readExpr,
- readExprFile,
- )
-where
-
-import Control.Monad (fail)
-import Control.Monad (mzero)
-import Data.Char (digitToInt)
-import Data.Functor.Identity (Identity)
-import Data.String
-import qualified Data.Text as T
-import Language.Bs.Expr
-import Protolude hiding ((<|>), try)
-import Text.Parsec
-import qualified Text.Parsec.Language as Lang
-import Text.Parsec.Text
-import qualified Text.Parsec.Token as Tok
-
-lexer :: Tok.GenTokenParser T.Text () Identity
-lexer = Tok.makeTokenParser style
-
-style :: Tok.GenLanguageDef T.Text () Identity
-style =
- Lang.emptyDef
- { Tok.commentStart = "#|",
- Tok.commentEnd = "|#",
- Tok.commentLine = ";",
- Tok.opStart = mzero,
- Tok.opLetter = mzero,
- Tok.identStart = letter <|> oneOf "!$%&*/:<=>?^_~",
- Tok.identLetter = digit <|> letter <|> oneOf "!$%&*/:<=>?^_~+-.@"
- }
-
-parens :: Parser a -> Parser a
-parens = Tok.parens lexer
-
-whitespace :: Parser ()
-whitespace = Tok.whiteSpace lexer
-
-lexeme :: Parser a -> Parser a
-lexeme = Tok.lexeme lexer
-
-quoted :: Parser a -> Parser a
-quoted p = try (char '\'') *> p
-
-identifier :: Parser T.Text
-identifier = T.pack <$> (Tok.identifier lexer <|> specialIdentifier) <?> "identifier"
- where
- specialIdentifier :: Parser String
- specialIdentifier =
- lexeme $ try $
- string "-" <|> string "+" <|> string "..."
-
--- | The @Radix@ type consists of a base integer (e.g. @10@) and a parser for
--- digits in that base (e.g. @digit@).
-type Radix = (Integer, Parser Char)
-
--- | Parse an integer, given a radix as output by @radix@.
--- Copied from Text.Parsec.Token
-numberWithRadix :: Radix -> Parser Integer
-numberWithRadix (base, baseDigit) = do
- digits <- many1 baseDigit
- let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits
- seq n (return n)
-
-decimal :: Parser Integer
-decimal = Tok.decimal lexer
-
--- | Parse a sign, return either @id@ or @negate@ based on the sign parsed.
--- Copied from Text.Parsec.Token
-sign :: Parser (Integer -> Integer)
-sign =
- char '-' *> return negate
- <|> char '+' *> return identity
- <|> return identity
-
-intRadix :: Radix -> Parser Integer
-intRadix r = sign <*> numberWithRadix r
-
-textLiteral :: Parser T.Text
-textLiteral = T.pack <$> Tok.stringLiteral lexer
-
-nil :: Parser ()
-nil = try ((char '\'') *> string "()") *> return () <?> "nil"
-
-hashVal :: Parser Expr
-hashVal =
- lexeme $
- char '#'
- *> ( char 't' *> return (Bool True)
- <|> char 'f' *> return (Bool False)
- <|> char 'b' *> (Numb <$> intRadix (2, oneOf "01"))
- <|> char 'o' *> (Numb <$> intRadix (8, octDigit))
- <|> char 'd' *> (Numb <$> intRadix (10, digit))
- <|> char 'x' *> (Numb <$> intRadix (16, hexDigit))
- <|> oneOf "ei" *> fail "Unsupported: exactness"
- <|> char '(' *> fail "Unsupported: vector"
- <|> char '\\' *> fail "Unsupported: char"
- )
-
-lispVal :: Parser Expr
-lispVal =
- hashVal
- <|> Nil <$ nil
- <|> Numb <$> try (sign <*> decimal)
- <|> Atom <$> identifier
- <|> Tape <$> textLiteral
- <|> _Quote <$> quoted lispVal
- <|> List <$> parens manyExpr
-
-manyExpr :: Parser [Expr]
-manyExpr = lispVal `sepBy` whitespace
-
-_Quote :: Expr -> Expr
-_Quote x = List [Atom "quote", x]
-
-contents :: Parser a -> ParsecT T.Text () Identity a
-contents p = whitespace *> lexeme p <* eof
-
-readExpr :: T.Text -> Either ParseError Expr
-readExpr = parse (contents lispVal) "<stdin>"
-
-readExprFile :: SourceName -> T.Text -> Either ParseError Expr
-readExprFile = parse (contents (List <$> manyExpr))
diff --git a/Biz/Language/Bs/Primitives.hs b/Biz/Language/Bs/Primitives.hs
deleted file mode 100644
index 4c70499..0000000
--- a/Biz/Language/Bs/Primitives.hs
+++ /dev/null
@@ -1,188 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
--- | bs primitives
---
--- I would like to reduce the number of primitives in the language to some
--- minimal number, like SKI combinator or Nock instructions. I'm not sure what
--- the minimal number is. The idea is to move primitives from here into core.scm
--- over time.
-module Language.Bs.Primitives where
-
-import Control.Exception
-import Control.Monad.Except
-import Data.Text as T
-import Data.Text.IO as TIO
-import Language.Bs.Expr
-import Network.HTTP
-import Protolude
-import System.Directory
-import System.IO
-
-type Prim = [(T.Text, Expr)]
-
-type Unary = Expr -> Eval Expr
-
-type Binary = Expr -> Expr -> Eval Expr
-
-mkF :: ([Expr] -> Eval Expr) -> Expr
-mkF = IFun . IFunc
-
-primEnv :: Prim
-primEnv =
- [ ("+", mkF $ binopFold (numOp (+)) (Numb 0)),
- ("*", mkF $ binopFold (numOp (*)) (Numb 1)),
- ("string-append", mkF $ binopFold (strOp (<>)) (Tape "")),
- ("-", mkF $ binop $ numOp (-)),
- ("<", mkF $ binop $ numCmp (<)),
- ("<=", mkF $ binop $ numCmp (<=)),
- (">", mkF $ binop $ numCmp (>)),
- (">=", mkF $ binop $ numCmp (>=)),
- ("==", mkF $ binop $ numCmp (==)),
- ("even?", mkF $ unop $ numBool even),
- ("odd?", mkF $ unop $ numBool odd),
- ("neg?", mkF $ unop $ numBool (< 0)),
- ("pos?", mkF $ unop $ numBool (> 0)),
- ("eq?", mkF $ binop eqCmd),
- ("null?", mkF $ unop (eqCmd Nil)),
- ("bl-eq?", mkF $ binop $ eqOp (==)),
- ("and", mkF $ binopFold (eqOp (&&)) (Bool True)),
- ("or", mkF $ binopFold (eqOp (||)) (Bool False)),
- ("not", mkF $ unop $ notOp),
- ("cons", mkF $ Language.Bs.Primitives.cons),
- ("cdr", mkF $ Language.Bs.Primitives.cdr),
- ("car", mkF $ Language.Bs.Primitives.car),
- ("quote", mkF $ quote),
- ("file?", mkF $ unop fileExists),
- ("slurp", mkF $ unop slurp),
- ("wslurp", mkF $ unop wSlurp),
- ("put", mkF $ binop put_)
- ]
-
-unop :: Unary -> [Expr] -> Eval Expr
-unop op [x] = op x
-unop _ args = throw $ NumArgs 1 args
-
-binop :: Binary -> [Expr] -> Eval Expr
-binop op [x, y] = op x y
-binop _ args = throw $ NumArgs 2 args
-
-fileExists :: Expr -> Eval Expr
-fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt)
-fileExists val = throw $ TypeMismatch "read expects string, instead got: " val
-
-slurp :: Expr -> Eval Expr
-slurp (Tape txt) = liftIO $ wFileSlurp txt
-slurp val = throw $ TypeMismatch "read expects string, instead got: " val
-
-wFileSlurp :: T.Text -> IO Expr
-wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go
- where
- go = readTextFile fileName
-
-openURL :: T.Text -> IO Expr
-openURL x = do
- req <- simpleHTTP (getRequest $ T.unpack x)
- body <- getResponseBody req
- return $ Tape $ T.pack body
-
-wSlurp :: Expr -> Eval Expr
-wSlurp (Tape txt) = liftIO $ openURL txt
-wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val
-
-readTextFile :: T.Text -> Handle -> IO Expr
-readTextFile fileName h = do
- exists <- doesFileExist $ T.unpack fileName
- if exists
- then (TIO.hGetContents h) >>= (return . Tape)
- else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
-
-put_ :: Expr -> Expr -> Eval Expr
-put_ (Tape file) (Tape msg) = liftIO $ wFilePut file msg
-put_ (Tape _) val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val
-put_ val _ = throw $ TypeMismatch "put expects string, instead got: " val
-
-wFilePut :: T.Text -> T.Text -> IO Expr
-wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go
- where
- go = putTextFile fileName msg
-
-putTextFile :: T.Text -> T.Text -> Handle -> IO Expr
-putTextFile fileName msg h = do
- canWrite <- hIsWritable h
- if canWrite
- then (TIO.hPutStr h msg) >> (return $ Tape msg)
- else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
-
-binopFold :: Binary -> Expr -> [Expr] -> Eval Expr
-binopFold op farg args = case args of
- [] -> throw $ NumArgs 2 args
- [a, b] -> op a b
- _ -> foldM op farg args
-
-numBool :: (Integer -> Bool) -> Expr -> Eval Expr
-numBool op (Numb x) = return $ Bool $ op x
-numBool _ x = throw $ TypeMismatch "numeric op " x
-
-numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr
-numOp op (Numb x) (Numb y) = return $ Numb $ op x y
-numOp _ Nil (Numb y) = return $ Numb y
-numOp _ (Numb x) Nil = return $ Numb x
-numOp _ x (Numb _) = throw $ TypeMismatch "numeric op" x
-numOp _ (Numb _) y = throw $ TypeMismatch "numeric op" y
-numOp _ x _ = throw $ TypeMismatch "numeric op" x
-
-strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr
-strOp op (Tape x) (Tape y) = return $ Tape $ op x y
-strOp _ Nil (Tape y) = return $ Tape y
-strOp _ (Tape x) Nil = return $ Tape x
-strOp _ x (Tape _) = throw $ TypeMismatch "string op" x
-strOp _ (Tape _) y = throw $ TypeMismatch "string op" y
-strOp _ x _ = throw $ TypeMismatch "string op" x
-
-eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr
-eqOp op (Bool x) (Bool y) = return $ Bool $ op x y
-eqOp _ x (Bool _) = throw $ TypeMismatch "bool op" x
-eqOp _ (Bool _) y = throw $ TypeMismatch "bool op" y
-eqOp _ x _ = throw $ TypeMismatch "bool op" x
-
-numCmp :: (Integer -> Integer -> Bool) -> Expr -> Expr -> Eval Expr
-numCmp op (Numb x) (Numb y) = return . Bool $ op x y
-numCmp _ x (Numb _) = throw $ TypeMismatch "numeric op" x
-numCmp _ (Numb _) y = throw $ TypeMismatch "numeric op" y
-numCmp _ x _ = throw $ TypeMismatch "numeric op" x
-
-notOp :: Expr -> Eval Expr
-notOp (Bool True) = return $ Bool False
-notOp (Bool False) = return $ Bool True
-notOp x = throw $ TypeMismatch " not expects Bool" x
-
-eqCmd :: Expr -> Expr -> Eval Expr
-eqCmd (Atom x) (Atom y) = return . Bool $ x == y
-eqCmd (Numb x) (Numb y) = return . Bool $ x == y
-eqCmd (Tape x) (Tape y) = return . Bool $ x == y
-eqCmd (Bool x) (Bool y) = return . Bool $ x == y
-eqCmd Nil Nil = return $ Bool True
-eqCmd _ _ = return $ Bool False
-
-cons :: [Expr] -> Eval Expr
-cons [x, (List ys)] = return $ List $ x : ys
-cons [x, y] = return $ List [x, y]
-cons _ = throw $ ExpectedList "cons, in second argument"
-
-car :: [Expr] -> Eval Expr
-car [List []] = return Nil
-car [List (x : _)] = return x
-car [] = return Nil
-car _ = throw $ ExpectedList "car"
-
-cdr :: [Expr] -> Eval Expr
-cdr [List (_ : xs)] = return $ List xs
-cdr [List []] = return Nil
-cdr [] = return Nil
-cdr _ = throw $ ExpectedList "cdr"
-
-quote :: [Expr] -> Eval Expr
-quote [List xs] = return $ List $ Atom "quote" : xs
-quote [expr] = return $ List $ Atom "quote" : [expr]
-quote args = throw $ NumArgs 1 args
diff --git a/Biz/Language/Bs/Repl.hs b/Biz/Language/Bs/Repl.hs
deleted file mode 100644
index 24f1bcd..0000000
--- a/Biz/Language/Bs/Repl.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Bs.Repl
- ( mainLoop,
- )
-where
-
-import Control.Monad.Trans
-import Data.String
-import Data.Text as T
-import Language.Bs.Eval
-import Protolude
-import System.Console.Haskeline
-
-type Repl a = InputT IO a
-
-mainLoop :: IO ()
-mainLoop = runInputT defaultSettings repl
-
-repl :: Repl ()
-repl = do
- minput <- getInputLine "bs> "
- case minput of
- Nothing -> outputStrLn "bye."
- Just input -> (liftIO $ process input) >> repl
-
---Just input -> (liftIO $ processToAST input) >> repl
-
-process :: String -> IO ()
-process str = do
- res <- safeExec $ evalText $ T.pack str
- either putStrLn return res
-
-processToAST :: String -> IO ()
-processToAST str = print $ runParseTest $ T.pack str
diff --git a/Biz/Language/Bs/Test.hs b/Biz/Language/Bs/Test.hs
deleted file mode 100644
index 4a40036..0000000
--- a/Biz/Language/Bs/Test.hs
+++ /dev/null
@@ -1,2 +0,0 @@
--- TODO
-module Language.Bs.Test where
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 12:25:42 +0000