diff options
Diffstat (limited to 'Biz/Language/Bs/Primitives.hs')
| -rw-r--r-- | Biz/Language/Bs/Primitives.hs | 179 |
1 files changed, 92 insertions, 87 deletions
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 |