Add semi-working bs

1 files changed, 175 insertions, 0 deletions

diff --git a/lore/Language/Bs/Primitives.hs b/lore/Language/Bs/Primitives.hs
new file mode 100644
index 0000000..a2de7bb
--- /dev/null
+++ b/lore/Language/Bs/Primitives.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Bs.Primitives where
+
+import Control.Exception hiding (handle)
+import Control.Monad.Except
+import Data.Text as T
+import Data.Text.IO as TIO
+import Language.Bs.Expr
+import Network.HTTP
+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 handle = do
+  exists <- doesFileExist $ T.unpack fileName
+  if exists
+  then (TIO.hGetContents handle) >>= (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 handle = do
+  canWrite <- hIsWritable handle
+  if canWrite
+  then (TIO.hPutStr handle 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