Re-namespacing

Moving away from the DNS-driven namespacing toward more condensed names,
mostly because I don't like typing so much.

1 files changed, 0 insertions, 183 deletions

diff --git a/Com/Simatime/Language/Bs/Primitives.hs b/Com/Simatime/Language/Bs/Primitives.hs
deleted file mode 100644
index c074c59..0000000
--- a/Com/Simatime/Language/Bs/Primitives.hs
+++ /dev/null
@@ -1,183 +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