{-# LANGUAGE CPP #-}
{-# Language ExistentialQuantification #-}

{- |
Module      : Language.Scheme.Primitives
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

Maintainer  : github.com/justinethier
Stability   : experimental
Portability : portable

This module contains primitive functions written in Haskell.
Most of these map directly to an equivalent Scheme function.

-}

module Language.Scheme.Primitives (
 -- * Pure functions
 -- ** List
   car
 , cdr 
 , cons
 , eq
 , equal 
 , makeList
 , listCopy
 -- ** Vector
 , buildVector 
 , vectorLength 
 , vectorRef 
 , vectorCopy
 , vectorToList 
 , listToVector
 , makeVector
 -- ** Bytevectors
 , makeByteVector
 , byteVector
 , byteVectorLength
 , byteVectorRef
 , byteVectorCopy
 , byteVectorAppend
 , byteVectorUtf2Str
 , byteVectorStr2Utf
 -- ** Hash Table
 , hashTblExists 
 , hashTblSize 
 , hashTbl2List
 , hashTblKeys
 , hashTblValues 
 , hashTblCopy
 , hashTblMake
 , wrapHashTbl
 , wrapLeadObj
 -- ** String
 , buildString
 , makeString
 , doMakeString
 , stringLength
 , stringRef
 , substring
 , stringCIEquals 
 , stringCIBoolBinop 
 , stringAppend 
 , stringToNumber
 , stringToList 
 , listToString
 , stringToVector
 , vectorToString
 , stringCopy 
 , symbol2String 
 , string2Symbol

 -- ** Character
 , charCIBoolBinop 
 , charPredicate
 , charUpper
 , charLower
 , charDigitValue
 , char2Int
 , int2Char

 -- ** Predicate
 , isHashTbl
 , isChar 
 , isString 
 , isBoolean 
 , isBooleanEq
 , isSymbolEq
 , isDottedList 
 , isProcedure 
 , isList 
 , isVector 
 , isRecord
 , isByteVector
 , isNull 
 , isEOFObject 
 , isSymbol 

 -- ** Utility functions
 , Unpacker ()
 , unpackEquals 
 , boolBinop 
 , unaryOp 
 , unaryOp'
 , strBoolBinop 
 , charBoolBinop 
 , boolBoolBinop
 , unpackStr 
 , unpackBool
 -- * Impure functions
 -- |All of these functions must be executed within the IO monad.
 
 -- ** Input / Output 
 , makePort 
 , makeBufferPort
 , openInputString
 , openOutputString
 , getOutputString
 , openInputByteVector
 , openOutputByteVector
 , getOutputByteVector
 , closePort
 , flushOutputPort
 , currentOutputPort 
 , currentInputPort 
 , isTextPort
 , isBinaryPort
 , isOutputPort 
 , isInputPort
 , isInputPortOpen
 , isOutputPortOpen
 , isCharReady
 , readProc 
 , readCharProc 
 , readByteVector
 , readString
 , writeProc 
 , writeCharProc
 , writeByteVector
 , writeString
 , readContents
 , load
 , readAll
 , fileExists
 , deleteFile
 , eofObject 
 -- ** Symbol generation
 , gensym
 , _gensym
 -- ** Time
 , currentTimestamp
 -- ** System
 , system
 , getEnvVars
-- , systemRead

 ) where
import Language.Scheme.Numerical
import Language.Scheme.Parser
import Language.Scheme.Types
import Language.Scheme.Variables
--import qualified Control.Exception
import Control.Monad.Except
import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as BSU
import Data.Char hiding (isSymbol)
import Data.Array
import qualified Data.Knob as DK
--import qualified Data.List as DL
import qualified Data.Map
import qualified Data.Time.Clock.POSIX
import Data.Unique
import Data.Word
import System.Directory (doesFileExist, removeFile)
import qualified System.Environment as SE
import System.Exit (ExitCode(..))
import System.IO
import System.IO.Error
import qualified System.Process
--import System.Process (readProcess)
--import Debug.Trace

#if __GLASGOW_HASKELL__ < 702
try' = try
#else
try' :: IO a -> IO (Either IOError a)
try' :: IO a -> IO (Either IOError a)
try' = IO a -> IO (Either IOError a)
forall a. IO a -> IO (Either IOError a)
tryIOError
#endif

---------------------------------------------------
-- I/O Primitives
-- These primitives all execute within the IO monad
---------------------------------------------------

-- |Open the given file
--
--   LispVal Arguments:
--
--   * String - filename
--
--   Returns: Port
--
makePort
    :: (FilePath -> IOMode -> IO Handle)
    -> IOMode
    -> [LispVal]
    -> IOThrowsError LispVal
makePort :: (FilePath -> IOMode -> IO Handle)
-> IOMode -> [LispVal] -> IOThrowsError LispVal
makePort FilePath -> IOMode -> IO Handle
openFnc IOMode
mode [String FilePath
filename] = do
    Handle
h <- IO Handle -> ExceptT LispError IO Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> ExceptT LispError IO Handle)
-> IO Handle -> ExceptT LispError IO Handle
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openFnc FilePath
filename IOMode
mode
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Handle -> Maybe Knob -> LispVal
Port Handle
h Maybe Knob
forall a. Maybe a
Nothing
makePort FilePath -> IOMode -> IO Handle
fnc IOMode
mode [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IOMode -> IO Handle)
-> IOMode -> [LispVal] -> IOThrowsError LispVal
makePort FilePath -> IOMode -> IO Handle
fnc IOMode
mode
makePort FilePath -> IOMode -> IO Handle
_ IOMode
_ [] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
makePort FilePath -> IOMode -> IO Handle
_ IOMode
_ args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Create an memory-backed port
makeBufferPort :: Maybe LispVal -> IOThrowsError LispVal
makeBufferPort :: Maybe LispVal -> IOThrowsError LispVal
makeBufferPort Maybe LispVal
buf = do
    let mode :: IOMode
mode = case Maybe LispVal
buf of
                 Maybe LispVal
Nothing -> IOMode
WriteMode
                 Maybe LispVal
_ -> IOMode
ReadMode
    ByteString
bs <- case Maybe LispVal
buf of
--        Just (p@(Pointer {})] = recDerefPtrs p >>= box >>= openInputString
        Just (String FilePath
s)-> ByteString -> ExceptT LispError IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ExceptT LispError IO ByteString)
-> ByteString -> ExceptT LispError IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
BSU.fromString FilePath
s
        Just (ByteVector ByteString
bv)-> ByteString -> ExceptT LispError IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bv
        Just LispVal
err -> LispError -> ExceptT LispError IO ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ExceptT LispError IO ByteString)
-> LispError -> ExceptT LispError IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string or bytevector" LispVal
err
        Maybe LispVal
Nothing -> ByteString -> ExceptT LispError IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ExceptT LispError IO ByteString)
-> ByteString -> ExceptT LispError IO ByteString
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack []
    Knob
k <- ByteString -> ExceptT LispError IO Knob
forall (m :: * -> *). MonadIO m => ByteString -> m Knob
DK.newKnob ByteString
bs
    Handle
h <- IO Handle -> ExceptT LispError IO Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> ExceptT LispError IO Handle)
-> IO Handle -> ExceptT LispError IO Handle
forall a b. (a -> b) -> a -> b
$ Knob -> FilePath -> IOMode -> IO Handle
forall (m :: * -> *).
MonadIO m =>
Knob -> FilePath -> IOMode -> m Handle
DK.newFileHandle Knob
k FilePath
"temp.buf" IOMode
mode
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Handle -> Maybe Knob -> LispVal
Port Handle
h (Knob -> Maybe Knob
forall a. a -> Maybe a
Just Knob
k)

-- |Read byte buffer from a given port
getBufferFromPort :: LispVal -> IOThrowsError BSU.ByteString
getBufferFromPort :: LispVal -> ExceptT LispError IO ByteString
getBufferFromPort (Port Handle
h (Just Knob
k)) = do
    ()
_ <- IO () -> ExceptT LispError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT LispError IO ())
-> IO () -> ExceptT LispError IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
h
    Knob -> ExceptT LispError IO ByteString
forall (m :: * -> *). MonadIO m => Knob -> m ByteString
DK.getContents Knob
k
getBufferFromPort LispVal
args = do
    LispError -> ExceptT LispError IO ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ExceptT LispError IO ByteString)
-> LispError -> ExceptT LispError IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"output-port" LispVal
args

-- |Create a new input string buffer
openInputString :: [LispVal] -> IOThrowsError LispVal
openInputString :: [LispVal] -> IOThrowsError LispVal
openInputString [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
openInputString
openInputString [buf :: LispVal
buf@(String FilePath
_)] = Maybe LispVal -> IOThrowsError LispVal
makeBufferPort (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
buf)
openInputString [LispVal]
args = if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"(string)" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args
    else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Create a new output string buffer
openOutputString :: [LispVal] -> IOThrowsError LispVal
openOutputString :: [LispVal] -> IOThrowsError LispVal
openOutputString [LispVal]
_ = Maybe LispVal -> IOThrowsError LispVal
makeBufferPort Maybe LispVal
forall a. Maybe a
Nothing

-- |Create a new input bytevector buffer
openInputByteVector :: [LispVal] -> IOThrowsError LispVal
openInputByteVector :: [LispVal] -> IOThrowsError LispVal
openInputByteVector [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
openInputByteVector
openInputByteVector [buf :: LispVal
buf@(ByteVector ByteString
_)] = Maybe LispVal -> IOThrowsError LispVal
makeBufferPort (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
buf)
openInputByteVector [LispVal]
args = if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"(bytevector)" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args
    else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Create a new output bytevector buffer
openOutputByteVector :: [LispVal] -> IOThrowsError LispVal
openOutputByteVector :: [LispVal] -> IOThrowsError LispVal
openOutputByteVector [LispVal]
_ = Maybe LispVal -> IOThrowsError LispVal
makeBufferPort Maybe LispVal
forall a. Maybe a
Nothing


-- |Get string written to string-output-port
getOutputString :: [LispVal] -> IOThrowsError LispVal
getOutputString :: [LispVal] -> IOThrowsError LispVal
getOutputString [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
getOutputString
getOutputString [p :: LispVal
p@(Port Handle
port Maybe Knob
_)] = do
    Bool
o <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsOpen Handle
port
    if Bool
o then do 
            ByteString
bytes <- LispVal -> ExceptT LispError IO ByteString
getBufferFromPort LispVal
p
            LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
BSU.toString ByteString
bytes 
         else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String FilePath
""
getOutputString [LispVal]
args = do
    LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"output-port" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args

-- |Get bytevector written to bytevector-output-port
getOutputByteVector :: [LispVal] -> IOThrowsError LispVal
getOutputByteVector :: [LispVal] -> IOThrowsError LispVal
getOutputByteVector [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
getOutputByteVector
getOutputByteVector [p :: LispVal
p@(Port Handle
port Maybe Knob
_)] = do
    Bool
o <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsOpen Handle
port
    if Bool
o then do ByteString
bytes <- LispVal -> ExceptT LispError IO ByteString
getBufferFromPort LispVal
p
                 LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector ByteString
bytes 
         else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack []
getOutputByteVector [LispVal]
args = do
    LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"output-port" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args

-- |Close the given port
--
--   Arguments:
--
--   * Port
--
--   Returns: Bool - True if the port was closed, false otherwise
--
closePort :: [LispVal] -> IOThrowsError LispVal
closePort :: [LispVal] -> IOThrowsError LispVal
closePort [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
closePort
closePort [Port Handle
port Maybe Knob
_] = IO LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LispVal -> IOThrowsError LispVal)
-> IO LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
port IO () -> IO LispVal -> IO LispVal
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (LispVal -> IO LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IO LispVal) -> LispVal -> IO LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True)
closePort [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False


{- FUTURE: For now, these are just hardcoded to the standard i/o ports.
a future implementation that includes with-*put-from-file
would require a more involved implementation here as well as
other I/O functions hooking into these instead of std* -}

-- |Return the current input port
--
--   LispVal Arguments: (None)
--
--   Returns: Port
--
currentInputPort :: [LispVal] -> IOThrowsError LispVal
currentInputPort :: [LispVal] -> IOThrowsError LispVal
currentInputPort [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Handle -> Maybe Knob -> LispVal
Port Handle
stdin Maybe Knob
forall a. Maybe a
Nothing
-- |Return the current input port
--
--   LispVal Arguments: (None)
--
--   Returns: Port
--
currentOutputPort :: [LispVal] -> IOThrowsError LispVal
currentOutputPort :: [LispVal] -> IOThrowsError LispVal
currentOutputPort [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Handle -> Maybe Knob -> LispVal
Port Handle
stdout Maybe Knob
forall a. Maybe a
Nothing

-- | Flush the given output port
flushOutputPort :: [LispVal] -> IOThrowsError LispVal
flushOutputPort :: [LispVal] -> IOThrowsError LispVal
flushOutputPort [] = IO LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LispVal -> IOThrowsError LispVal)
-> IO LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
stdout IO () -> IO LispVal -> IO LispVal
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (LispVal -> IO LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IO LispVal) -> LispVal -> IO LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True)
flushOutputPort [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
flushOutputPort
flushOutputPort [p :: LispVal
p@(Port Handle
_ Maybe Knob
_)] = 
    LispVal
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
withOpenPort LispVal
p ((Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal)
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ \Handle
port -> IO LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LispVal -> IOThrowsError LispVal)
-> IO LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
port IO () -> IO LispVal -> IO LispVal
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (LispVal -> IO LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IO LispVal) -> LispVal -> IO LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True)
flushOutputPort [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if the given port is a text port.
--
--   Arguments
--
--   * Port
--
--   Returns: Bool
isTextPort :: [LispVal] -> IOThrowsError LispVal
isTextPort :: [LispVal] -> IOThrowsError LispVal
isTextPort [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isTextPort
isTextPort [Port Handle
port Maybe Knob
_] = do
    Bool
val <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
isTextPort' Handle
port
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
val
isTextPort [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if the given port is a binary port.
--
--   Arguments
--
--   * Port
--
--   Returns: Bool
isBinaryPort :: [LispVal] -> IOThrowsError LispVal
isBinaryPort :: [LispVal] -> IOThrowsError LispVal
isBinaryPort [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isBinaryPort
isBinaryPort [Port Handle
port Maybe Knob
_] = do
    Bool
val <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
isTextPort' Handle
port
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
val
isBinaryPort [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if a file handle is in text mode
isTextPort' :: Handle -> IO Bool
isTextPort' :: Handle -> IO Bool
isTextPort' Handle
port = do
    Maybe TextEncoding
textEncoding <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
port
    case Maybe TextEncoding
textEncoding of
        Maybe TextEncoding
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Maybe TextEncoding
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Determine if the given port is open
--
--   Arguments
--
--   * Port
--
--   Returns: Bool
isInputPortOpen :: [LispVal] -> IOThrowsError LispVal
isInputPortOpen :: [LispVal] -> IOThrowsError LispVal
isInputPortOpen [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isInputPortOpen
isInputPortOpen [p :: LispVal
p@(Port Handle
_ Maybe Knob
_)] = do
  LispVal
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
withOpenPort LispVal
p ((Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal)
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ \Handle
port -> do
    Bool
r <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsReadable Handle
port
    Bool
o <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsOpen Handle
port
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Bool
r Bool -> Bool -> Bool
&& Bool
o
isInputPortOpen [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Helper function to ensure a port is open, to prevent Haskell errors
withOpenPort :: LispVal -> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
withOpenPort :: LispVal
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
withOpenPort p :: LispVal
p@(Pointer {}) Handle -> IOThrowsError LispVal
proc = do
    LispVal
obj <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p 
    LispVal
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
withOpenPort LispVal
obj Handle -> IOThrowsError LispVal
proc
withOpenPort (Port Handle
port Maybe Knob
_) Handle -> IOThrowsError LispVal
proc = do
    Bool
o <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsOpen Handle
port
    if Bool
o then Handle -> IOThrowsError LispVal
proc Handle
port
         else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
withOpenPort LispVal
_ Handle -> IOThrowsError LispVal
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if the given port is open
--
--   Arguments
--
--   * Port
--
--   Returns: Bool
isOutputPortOpen :: [LispVal] -> IOThrowsError LispVal
isOutputPortOpen :: [LispVal] -> IOThrowsError LispVal
isOutputPortOpen [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isOutputPortOpen
isOutputPortOpen [p :: LispVal
p@(Port Handle
_ Maybe Knob
_)] = do
  LispVal
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
withOpenPort LispVal
p ((Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal)
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ \Handle
port -> do
    Bool
w <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsWritable Handle
port
    Bool
o <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsOpen Handle
port
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Bool
w Bool -> Bool -> Bool
&& Bool
o
isOutputPortOpen [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- |Determine if the given objects is an input port
--
--   LispVal Arguments:
--
--   * Port
--
--   Returns: Bool - True if an input port, false otherwise
--
isInputPort :: [LispVal] -> IOThrowsError LispVal
isInputPort :: [LispVal] -> IOThrowsError LispVal
isInputPort [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isInputPort
isInputPort [p :: LispVal
p@(Port Handle
_ Maybe Knob
_)] = 
  LispVal
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
withOpenPort LispVal
p ((Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal)
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ \Handle
port -> (Bool -> LispVal)
-> ExceptT LispError IO Bool -> IOThrowsError LispVal
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> LispVal
Bool (ExceptT LispError IO Bool -> IOThrowsError LispVal)
-> ExceptT LispError IO Bool -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsReadable Handle
port
isInputPort [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- |Determine if the given objects is an output port
--
--   LispVal Arguments:
--
--   * Port
--
--   Returns: Bool - True if an output port, false otherwise
--
isOutputPort :: [LispVal] -> IOThrowsError LispVal
isOutputPort :: [LispVal] -> IOThrowsError LispVal
isOutputPort [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isOutputPort
isOutputPort [p :: LispVal
p@(Port Handle
_ Maybe Knob
_)] = 
    LispVal
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
withOpenPort LispVal
p ((Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal)
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ \Handle
port -> (Bool -> LispVal)
-> ExceptT LispError IO Bool -> IOThrowsError LispVal
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> LispVal
Bool (ExceptT LispError IO Bool -> IOThrowsError LispVal)
-> ExceptT LispError IO Bool -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsWritable Handle
port
isOutputPort [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- |Determine if a character is ready on the port
--
--   LispVal Arguments:
--
--   * Port
--
--   Returns: Bool
--
isCharReady :: [LispVal] -> IOThrowsError LispVal
isCharReady :: [LispVal] -> IOThrowsError LispVal
isCharReady [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isCharReady
isCharReady [Port Handle
port Maybe Knob
_] = do --liftM Bool $ liftIO $ hReady port
    Either IOError Bool
result <- IO (Either IOError Bool)
-> ExceptT LispError IO (Either IOError Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError Bool)
 -> ExceptT LispError IO (Either IOError Bool))
-> IO (Either IOError Bool)
-> ExceptT LispError IO (Either IOError Bool)
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO (Either IOError Bool)
forall a. IO a -> IO (Either IOError a)
try' (IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hReady Handle
port)
    case Either IOError Bool
result of
        Left IOError
e -> if IOError -> Bool
isEOFError IOError
e
                     then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
                     else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default FilePath
"I/O error reading from port" -- FUTURE: ioError e
        Right Bool
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isCharReady [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- |Read from the given port
--
--   LispVal Arguments:
--
--   * Port
--
--   Returns: LispVal
--
readProc :: Bool -> [LispVal] -> IOThrowsError LispVal
readProc :: Bool -> [LispVal] -> IOThrowsError LispVal
readProc Bool
mode [] = Bool -> [LispVal] -> IOThrowsError LispVal
readProc Bool
mode [Handle -> Maybe Knob -> LispVal
Port Handle
stdin Maybe Knob
forall a. Maybe a
Nothing]
readProc Bool
mode [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> [LispVal] -> IOThrowsError LispVal
readProc Bool
mode
readProc Bool
mode [Port Handle
port Maybe Knob
_] = do
    Either IOError FilePath
input <- IO (Either IOError FilePath)
-> ExceptT LispError IO (Either IOError FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError FilePath)
 -> ExceptT LispError IO (Either IOError FilePath))
-> IO (Either IOError FilePath)
-> ExceptT LispError IO (Either IOError FilePath)
forall a b. (a -> b) -> a -> b
$ IO FilePath -> IO (Either IOError FilePath)
forall a. IO a -> IO (Either IOError a)
try' (IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Handle -> IO FilePath
hGetLine Handle
port)
    case Either IOError FilePath
input of
        Left IOError
e -> if IOError -> Bool
isEOFError IOError
e
                     then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal
EOF
                     else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default FilePath
"I/O error reading from port" -- FUTURE: ioError e
        Right FilePath
inpStr -> do
            ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
                case Bool
mode of
                    Bool
True -> FilePath -> ThrowsError LispVal
readExpr FilePath
inpStr
                    Bool
_ -> LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String FilePath
inpStr
readProc Bool
_ [LispVal]
args = if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                     then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"port" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args
                     else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Read character from port
--
--   LispVal Arguments:
--
--   * Port
--
--   Returns: Char
--
readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal
readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal
readCharProc Handle -> IO Char
func [p :: LispVal
p@(Pointer {})] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal
readCharProc Handle -> IO Char
func
readCharProc Handle -> IO Char
func [] = (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal
readCharProc Handle -> IO Char
func [Handle -> Maybe Knob -> LispVal
Port Handle
stdin Maybe Knob
forall a. Maybe a
Nothing]
readCharProc Handle -> IO Char
func [p :: LispVal
p@(Port Handle
_ Maybe Knob
_)] = do
  LispVal
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
withOpenPort LispVal
p ((Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal)
-> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ \Handle
port -> do
    IO () -> ExceptT LispError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT LispError IO ())
-> IO () -> ExceptT LispError IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
port BufferMode
NoBuffering
    Either IOError Char
input <- IO (Either IOError Char)
-> ExceptT LispError IO (Either IOError Char)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError Char)
 -> ExceptT LispError IO (Either IOError Char))
-> IO (Either IOError Char)
-> ExceptT LispError IO (Either IOError Char)
forall a b. (a -> b) -> a -> b
$ IO Char -> IO (Either IOError Char)
forall a. IO a -> IO (Either IOError a)
try' (IO Char -> IO Char
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Char -> IO Char) -> IO Char -> IO Char
forall a b. (a -> b) -> a -> b
$ Handle -> IO Char
func Handle
port)
    IO () -> ExceptT LispError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT LispError IO ())
-> IO () -> ExceptT LispError IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
port BufferMode
LineBuffering
    case Either IOError Char
input of
        Left IOError
e -> if IOError -> Bool
isEOFError IOError
e
                     then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal
EOF
                     else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default FilePath
"I/O error reading from port"
        Right Char
inpChr -> do
            LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
inpChr
readCharProc Handle -> IO Char
_ [LispVal]
args = if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                         then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"port" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args
                         else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- | Read a byte vector from the given port
--
--   Arguments
--
--   * Number - Number of bytes to read
--   * Port - Port to read from
--
--   Returns: ByteVector
readByteVector :: [LispVal] -> IOThrowsError LispVal
readByteVector :: [LispVal] -> IOThrowsError LispVal
readByteVector [LispVal]
args = [LispVal] -> (ByteString -> LispVal) -> IOThrowsError LispVal
readBuffer [LispVal]
args ByteString -> LispVal
ByteVector

-- | Read a string from the given port
--
--   Arguments
--
--   * Number - Number of bytes to read
--   * Port - Port to read from
--
--   Returns: String
readString :: [LispVal] -> IOThrowsError LispVal
readString :: [LispVal] -> IOThrowsError LispVal
readString [LispVal]
args = [LispVal] -> (ByteString -> LispVal) -> IOThrowsError LispVal
readBuffer [LispVal]
args (FilePath -> LispVal
String (FilePath -> LispVal)
-> (ByteString -> FilePath) -> ByteString -> LispVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BSU.toString)

-- |Helper function to read n bytes from a port into a buffer
readBuffer :: [LispVal] -> (BSU.ByteString -> LispVal) -> IOThrowsError LispVal
readBuffer :: [LispVal] -> (ByteString -> LispVal) -> IOThrowsError LispVal
readBuffer [Number Integer
n, Port Handle
port Maybe Knob
_] ByteString -> LispVal
rvfnc = do
    Either IOError ByteString
input <- IO (Either IOError ByteString)
-> ExceptT LispError IO (Either IOError ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError ByteString)
 -> ExceptT LispError IO (Either IOError ByteString))
-> IO (Either IOError ByteString)
-> ExceptT LispError IO (Either IOError ByteString)
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO (Either IOError ByteString)
forall a. IO a -> IO (Either IOError a)
try' (IO ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
BS.hGet Handle
port (Int -> IO ByteString) -> Int -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
    case Either IOError ByteString
input of
        Left IOError
e -> if IOError -> Bool
isEOFError IOError
e
                     then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal
EOF
                     else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default FilePath
"I/O error reading from port"
        Right ByteString
inBytes -> do
            if ByteString -> Bool
BS.null ByteString
inBytes
               then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal
EOF
               else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
rvfnc ByteString
inBytes
readBuffer [LispVal]
args ByteString -> LispVal
_ = if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
                       then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"(k port)" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args
                       else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args

-- |Write to the given port
--
--   LispVal Arguments:
--
--   * LispVal
--
--   * Port (optional)
--
--   Returns: (None)
--
{- writeProc :: --forall a (m :: * -> *).
             (MonadIO m, MonadError LispError m) =>
             (Handle -> LispVal -> IO a) -> [LispVal] -> m LispVal -}
writeProc :: (Handle -> LispVal -> IO a)
          -> [LispVal] -> ExceptT LispError IO LispVal
writeProc :: (Handle -> LispVal -> IO a) -> [LispVal] -> IOThrowsError LispVal
writeProc Handle -> LispVal -> IO a
func [LispVal
obj] = do
    LispVal
dobj <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
obj -- Last opportunity to do this before writing
    (Handle -> LispVal -> IO a) -> [LispVal] -> IOThrowsError LispVal
forall a.
(Handle -> LispVal -> IO a) -> [LispVal] -> IOThrowsError LispVal
writeProc Handle -> LispVal -> IO a
func [LispVal
dobj, Handle -> Maybe Knob -> LispVal
Port Handle
stdout Maybe Knob
forall a. Maybe a
Nothing]
writeProc Handle -> LispVal -> IO a
func [LispVal
obj, Port Handle
port Maybe Knob
_] = do
    LispVal
dobj <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
obj -- Last opportunity to do this before writing
    Either IOError a
output <- IO (Either IOError a) -> ExceptT LispError IO (Either IOError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError a) -> ExceptT LispError IO (Either IOError a))
-> IO (Either IOError a) -> ExceptT LispError IO (Either IOError a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either IOError a)
forall a. IO a -> IO (Either IOError a)
try' (IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Handle -> LispVal -> IO a
func Handle
port LispVal
dobj)
    case Either IOError a
output of
        Left IOError
_ -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default FilePath
"I/O error writing to port"
        Right a
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
Nil FilePath
""
writeProc Handle -> LispVal -> IO a
_ [LispVal]
other = if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
other Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
                     then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"(value port)" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
other
                     else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
other

-- |Write character to the given port
--
--   Arguments:
--
--   * Char - Value to write
--
--   * Port (optional) - Port to write to, defaults to standard output
--
--   Returns: (None)
--
writeCharProc :: [LispVal] -> IOThrowsError LispVal
writeCharProc :: [LispVal] -> IOThrowsError LispVal
writeCharProc [LispVal
obj] = [LispVal] -> IOThrowsError LispVal
writeCharProc [LispVal
obj, Handle -> Maybe Knob -> LispVal
Port Handle
stdout Maybe Knob
forall a. Maybe a
Nothing]
writeCharProc [obj :: LispVal
obj@(Char Char
_), Port Handle
port Maybe Knob
_] = do
    Either IOError ()
output <- IO (Either IOError ()) -> ExceptT LispError IO (Either IOError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError ())
 -> ExceptT LispError IO (Either IOError ()))
-> IO (Either IOError ())
-> ExceptT LispError IO (Either IOError ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOError ())
forall a. IO a -> IO (Either IOError a)
try' (IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Handle -> FilePath -> IO ()
hPutStr Handle
port (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ LispVal -> FilePath
forall a. Show a => a -> FilePath
show LispVal
obj))
    case Either IOError ()
output of
        Left IOError
_ -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default FilePath
"I/O error writing to port"
        Right ()
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
Nil FilePath
""
writeCharProc [LispVal]
other = if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
other Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
                     then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"(character port)" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
other
                     else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
other

-- | Write a byte vector to the given port
--
--   Arguments
--
--   * ByteVector
--   * Port
--
--   Returns: (unspecified)
writeByteVector :: [LispVal] -> IOThrowsError LispVal
writeByteVector :: [LispVal] -> IOThrowsError LispVal
writeByteVector [LispVal]
args = [LispVal]
-> (LispVal -> ExceptT LispError IO ByteString)
-> IOThrowsError LispVal
writeBuffer [LispVal]
args LispVal -> ExceptT LispError IO ByteString
bv2b
  where
    bv2b :: LispVal -> ExceptT LispError IO ByteString
bv2b LispVal
obj = do
        ByteVector ByteString
bs <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
obj -- Last opportunity to do this before writing
        ByteString -> ExceptT LispError IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

-- | Write a string to the given port
--
--   Arguments
--
--   * String
--   * Port
--
--   Returns: (unspecified)
writeString :: [LispVal] -> IOThrowsError LispVal
writeString :: [LispVal] -> IOThrowsError LispVal
writeString [LispVal]
args = [LispVal]
-> (LispVal -> ExceptT LispError IO ByteString)
-> IOThrowsError LispVal
writeBuffer [LispVal]
args LispVal -> ExceptT LispError IO ByteString
str2b
  where
    str2b :: LispVal -> ExceptT LispError IO ByteString
str2b LispVal
obj = do
        String FilePath
str <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
obj -- Last opportunity to do this before writing
        ByteString -> ExceptT LispError IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ExceptT LispError IO ByteString)
-> ByteString -> ExceptT LispError IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
BSU.fromString FilePath
str

-- |Helper function to write buffer-based data to output port
writeBuffer :: [LispVal] -> (LispVal -> IOThrowsError BSU.ByteString) -> IOThrowsError LispVal
writeBuffer :: [LispVal]
-> (LispVal -> ExceptT LispError IO ByteString)
-> IOThrowsError LispVal
writeBuffer [LispVal
obj, Port Handle
port Maybe Knob
_] LispVal -> ExceptT LispError IO ByteString
getBS = do
    ByteString
bs <- LispVal -> ExceptT LispError IO ByteString
getBS LispVal
obj
    Either IOError ()
output <- IO (Either IOError ()) -> ExceptT LispError IO (Either IOError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError ())
 -> ExceptT LispError IO (Either IOError ()))
-> IO (Either IOError ())
-> ExceptT LispError IO (Either IOError ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOError ())
forall a. IO a -> IO (Either IOError a)
try' (IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPut Handle
port ByteString
bs)
    case Either IOError ()
output of
        Left IOError
_ -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default FilePath
"I/O error writing to port"
        Right ()
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
Nil FilePath
""
writeBuffer [LispVal]
other LispVal -> ExceptT LispError IO ByteString
_ = 
    if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
other Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
       then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"(bytevector port)" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
other
       else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
other

-- |Determine if the given file exists
--
--   Arguments:
--
--   * String - Filename to check
--
--   Returns: Bool - True if file exists, false otherwise
--
fileExists :: [LispVal] -> IOThrowsError LispVal
fileExists :: [LispVal] -> IOThrowsError LispVal
fileExists [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
fileExists
fileExists [String FilePath
filename] = do
    Bool
exists <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
filename
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
exists
fileExists [] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
fileExists args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Delete the given file
--
--   Arguments:
--
--   * String - Filename to delete
--
--   Returns: Bool - True if file was deleted, false if an error occurred
--
deleteFile :: [LispVal] -> IOThrowsError LispVal
deleteFile :: [LispVal] -> IOThrowsError LispVal
deleteFile [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
deleteFile
deleteFile [String FilePath
filename] = do
    Either IOError ()
output <- IO (Either IOError ()) -> ExceptT LispError IO (Either IOError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError ())
 -> ExceptT LispError IO (Either IOError ()))
-> IO (Either IOError ())
-> ExceptT LispError IO (Either IOError ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOError ())
forall a. IO a -> IO (Either IOError a)
try' (IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
filename)
    case Either IOError ()
output of
        Left IOError
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
        Right ()
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
deleteFile [] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
deleteFile args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Read the given file and return the raw string content 
--
--   Arguments:
--
--   * String - Filename to read
--
--   Returns: String - Actual text read from the file
--
readContents :: [LispVal] -> IOThrowsError LispVal
readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String FilePath
filename] = (FilePath -> LispVal)
-> ExceptT LispError IO FilePath -> IOThrowsError LispVal
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM FilePath -> LispVal
String (ExceptT LispError IO FilePath -> IOThrowsError LispVal)
-> ExceptT LispError IO FilePath -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ IO FilePath -> ExceptT LispError IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT LispError IO FilePath)
-> IO FilePath -> ExceptT LispError IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
filename
readContents [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
readContents
readContents [] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
readContents args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Parse the given file and return a list of scheme expressions
--
--   Arguments:
--
--   * String - Filename to read
--
--   Returns: [LispVal] - Raw contents of the file parsed as scheme code
--
load :: String -> IOThrowsError [LispVal]
load :: FilePath -> ExceptT LispError IO [LispVal]
load FilePath
filename = do
  Bool
result <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
filename
  if Bool
result
     then do
        FilePath
f <- IO FilePath -> ExceptT LispError IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT LispError IO FilePath)
-> IO FilePath -> ExceptT LispError IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
filename

        case FilePath -> [FilePath]
lines FilePath
f of
            -- Skip comment header for shell scripts
            -- TODO: this could be much more robust
            ((Char
'#':Char
'!':Char
'/' : FilePath
_) : [FilePath]
ls) -> ThrowsError [LispVal] -> ExceptT LispError IO [LispVal]
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError [LispVal] -> ExceptT LispError IO [LispVal])
-> (FilePath -> ThrowsError [LispVal])
-> FilePath
-> ExceptT LispError IO [LispVal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ThrowsError [LispVal]
readExprList (FilePath -> ExceptT LispError IO [LispVal])
-> FilePath -> ExceptT LispError IO [LispVal]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath]
ls
            ((Char
'#':Char
'!':Char
' ':Char
'/' : FilePath
_) : [FilePath]
ls) -> ThrowsError [LispVal] -> ExceptT LispError IO [LispVal]
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError [LispVal] -> ExceptT LispError IO [LispVal])
-> (FilePath -> ThrowsError [LispVal])
-> FilePath
-> ExceptT LispError IO [LispVal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ThrowsError [LispVal]
readExprList (FilePath -> ExceptT LispError IO [LispVal])
-> FilePath -> ExceptT LispError IO [LispVal]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath]
ls
            [FilePath]
_ -> (ThrowsError [LispVal] -> ExceptT LispError IO [LispVal]
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError [LispVal] -> ExceptT LispError IO [LispVal])
-> (FilePath -> ThrowsError [LispVal])
-> FilePath
-> ExceptT LispError IO [LispVal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ThrowsError [LispVal]
readExprList) FilePath
f
     else LispError -> ExceptT LispError IO [LispVal]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ExceptT LispError IO [LispVal])
-> LispError -> ExceptT LispError IO [LispVal]
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default (FilePath -> LispError) -> FilePath -> LispError
forall a b. (a -> b) -> a -> b
$ FilePath
"File does not exist: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filename

-- | Read the contents of the given scheme source file into a list
--
--   Arguments:
--
--   * String - Filename to read
--
--   Returns: List - Raw contents of the file parsed as scheme code
--
readAll :: [LispVal] -> IOThrowsError LispVal
readAll :: [LispVal] -> IOThrowsError LispVal
readAll [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
readAll
readAll [String FilePath
filename] = ([LispVal] -> LispVal)
-> ExceptT LispError IO [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [LispVal] -> LispVal
List (ExceptT LispError IO [LispVal] -> IOThrowsError LispVal)
-> ExceptT LispError IO [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> ExceptT LispError IO [LispVal]
load FilePath
filename
readAll [] = do -- read from stdin
    FilePath
input <- IO FilePath -> ExceptT LispError IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT LispError IO FilePath)
-> IO FilePath -> ExceptT LispError IO FilePath
forall a b. (a -> b) -> a -> b
$ IO FilePath
getContents
    [LispVal]
lisp <- (ThrowsError [LispVal] -> ExceptT LispError IO [LispVal]
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError [LispVal] -> ExceptT LispError IO [LispVal])
-> (FilePath -> ThrowsError [LispVal])
-> FilePath
-> ExceptT LispError IO [LispVal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ThrowsError [LispVal]
readExprList) FilePath
input
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
lisp
readAll args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Version of gensym that can be conveniently called from Haskell.
_gensym :: String -> IOThrowsError LispVal
_gensym :: FilePath -> IOThrowsError LispVal
_gensym FilePath
prefix = do
    Unique
u <- IO Unique -> ExceptT LispError IO Unique
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Unique -> ExceptT LispError IO Unique)
-> IO Unique -> ExceptT LispError IO Unique
forall a b. (a -> b) -> a -> b
$ IO Unique
newUnique
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
Atom (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath
prefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (LispVal -> FilePath
forall a. Show a => a -> FilePath
show (LispVal -> FilePath) -> LispVal -> FilePath
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Unique -> Int
hashUnique Unique
u)

-- |Generate a (reasonably) unique symbol, given an optional prefix.
--  This function is provided even though it is not part of R5RS.
--
--   Arguments:
--
--   * String - Prefix of the unique symbol
--
--   Returns: Atom
--
gensym :: [LispVal] -> IOThrowsError LispVal
gensym :: [LispVal] -> IOThrowsError LispVal
gensym [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
gensym
gensym [String FilePath
prefix] = FilePath -> IOThrowsError LispVal
_gensym FilePath
prefix
gensym [] = FilePath -> IOThrowsError LispVal
_gensym FilePath
" g"
gensym args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args


---------------------------------------------------
-- "Pure" primitives
---------------------------------------------------

-- List primitives

-- | Retrieve the first item from a list
--
--   Arguments:
--
--   * List (or DottedList)
--
--   Returns: LispVal - First item in the list
--
car :: [LispVal] -> IOThrowsError LispVal
car :: [LispVal] -> IOThrowsError LispVal
car [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
car
car [List (LispVal
x : [LispVal]
_)] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
x
car [DottedList (LispVal
x : [LispVal]
_) LispVal
_] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
x
car [LispVal
badArg] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"pair" LispVal
badArg
car [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Return the /tail/ of a list, with the first element removed
--
--   Arguments:
--
--   * List (or DottedList)
--
--   Returns: List (or DottedList)
--
cdr :: [LispVal] -> IOThrowsError LispVal
cdr :: [LispVal] -> IOThrowsError LispVal
cdr [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
cdr
cdr [List (LispVal
_ : [LispVal]
xs)] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
xs
cdr [DottedList [LispVal
_] LispVal
x] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
x
cdr [DottedList (LispVal
_ : [LispVal]
xs) LispVal
x] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal -> LispVal
DottedList [LispVal]
xs LispVal
x
cdr [LispVal
badArg] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"pair" LispVal
badArg
cdr [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | The LISP @cons@ operation - create a list from two values
--
--   Arguments:
--
--   * LispVal
--
--   * LispVal
--
--   Returns: List (or DottedList) containing new value(s)
--
cons :: [LispVal] -> IOThrowsError LispVal
cons :: [LispVal] -> IOThrowsError LispVal
cons [LispVal
x, p :: LispVal
p@(Pointer FilePath
_ Env
_)] = do
  LispVal
y <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  [LispVal] -> IOThrowsError LispVal
cons [LispVal
x, LispVal
y]
cons [LispVal
x1, List []] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal
x1]
cons [LispVal
x, List [LispVal]
xs] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ LispVal
x LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
xs
cons [LispVal
x, DottedList [LispVal]
xs LispVal
xlast] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal -> LispVal
DottedList (LispVal
x LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
xs) LispVal
xlast
cons [LispVal
x1, LispVal
x2] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal -> LispVal
DottedList [LispVal
x1] LispVal
x2
cons [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList

-- | Create a new list
--
--   Arguments
--
--   * Number - Length of the list
--   * LispVal - Object to fill the list with (optional)
--
--   Returns: List
makeList :: [LispVal] -> ThrowsError LispVal
makeList :: [LispVal] -> ThrowsError LispVal
makeList [(Number Integer
n)] = [LispVal] -> ThrowsError LispVal
makeList [Integer -> LispVal
Number Integer
n, [LispVal] -> LispVal
List []]
makeList [(Number Integer
n), LispVal
a] = do
  let l :: [LispVal]
l = Int -> LispVal -> [LispVal]
forall a. Int -> a -> [a]
replicate (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) LispVal
a
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
l
makeList [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"integer" LispVal
badType
makeList [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Create a copy of a list
--
--   Arguments
--
--   * List
--
--   Returns: List
listCopy :: [LispVal] -> IOThrowsError LispVal
listCopy :: [LispVal] -> IOThrowsError LispVal
listCopy [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = do
  LispVal
l <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  [LispVal] -> IOThrowsError LispVal
listCopy [LispVal
l]
listCopy [(List [LispVal]
ls)] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
ls
listCopy [LispVal
badType] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
badType
listCopy [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Create a copy of a vector
--
--   Arguments
--
--   * Vector
--   * Number - Start copying the vector from this element (optional)
--   * Number - Stop copying the vector at this element (optional)
--
--   Returns: Vector
vectorCopy :: [LispVal] -> IOThrowsError LispVal
vectorCopy :: [LispVal] -> IOThrowsError LispVal
vectorCopy (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
args) = do
  LispVal
v <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  [LispVal] -> IOThrowsError LispVal
vectorCopy (LispVal
v LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
args)
vectorCopy [Vector Array Int LispVal
vs] = do
    let l :: [LispVal]
l = Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
vs
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [LispVal]
l 
vectorCopy [Vector Array Int LispVal
vs, Number Integer
start] = do
    let l :: [LispVal]
l = Int -> [LispVal] -> [LispVal]
forall a. Int -> [a] -> [a]
drop (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
start) ([LispVal] -> [LispVal]) -> [LispVal] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ 
              Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
vs
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [LispVal]
l 
vectorCopy [Vector Array Int LispVal
vs, Number Integer
start, Number Integer
end] = do
    let l :: [LispVal]
l = Int -> [LispVal] -> [LispVal]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
end Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start) ([LispVal] -> [LispVal]) -> [LispVal] -> [LispVal]
forall a b. (a -> b) -> a -> b
$
              Int -> [LispVal] -> [LispVal]
forall a. Int -> [a] -> [a]
drop (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
start) ([LispVal] -> [LispVal]) -> [LispVal] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ 
                Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
vs
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [LispVal]
l 
vectorCopy [LispVal
badType] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
badType
vectorCopy [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Use pointer equality to compare two objects if possible, otherwise
--   fall back to the normal equality comparison
eq :: [LispVal] -> IOThrowsError LispVal
eq :: [LispVal] -> IOThrowsError LispVal
eq [(Pointer FilePath
pA Env
envA), (Pointer FilePath
pB Env
envB)] = do
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ (FilePath
pA FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
pB) Bool -> Bool -> Bool
&& ((Env -> IORef (Map FilePath (IORef LispVal))
bindings Env
envA) IORef (Map FilePath (IORef LispVal))
-> IORef (Map FilePath (IORef LispVal)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Env -> IORef (Map FilePath (IORef LispVal))
bindings Env
envB))
--    if pA == pB 
--       then do
--         refA <- getNamespacedRef envA varNamespace pA
--         refB <- getNamespacedRef envB varNamespace pB
--         return $ Bool $ refA == refB
--       else return $ Bool False
eq [LispVal]
args = ([LispVal] -> ThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
recDerefToFnc [LispVal] -> ThrowsError LispVal
eqv [LispVal]
args

-- | Recursively compare two LispVals for equality
--
--   Arguments:
--
--   * LispVal
--
--   * LispVal
--
--   Returns: Bool - True if equal, false otherwise
--
equal :: [LispVal] -> ThrowsError LispVal
equal :: [LispVal] -> ThrowsError LispVal
equal [(Vector Array Int LispVal
arg1), (Vector Array Int LispVal
arg2)] = ([LispVal] -> ThrowsError LispVal)
-> [LispVal] -> ThrowsError LispVal
eqvList [LispVal] -> ThrowsError LispVal
equal [[LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ (Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
arg1), [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ (Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
arg2)]
equal [l1 :: LispVal
l1@(List [LispVal]
_), l2 :: LispVal
l2@(List [LispVal]
_)] = ([LispVal] -> ThrowsError LispVal)
-> [LispVal] -> ThrowsError LispVal
eqvList [LispVal] -> ThrowsError LispVal
equal [LispVal
l1, LispVal
l2]
equal [(DottedList [LispVal]
xs LispVal
x), (DottedList [LispVal]
ys LispVal
y)] = [LispVal] -> ThrowsError LispVal
equal [[LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
xs [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
x], [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
ys [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
y]]
equal [LispVal
arg1, LispVal
arg2] = do
  Bool
primitiveEquals <- ([Bool] -> Bool)
-> Either LispError [Bool] -> Either LispError Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (Either LispError [Bool] -> Either LispError Bool)
-> Either LispError [Bool] -> Either LispError Bool
forall a b. (a -> b) -> a -> b
$ (Unpacker -> Either LispError Bool)
-> [Unpacker] -> Either LispError [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LispVal -> LispVal -> Unpacker -> Either LispError Bool
unpackEquals LispVal
arg1 LispVal
arg2)
                     [(LispVal -> ThrowsError Integer) -> Unpacker
forall a. Eq a => (LispVal -> ThrowsError a) -> Unpacker
AnyUnpacker LispVal -> ThrowsError Integer
unpackNum, (LispVal -> ThrowsError FilePath) -> Unpacker
forall a. Eq a => (LispVal -> ThrowsError a) -> Unpacker
AnyUnpacker LispVal -> ThrowsError FilePath
unpackStr, (LispVal -> Either LispError Bool) -> Unpacker
forall a. Eq a => (LispVal -> ThrowsError a) -> Unpacker
AnyUnpacker LispVal -> Either LispError Bool
unpackBool]
  LispVal
eqvEquals <- [LispVal] -> ThrowsError LispVal
eqv [LispVal
arg1, LispVal
arg2]
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ (Bool
primitiveEquals Bool -> Bool -> Bool
|| let (Bool Bool
x) = LispVal
eqvEquals in Bool
x)
equal [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList

-- ------------ Vector Primitives --------------

-- | Create a new vector
--
--   Arguments:
--
--   * Number - Length of the vector
--
--   * LispVal - Value to fill the vector with
--
--   Returns: Vector
--
makeVector :: [LispVal] -> ThrowsError LispVal
makeVector :: [LispVal] -> ThrowsError LispVal
makeVector [(Number Integer
n)] = [LispVal] -> ThrowsError LispVal
makeVector [Integer -> LispVal
Number Integer
n, [LispVal] -> LispVal
List []]
makeVector [(Number Integer
n), LispVal
a] = do
  let l :: [LispVal]
l = Int -> LispVal -> [LispVal]
forall a. Int -> a -> [a]
replicate (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) LispVal
a
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [LispVal]
l
makeVector [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"integer" LispVal
badType
makeVector [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Create a vector from the given lisp values
--
--   Arguments:
--
--   * LispVal (s)
--
--   Returns: Vector
--
buildVector :: [LispVal] -> ThrowsError LispVal
buildVector :: [LispVal] -> ThrowsError LispVal
buildVector lst :: [LispVal]
lst@(LispVal
_ : [LispVal]
_) = do
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
lst Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [LispVal]
lst
buildVector [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Determine the length of the given vector
--
--   Arguments:
--
--   * Vector
--
--   Returns: Number
--
vectorLength :: [LispVal] -> ThrowsError LispVal
vectorLength :: [LispVal] -> ThrowsError LispVal
vectorLength [(Vector Array Int LispVal
v)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v)
vectorLength [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"vector" LispVal
badType
vectorLength [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Retrieve the object at the given position of a vector
--
--   Arguments:
--
--   * Vector
--
--   * Number - Index of the vector to retrieve
--
--   Returns: Object at the given index
--
vectorRef :: [LispVal] -> ThrowsError LispVal
vectorRef :: [LispVal] -> ThrowsError LispVal
vectorRef [(Vector Array Int LispVal
v), (Number Integer
n)] = do
    let len :: Integer
len = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([LispVal] -> Int) -> [LispVal] -> Int
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
len Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
       then LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default FilePath
"Invalid index"
       else LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal
v Array Int LispVal -> Int -> LispVal
forall i e. Ix i => Array i e -> i -> e
! (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
vectorRef [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"vector integer" LispVal
badType
vectorRef [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList

-- | Convert the given vector to a list
--
--   Arguments:
--
--   * Vector
--
--   Returns: List
--
vectorToList :: [LispVal] -> ThrowsError LispVal
vectorToList :: [LispVal] -> ThrowsError LispVal
vectorToList [(Vector Array Int LispVal
v)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v
vectorToList [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"vector" LispVal
badType
vectorToList [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Convert the given list to a vector
--
--   Arguments:
--
--   * List to convert
--
--   Returns: Vector
--
listToVector :: [LispVal] -> ThrowsError LispVal
listToVector :: [LispVal] -> ThrowsError LispVal
listToVector [(List [LispVal]
l)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [LispVal]
l
listToVector [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"list" LispVal
badType
listToVector [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- ------------ Bytevector Primitives --------------

-- | Create a new bytevector
--
--   Arguments:
--
--   * Number - Length of the new bytevector
--
--   * Number (optional) - Byte value to fill the bytevector with
--
--   Returns: ByteVector - A new bytevector
--
makeByteVector :: [LispVal] -> ThrowsError LispVal
makeByteVector :: [LispVal] -> ThrowsError LispVal
makeByteVector [(Number Integer
n)] = do
  let ls :: [Word8]
ls = Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) (Word8
0 :: Word8)
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack [Word8]
ls
makeByteVector [Number Integer
n, Number Integer
byte] = do
  let ls :: [Word8]
ls = Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) (Integer -> Word8
forall a. Num a => Integer -> a
fromInteger Integer
byte :: Word8)
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack [Word8]
ls
makeByteVector [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"integer" LispVal
badType
makeByteVector [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList

-- | Create new bytevector containing the given data
--
--   Arguments:
--
--   * Objects - Objects to convert to bytes for the bytevector
--
--   Returns: ByteVector - A new bytevector
--
byteVector :: [LispVal] -> ThrowsError LispVal
byteVector :: [LispVal] -> ThrowsError LispVal
byteVector [LispVal]
bs = do
 LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (LispVal -> Word8) -> [LispVal] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map LispVal -> Word8
conv [LispVal]
bs
 where 
   conv :: LispVal -> Word8
conv (Number Integer
n) = Integer -> Word8
forall a. Num a => Integer -> a
fromInteger Integer
n :: Word8
   conv LispVal
_ = Word8
0 :: Word8

byteVectorCopy :: [LispVal] -> IOThrowsError LispVal

-- | Create a copy of the given bytevector
--
--   Arguments:
--
--   * ByteVector - Bytevector to copy
--
--   * Number (optional) - Start of the region to copy
--
--   * Number (optional) - End of the region to copy
--
--   Returns: ByteVector - A new bytevector containing the copied region
--
byteVectorCopy :: [LispVal] -> IOThrowsError LispVal
byteVectorCopy (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
lvs) = do
    LispVal
bv <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
    [LispVal] -> IOThrowsError LispVal
byteVectorCopy (LispVal
bv LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
lvs)
byteVectorCopy [ByteVector ByteString
bv] = do
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.copy
        ByteString
bv
byteVectorCopy [ByteVector ByteString
bv, Number Integer
start] = do
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop 
        (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
start)
        ByteString
bv
byteVectorCopy [ByteVector ByteString
bv, Number Integer
start, Number Integer
end] = do
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take 
        (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
end Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start)
        (Int -> ByteString -> ByteString
BS.drop 
            (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
start)
            ByteString
bv)
byteVectorCopy [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"bytevector" LispVal
badType
byteVectorCopy [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Append many bytevectors into a new bytevector
--
--   Arguments:
--
--   * ByteVector (one or more) - Bytevectors to concatenate
--
--   Returns: ByteVector - A new bytevector containing the values
--
byteVectorAppend :: [LispVal] -> IOThrowsError LispVal
byteVectorAppend :: [LispVal] -> IOThrowsError LispVal
byteVectorAppend [LispVal]
bs = do
    let conv :: LispVal -> IOThrowsError BSU.ByteString
        conv :: LispVal -> ExceptT LispError IO ByteString
conv p :: LispVal
p@(Pointer FilePath
_ Env
_) = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO ByteString)
-> ExceptT LispError IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO ByteString
conv
        conv (ByteVector ByteString
bvs) = ByteString -> ExceptT LispError IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bvs
        conv LispVal
_ = ByteString -> ExceptT LispError IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty
    [ByteString]
bs' <- (LispVal -> ExceptT LispError IO ByteString)
-> [LispVal] -> ExceptT LispError IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LispVal -> ExceptT LispError IO ByteString
conv [LispVal]
bs
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat [ByteString]
bs'
-- TODO: error handling

-- | Find the length of a bytevector
--
--   Arguments:
--
--   * ByteVector
--
--   Returns: Number - Length of the given bytevector
--
byteVectorLength :: [LispVal] -> IOThrowsError LispVal
byteVectorLength :: [LispVal] -> IOThrowsError LispVal
byteVectorLength [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
byteVectorLength
byteVectorLength [(ByteVector ByteString
bv)] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bv
byteVectorLength [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"bytevector" LispVal
badType
byteVectorLength [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Return object at the given index of a bytevector
--
--   Arguments:
--
--   * ByteVector
--
--   * Number - Index of the bytevector to query
--
--   Returns: Object at the index
--
byteVectorRef :: [LispVal] -> IOThrowsError LispVal
byteVectorRef :: [LispVal] -> IOThrowsError LispVal
byteVectorRef (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
lvs) = do
    LispVal
bv <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
    [LispVal] -> IOThrowsError LispVal
byteVectorRef (LispVal
bv LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
lvs)
byteVectorRef [(ByteVector ByteString
bv), (Number Integer
n)] = do
    let len :: Integer
len = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ (ByteString -> Int
BS.length ByteString
bv) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
len Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
       then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default FilePath
"Invalid index"
       else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Word8 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word8 -> Integer) -> Word8 -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> Word8
BS.index ByteString
bv (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
byteVectorRef [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"bytevector integer" LispVal
badType
byteVectorRef [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList

-- | Convert a bytevector to a string
--
--   Arguments:
--
--   * ByteVector
--
--   Returns: String
--
byteVectorUtf2Str :: [LispVal] -> IOThrowsError LispVal
byteVectorUtf2Str :: [LispVal] -> IOThrowsError LispVal
byteVectorUtf2Str [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
byteVectorUtf2Str
byteVectorUtf2Str [(ByteVector ByteString
bv)] = do
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
BSU.toString ByteString
bv 
-- TODO: need to support other overloads of this function
byteVectorUtf2Str [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"bytevector" LispVal
badType
byteVectorUtf2Str [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Convert a string to a bytevector
--
--   Arguments:
--
--   * String
--
--   Returns: ByteVector
--
byteVectorStr2Utf :: [LispVal] -> IOThrowsError LispVal
byteVectorStr2Utf :: [LispVal] -> IOThrowsError LispVal
byteVectorStr2Utf [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
byteVectorStr2Utf
byteVectorStr2Utf [(String FilePath
s)] = do
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
BSU.fromString FilePath
s
-- TODO: need to support other overloads of this function
byteVectorStr2Utf [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" LispVal
badType
byteVectorStr2Utf [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList


-- ------------ Ptr Helper Primitives --------------

-- | A helper function to allow a pure function to work with pointers, by
--   dereferencing the leading object in the argument list if it is
--   a pointer. This is a special hash-table specific function that will
--   also dereference a hash table key if it is included.
wrapHashTbl :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal
wrapHashTbl :: ([LispVal] -> ThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
wrapHashTbl [LispVal] -> ThrowsError LispVal
fnc [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = do
  LispVal
val <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
fnc [LispVal
val]
wrapHashTbl [LispVal] -> ThrowsError LispVal
fnc (p :: LispVal
p@(Pointer FilePath
_ Env
_) : LispVal
key : [LispVal]
args) = do
  LispVal
ht <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  LispVal
k <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
key
  ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
fnc (LispVal
ht LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: LispVal
k LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
args)
wrapHashTbl [LispVal] -> ThrowsError LispVal
fnc [LispVal]
args = ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
fnc [LispVal]
args

-- | A helper function to allow a pure function to work with pointers, by
--   dereferencing the leading object in the argument list if it is
--   a pointer.
wrapLeadObj :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal
wrapLeadObj :: ([LispVal] -> ThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
wrapLeadObj [LispVal] -> ThrowsError LispVal
fnc [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = do
  LispVal
val <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
fnc [LispVal
val]
wrapLeadObj [LispVal] -> ThrowsError LispVal
fnc (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
args) = do
  LispVal
obj <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
fnc (LispVal
obj LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
args)
wrapLeadObj [LispVal] -> ThrowsError LispVal
fnc [LispVal]
args = ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
fnc [LispVal]
args

-- ------------ Hash Table Primitives --------------

-- Future: support (equal?), (hash) parameters

-- | Create a new hashtable
--
--   Arguments: (None)
--
--   Returns: HashTable
--
hashTblMake :: [LispVal] -> ThrowsError LispVal
hashTblMake :: [LispVal] -> ThrowsError LispVal
hashTblMake [LispVal]
_ = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> LispVal
HashTable (Map LispVal LispVal -> LispVal) -> Map LispVal LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ [(LispVal, LispVal)] -> Map LispVal LispVal
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList []

-- | Determine if a given object is a hashtable
--
--   Arguments:
--
--   * Object to inspect
--
--   Returns: Bool - True if arg was a hashtable, false otherwise
--
isHashTbl :: [LispVal] -> ThrowsError LispVal
isHashTbl :: [LispVal] -> ThrowsError LispVal
isHashTbl [(HashTable Map LispVal LispVal
_)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isHashTbl [LispVal]
_ = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if the given key is found in the hashtable
--
--   Arguments:
--
--   * HashTable to search
--
--   * Key to search for
--
--   Returns: Bool - True if found, False otherwise
--
hashTblExists :: [LispVal] -> ThrowsError LispVal
hashTblExists :: [LispVal] -> ThrowsError LispVal
hashTblExists [(HashTable Map LispVal LispVal
ht), LispVal
key] = do
  case LispVal -> Map LispVal LispVal -> Maybe LispVal
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup LispVal
key Map LispVal LispVal
ht of
    Just LispVal
_ -> LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
    Maybe LispVal
Nothing -> LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
hashTblExists [] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) []
hashTblExists args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args

-- | Return the number of key/value associations in the hashtable
--
--   Arguments:
--
--   * HashTable
--
--   Returns: Number - number of associations
--
hashTblSize :: [LispVal] -> ThrowsError LispVal
hashTblSize :: [LispVal] -> ThrowsError LispVal
hashTblSize [(HashTable Map LispVal LispVal
ht)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> Int
forall k a. Map k a -> Int
Data.Map.size Map LispVal LispVal
ht
hashTblSize [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"hash-table" LispVal
badType
hashTblSize [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Create a list containing all key/value pairs in the hashtable
--
--   Arguments:
--
--   * HashTable
--
--   Returns: List of (key, value) pairs
--
hashTbl2List :: [LispVal] -> ThrowsError LispVal
hashTbl2List :: [LispVal] -> ThrowsError LispVal
hashTbl2List [(HashTable Map LispVal LispVal
ht)] = do
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ ((LispVal, LispVal) -> LispVal)
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map (\ (LispVal
k, LispVal
v) -> [LispVal] -> LispVal
List [LispVal
k, LispVal
v]) ([(LispVal, LispVal)] -> [LispVal])
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> [(LispVal, LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map LispVal LispVal
ht
hashTbl2List [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"hash-table" LispVal
badType
hashTbl2List [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Create a list containing all keys in the hashtable
--
--   Arguments:
--
--   * HashTable
--
--   Returns: List containing the keys
--
hashTblKeys :: [LispVal] -> ThrowsError LispVal
hashTblKeys :: [LispVal] -> ThrowsError LispVal
hashTblKeys [(HashTable Map LispVal LispVal
ht)] = do
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ ((LispVal, LispVal) -> LispVal)
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map (LispVal, LispVal) -> LispVal
forall a b. (a, b) -> a
fst ([(LispVal, LispVal)] -> [LispVal])
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> [(LispVal, LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map LispVal LispVal
ht
hashTblKeys [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"hash-table" LispVal
badType
hashTblKeys [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Create a list containing all values in the hashtable
--
--   Arguments:
--
--   * HashTable
--
--   Returns: List containing the values
--
hashTblValues :: [LispVal] -> ThrowsError LispVal
hashTblValues :: [LispVal] -> ThrowsError LispVal
hashTblValues [(HashTable Map LispVal LispVal
ht)] = do
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ ((LispVal, LispVal) -> LispVal)
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map (LispVal, LispVal) -> LispVal
forall a b. (a, b) -> b
snd ([(LispVal, LispVal)] -> [LispVal])
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> [(LispVal, LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map LispVal LispVal
ht
hashTblValues [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"hash-table" LispVal
badType
hashTblValues [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Create a new copy of a hashtable
--
--   Arguments:
--
--   * HashTable to copy
--
--   Returns: HashTable
--
hashTblCopy :: [LispVal] -> ThrowsError LispVal
hashTblCopy :: [LispVal] -> ThrowsError LispVal
hashTblCopy [(HashTable Map LispVal LispVal
ht)] = do
  LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> LispVal
HashTable (Map LispVal LispVal -> LispVal) -> Map LispVal LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ [(LispVal, LispVal)] -> Map LispVal LispVal
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList ([(LispVal, LispVal)] -> Map LispVal LispVal)
-> [(LispVal, LispVal)] -> Map LispVal LispVal
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> [(LispVal, LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map LispVal LispVal
ht
hashTblCopy [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"hash-table" LispVal
badType
hashTblCopy [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- ------------ String Primitives --------------

-- | Convert a list of characters to a string
--
--   Arguments:
--
--   * Character (one or more) - Character(s) to add to the string
--
--   Returns: String - new string built from given chars
--
buildString :: [LispVal] -> ThrowsError LispVal
buildString :: [LispVal] -> ThrowsError LispVal
buildString [(Char Char
c)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String [Char
c]
buildString (Char Char
c : [LispVal]
rest) = do
  LispVal
cs <- [LispVal] -> ThrowsError LispVal
buildString [LispVal]
rest
  case LispVal
cs of
    String FilePath
s -> LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ Char
cChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
s
    LispVal
badType -> LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"character" LispVal
badType
buildString [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"character" LispVal
badType
buildString [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Make a new string
--
--   Arguments:
--
--   * Number - number of characters in the string
--
--   * Char (optional) - Character to fill in each position of string.
--                       Defaults to space
--
--   Returns: String - new string
--
makeString :: [LispVal] -> ThrowsError LispVal
makeString :: [LispVal] -> ThrowsError LispVal
makeString [(Number Integer
n)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> Char -> FilePath -> LispVal
forall a. (Num a, Eq a) => a -> Char -> FilePath -> LispVal
doMakeString Integer
n Char
' ' FilePath
""
makeString [(Number Integer
n), (Char Char
c)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> Char -> FilePath -> LispVal
forall a. (Num a, Eq a) => a -> Char -> FilePath -> LispVal
doMakeString Integer
n Char
c FilePath
""
makeString [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- |Helper function
doMakeString :: forall a . (Num a, Eq a) => a -> Char -> String -> LispVal
doMakeString :: a -> Char -> FilePath -> LispVal
doMakeString a
n Char
char FilePath
s =
    if a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
       then FilePath -> LispVal
String FilePath
s
       else a -> Char -> FilePath -> LispVal
forall a. (Num a, Eq a) => a -> Char -> FilePath -> LispVal
doMakeString (a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1) Char
char (FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Char
char])

-- | Determine the length of the given string
--
--   Arguments:
--
--   * String - String to examine
--
--   Returns: Number - Length of the given string
--
stringLength :: [LispVal] -> IOThrowsError LispVal
stringLength :: [LispVal] -> IOThrowsError LispVal
stringLength [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p  IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
stringLength
stringLength [String FilePath
s] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ (Char -> Integer -> Integer) -> Integer -> FilePath -> Integer
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Integer -> Integer) -> Char -> Integer -> Integer
forall a b. a -> b -> a
const (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)) Integer
0 FilePath
s -- Could probably do 'length s' instead...
stringLength [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" LispVal
badType
stringLength [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Get character at the given position of a string
--
--   Arguments:
--
--   * String - String to examine
--
--   * Number - Get the character at this position
--
--   Returns: Char
--
stringRef :: [LispVal] -> IOThrowsError LispVal
stringRef :: [LispVal] -> IOThrowsError LispVal
stringRef [p :: LispVal
p@(Pointer FilePath
_ Env
_), k :: LispVal
k@(Number Integer
_)] = do
    LispVal
s <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p 
    [LispVal] -> IOThrowsError LispVal
stringRef [LispVal
s, LispVal
k]
stringRef [(String FilePath
s), (Number Integer
k)] = do
    let len :: Integer
len = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
s) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    if Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
len Bool -> Bool -> Bool
|| Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
       then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default (FilePath -> LispError) -> FilePath -> LispError
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid index " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
k)
       else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char (Char -> LispVal) -> Char -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath
s FilePath -> Int -> Char
forall a. [a] -> Int -> a
!! Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
k
stringRef [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string number" LispVal
badType
stringRef [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList

-- | Get a part of the given string
--
--   Arguments:
--
--   * String - Original string
--
--   * Number - Starting position of the substring
--
--   * Number - Ending position of the substring
--
--   Returns: String - substring of the original string
--
substring :: [LispVal] -> IOThrowsError LispVal
substring :: [LispVal] -> IOThrowsError LispVal
substring (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
lvs) = do
  LispVal
s <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  [LispVal] -> IOThrowsError LispVal
substring (LispVal
s LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
lvs)
substring [(String FilePath
s), (Number Integer
start), (Number Integer
end)] =
  do let slength :: Int
slength = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
end Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start
     let begin :: Int
begin = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
start
     LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
slength (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
begin) FilePath
s
substring [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string number number" LispVal
badType
substring [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3) [LispVal]
badArgList

-- | Perform a case insensitive comparison of the given strings
--
--   Arguments:
--
--   * String - String to compare
--
--   * String - String to compare
--
--   Returns: Bool - True if strings are equal, false otherwise
--
stringCIEquals :: [LispVal] -> IOThrowsError LispVal
stringCIEquals :: [LispVal] -> IOThrowsError LispVal
stringCIEquals [LispVal]
args = do
  List [LispVal]
dargs <- LispVal -> IOThrowsError LispVal
recDerefPtrs (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args
  case [LispVal]
dargs of
    [(String FilePath
str1), (String FilePath
str2)] -> do
      if (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
str1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
str2)
         then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
         else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Int -> Bool
ciCmp FilePath
str1 FilePath
str2 Int
0
    [LispVal
badType] -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string string" LispVal
badType
    [LispVal]
badArgList -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList
 where ciCmp :: FilePath -> FilePath -> Int -> Bool
ciCmp FilePath
s1 FilePath
s2 Int
idx = 
         (Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
s1)) Bool -> Bool -> Bool
||
         (((Char -> Char
toLower (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ FilePath
s1 FilePath -> Int -> Char
forall a. [a] -> Int -> a
!! Int
idx) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char
toLower (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ FilePath
s2 FilePath -> Int -> Char
forall a. [a] -> Int -> a
!! Int
idx)) Bool -> Bool -> Bool
&& 
          FilePath -> FilePath -> Int -> Bool
ciCmp FilePath
s1 FilePath
s2 (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

-- |Helper function
stringCIBoolBinop :: (String -> String -> Bool) -> [LispVal] -> IOThrowsError LispVal
stringCIBoolBinop :: (FilePath -> FilePath -> Bool)
-> [LispVal] -> IOThrowsError LispVal
stringCIBoolBinop FilePath -> FilePath -> Bool
op [LispVal]
args = do 
  List [LispVal]
dargs <- LispVal -> IOThrowsError LispVal
recDerefPtrs (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args -- Deref any pointers
  case [LispVal]
dargs of
    [(String FilePath
s1), (String FilePath
s2)] ->
      ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ (LispVal -> ThrowsError FilePath)
-> (FilePath -> FilePath -> Bool)
-> [LispVal]
-> ThrowsError LispVal
forall a.
(LispVal -> ThrowsError a)
-> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop LispVal -> ThrowsError FilePath
unpackStr FilePath -> FilePath -> Bool
op [(FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
strToLower FilePath
s1), (FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
strToLower FilePath
s2)]
    [LispVal
badType] -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string string" LispVal
badType
    [LispVal]
badArgList -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList
  where strToLower :: FilePath -> FilePath
strToLower = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

-- |Helper function
charCIBoolBinop :: (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal
charCIBoolBinop :: (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal
charCIBoolBinop Char -> Char -> Bool
op [(Char Char
s1), (Char Char
s2)] = (LispVal -> ThrowsError Char)
-> (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal
forall a.
(LispVal -> ThrowsError a)
-> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop LispVal -> ThrowsError Char
unpackChar Char -> Char -> Bool
op [(Char -> LispVal
Char (Char -> LispVal) -> Char -> LispVal
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
s1), (Char -> LispVal
Char (Char -> LispVal) -> Char -> LispVal
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
s2)]
charCIBoolBinop Char -> Char -> Bool
_ [LispVal
badType] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"character character" LispVal
badType
charCIBoolBinop Char -> Char -> Bool
_ [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList

-- | Append all given strings together into a single string
--
--   Arguments:
--
--   * String (one or more) - String(s) to concatenate
--
--   Returns: String - all given strings appended together as a single string
--
stringAppend :: [LispVal] -> IOThrowsError LispVal
stringAppend :: [LispVal] -> IOThrowsError LispVal
stringAppend (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
lvs) = do
  LispVal
s <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  [LispVal] -> IOThrowsError LispVal
stringAppend (LispVal
s LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
lvs)
stringAppend [(String FilePath
s)] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String FilePath
s -- Needed for "last" string value
stringAppend (String FilePath
st : [LispVal]
sts) = do
  LispVal
rest <- [LispVal] -> IOThrowsError LispVal
stringAppend [LispVal]
sts
  case LispVal
rest of
    String FilePath
s -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath
st FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s
    LispVal
other -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" LispVal
other
stringAppend [] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String FilePath
""
stringAppend [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" LispVal
badType
stringAppend [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Convert given string to a number
--
--   Arguments:
--
--   * String - String to convert
--
--   * Number (optional) - Number base to convert from, defaults to base 10 (decimal)
--
--   Returns: Numeric type, actual type will depend upon given string
--
stringToNumber :: [LispVal] -> IOThrowsError LispVal
stringToNumber :: [LispVal] -> IOThrowsError LispVal
stringToNumber (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
lvs) = do
  LispVal
s <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  [LispVal] -> IOThrowsError LispVal
stringToNumber (LispVal
s LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
lvs)
stringToNumber [(String FilePath
s)] = do
  LispVal
result <- ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> ThrowsError LispVal
readExpr FilePath
s
  case LispVal
result of
    n :: LispVal
n@(Number Integer
_) -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
n
    n :: LispVal
n@(Rational Rational
_) -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
n
    n :: LispVal
n@(Float Double
_) -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
n
    n :: LispVal
n@(Complex Complex Double
_) -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
n
    LispVal
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
stringToNumber [(String FilePath
s), Number Integer
radix] = do
  case Integer
radix of
    Integer
2 -> [LispVal] -> IOThrowsError LispVal
stringToNumber [FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath
"#b" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s]
    Integer
8 -> [LispVal] -> IOThrowsError LispVal
stringToNumber [FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath
"#o" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s]
    Integer
10 -> [LispVal] -> IOThrowsError LispVal
stringToNumber [FilePath -> LispVal
String FilePath
s]
    Integer
16 -> [LispVal] -> IOThrowsError LispVal
stringToNumber [FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ FilePath
"#x" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s]
    Integer
_ -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispError
Default (FilePath -> LispError) -> FilePath -> LispError
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid radix: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
radix
stringToNumber [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" LispVal
badType
stringToNumber [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- | Convert the given string to a list of chars
--
--   Arguments:
--
--   * String - string to deconstruct
--
--   Returns: List - list of characters
--
stringToList :: [LispVal] -> IOThrowsError LispVal
stringToList :: [LispVal] -> IOThrowsError LispVal
stringToList (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
ps) = do
    LispVal
p' <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p 
    [LispVal] -> IOThrowsError LispVal
stringToList (LispVal
p' LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ps)
stringToList [(String FilePath
s)] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ (Char -> LispVal) -> FilePath -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map Char -> LispVal
Char FilePath
s
stringToList [String FilePath
s, Number Integer
start] = 
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ (Char -> LispVal) -> FilePath -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map Char -> LispVal
Char (FilePath -> [LispVal]) -> FilePath -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Integer -> FilePath -> FilePath
forall a. Integer -> [a] -> [a]
trimStart Integer
start FilePath
s
stringToList [String FilePath
s, Number Integer
start, Number Integer
end] = 
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ (Char -> LispVal) -> FilePath -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map Char -> LispVal
Char (FilePath -> [LispVal]) -> FilePath -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> FilePath -> FilePath
forall a. Integer -> Integer -> [a] -> [a]
trimStartEnd Integer
start Integer
end FilePath
s
stringToList [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" LispVal
badType
stringToList [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
badArgList

-- |Utility function to trim from the start of a list
trimStart :: Integer -> [a] -> [a]
trimStart :: Integer -> [a] -> [a]
trimStart Integer
start = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
start)

-- |Utility function to trim from start/end of a list
trimStartEnd :: Integer -> Integer -> [a] -> [a]
trimStartEnd :: Integer -> Integer -> [a] -> [a]
trimStartEnd Integer
start Integer
end [a]
ls = 
  Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
end Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
start) [a]
ls

-- | Convert the given list of characters to a string
--
--   Arguments:
--
--   * List - list of chars to convert
--
--   Returns: String - Resulting string
--
listToString :: [LispVal] -> IOThrowsError LispVal
listToString :: [LispVal] -> IOThrowsError LispVal
listToString [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
listToString
listToString [(List [])] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String FilePath
""
listToString [(List [LispVal]
l)] = ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
buildString [LispVal]
l
listToString [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"list" LispVal
badType
listToString [] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
listToString args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- | Convert a string to a vector
--
--   Arguments
--
--   * String
--
--   Returns: Vector
stringToVector :: [LispVal] -> IOThrowsError LispVal
stringToVector :: [LispVal] -> IOThrowsError LispVal
stringToVector [LispVal]
args = do
    List [LispVal]
l <- [LispVal] -> IOThrowsError LispVal
stringToList [LispVal]
args
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [LispVal]
l

-- | Convert a vector to a string
--
--   Arguments
--
--   * Vector
--
--   Returns: String
vectorToString :: [LispVal] -> IOThrowsError LispVal
vectorToString :: [LispVal] -> IOThrowsError LispVal
vectorToString (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
ps) = do
    LispVal
p' <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
    [LispVal] -> IOThrowsError LispVal
vectorToString (LispVal
p' LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ps)
vectorToString [(Vector Array Int LispVal
v)] = do
    let l :: [LispVal]
l = Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v
    case [LispVal]
l of
        [] -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String FilePath
""
        [LispVal]
_ -> ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
buildString [LispVal]
l
vectorToString [Vector Array Int LispVal
v, Number Integer
start] = do
    [LispVal] -> IOThrowsError LispVal
listToString [[LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> [LispVal] -> [LispVal]
forall a. Integer -> [a] -> [a]
trimStart Integer
start (Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v)]
vectorToString [Vector Array Int LispVal
v, Number Integer
start, Number Integer
end] = do
    [LispVal] -> IOThrowsError LispVal
listToString [[LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> [LispVal] -> [LispVal]
forall a. Integer -> Integer -> [a] -> [a]
trimStartEnd Integer
start Integer
end (Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v)]
vectorToString [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"vector" LispVal
badType
vectorToString [] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
vectorToString args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- | Create a copy of the given string
--
--   Arguments:
--
--   * String - String to copy
--
--   Returns: String - New copy of the given string
--
stringCopy :: [LispVal] -> IOThrowsError LispVal
stringCopy :: [LispVal] -> IOThrowsError LispVal
stringCopy (p :: LispVal
p@(Pointer FilePath
_ Env
_) : [LispVal]
args) = do
    LispVal
s <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p 
    [LispVal] -> IOThrowsError LispVal
stringCopy (LispVal
s LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
args)
stringCopy [String FilePath
s] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String FilePath
s
stringCopy [String FilePath
s, Number Integer
start] = do
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> FilePath -> FilePath
forall a. Integer -> [a] -> [a]
trimStart Integer
start FilePath
s
stringCopy [String FilePath
s, Number Integer
start, Number Integer
end] = do
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String (FilePath -> LispVal) -> FilePath -> LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> FilePath -> FilePath
forall a. Integer -> Integer -> [a] -> [a]
trimStartEnd Integer
start Integer
end FilePath
s
stringCopy [LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" LispVal
badType
stringCopy [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList

-- | Determine if given object is an improper list
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if improper list, False otherwise
--
isDottedList :: [LispVal] -> IOThrowsError LispVal
isDottedList :: [LispVal] -> IOThrowsError LispVal
isDottedList ([p :: LispVal
p@(Pointer FilePath
_ Env
_)]) = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isDottedList
isDottedList ([DottedList [LispVal]
_ LispVal
_]) = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
-- Must include lists as well since they are made up of /chains/ of pairs
isDottedList ([List []]) = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
isDottedList ([List [LispVal]
_]) = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isDottedList [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if given object is a procedure
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if procedure, False otherwise
--
isProcedure :: [LispVal] -> ThrowsError LispVal
isProcedure :: [LispVal] -> ThrowsError LispVal
isProcedure ([Continuation {}]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isProcedure ([PrimitiveFunc [LispVal] -> ThrowsError LispVal
_]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isProcedure ([Func {}]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isProcedure ([HFunc {}]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isProcedure ([IOFunc [LispVal] -> IOThrowsError LispVal
_]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isProcedure ([EvalFunc [LispVal] -> IOThrowsError LispVal
_]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isProcedure ([CustFunc [LispVal] -> IOThrowsError LispVal
_]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isProcedure [LispVal]
_ = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if given object is a vector
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if vector, False otherwise
--
isVector :: LispVal -> IOThrowsError LispVal
isVector :: LispVal -> IOThrowsError LispVal
isVector p :: LispVal
p@(Pointer FilePath
_ Env
_) = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> IOThrowsError LispVal
isVector
isVector (Vector Array Int LispVal
vs) = do
    case Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
vs of
        -- Special exception for record types
        ((Atom FilePath
"  record-marker  ") : [LispVal]
_) -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
        [LispVal]
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isVector LispVal
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if given object is a record
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if record, False otherwise
--
isRecord :: LispVal -> IOThrowsError LispVal
isRecord :: LispVal -> IOThrowsError LispVal
isRecord p :: LispVal
p@(Pointer FilePath
_ Env
_) = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> IOThrowsError LispVal
isRecord
isRecord (Vector Array Int LispVal
vs) = do
    case (Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
vs) of
        -- Special exception for record types
        ((Atom FilePath
"  record-marker  ") : [LispVal]
_) -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
        [LispVal]
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
isRecord LispVal
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if given object is a bytevector
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if bytevector, False otherwise
--
isByteVector :: LispVal -> IOThrowsError LispVal
isByteVector :: LispVal -> IOThrowsError LispVal
isByteVector p :: LispVal
p@(Pointer FilePath
_ Env
_) = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> IOThrowsError LispVal
isVector
isByteVector (ByteVector ByteString
_) = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isByteVector LispVal
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if given object is a list
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if list, False otherwise
--
isList :: LispVal -> IOThrowsError LispVal
isList :: LispVal -> IOThrowsError LispVal
isList p :: LispVal
p@(Pointer FilePath
_ Env
_) = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> IOThrowsError LispVal
isList
isList (List [LispVal]
_) = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isList LispVal
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if given object is the null list
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if null list, False otherwise
--
isNull :: [LispVal] -> IOThrowsError LispVal
isNull :: [LispVal] -> IOThrowsError LispVal
isNull ([p :: LispVal
p@(Pointer FilePath
_ Env
_)]) = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isNull
isNull ([List []]) = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isNull [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if given object is the EOF marker
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if EOF, False otherwise
--
isEOFObject :: [LispVal] -> ThrowsError LispVal
isEOFObject :: [LispVal] -> ThrowsError LispVal
isEOFObject ([LispVal
EOF]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isEOFObject [LispVal]
_ = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Return the EOF object
eofObject :: [LispVal] -> ThrowsError LispVal
eofObject :: [LispVal] -> ThrowsError LispVal
eofObject [LispVal]
_ = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal
EOF

-- | Determine if given object is a symbol
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if a symbol, False otherwise
--
isSymbol :: [LispVal] -> ThrowsError LispVal
isSymbol :: [LispVal] -> ThrowsError LispVal
isSymbol ([Atom FilePath
_]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isSymbol [LispVal]
_ = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Convert the given symbol to a string
--
--   Arguments:
--
--   * Atom - Symbol to convert
--
--   Returns: String
--
symbol2String :: [LispVal] -> ThrowsError LispVal
symbol2String :: [LispVal] -> ThrowsError LispVal
symbol2String ([Atom FilePath
a]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
String FilePath
a
symbol2String [LispVal
notAtom] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"symbol" LispVal
notAtom
symbol2String [] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
symbol2String args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- | Convert a string to a symbol
--
--   Arguments:
--
--   * String (or pointer) - String to convert
--
--   Returns: Atom
--
string2Symbol :: [LispVal] -> IOThrowsError LispVal
string2Symbol :: [LispVal] -> IOThrowsError LispVal
string2Symbol ([p :: LispVal
p@(Pointer FilePath
_ Env
_)]) = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
string2Symbol
string2Symbol ([String FilePath
s]) = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal
Atom FilePath
s
string2Symbol [] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
string2Symbol [LispVal
notString] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" LispVal
notString
string2Symbol args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- | Convert a character to uppercase
--
--   Arguments:
--
--   * Char
--
--   Returns: Char - Character in uppercase
--
charUpper :: [LispVal] -> ThrowsError LispVal
charUpper :: [LispVal] -> ThrowsError LispVal
charUpper [Char Char
c] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char (Char -> LispVal) -> Char -> LispVal
forall a b. (a -> b) -> a -> b
$ Char -> Char
toUpper Char
c
charUpper [LispVal
notChar] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"char" LispVal
notChar
charUpper [LispVal]
args = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- | Convert a character to lowercase
--
--   Arguments:
--
--   * Char
--
--   Returns: Char - Character in lowercase
--
charLower :: [LispVal] -> ThrowsError LispVal
charLower :: [LispVal] -> ThrowsError LispVal
charLower [Char Char
c] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char (Char -> LispVal) -> Char -> LispVal
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
c
charLower [LispVal
notChar] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"char" LispVal
notChar
charLower [LispVal]
args = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- | Return integer value of a char digit
--
--   Arguments
--
--   * Char
--
--   Returns: Number, or False
charDigitValue :: [LispVal] -> ThrowsError LispVal
charDigitValue :: [LispVal] -> ThrowsError LispVal
charDigitValue [Char Char
c] = do
    -- This is not really good enough, since unicode chars
    -- are supposed to be processed, and r7rs does not
    -- spec hex chars, but it is a decent start for now...
    if Char -> Bool
isHexDigit Char
c
       then LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Char -> Int
digitToInt Char
c
       else LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
charDigitValue [LispVal
notChar] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"char" LispVal
notChar
charDigitValue [LispVal]
args = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- | Convert from a charater to an integer
--
--   Arguments:
--
--   * Char
--
--   Returns: Number
--
char2Int :: [LispVal] -> ThrowsError LispVal
char2Int :: [LispVal] -> ThrowsError LispVal
char2Int [Char Char
c] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c 
char2Int [LispVal
notChar] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"char" LispVal
notChar
char2Int [LispVal]
args = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- | Convert from an integer to a character
--
--   Arguments:
--
--   * Number
--
--   Returns: Char
--
int2Char :: [LispVal] -> ThrowsError LispVal
int2Char :: [LispVal] -> ThrowsError LispVal
int2Char [Number Integer
n] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char (Char -> LispVal) -> Char -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n 
int2Char [LispVal
notInt] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"integer" LispVal
notInt
int2Char [LispVal]
args = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Determine if given character satisfies the given predicate
charPredicate :: (Char -> Bool) -> [LispVal] -> ThrowsError LispVal
charPredicate :: (Char -> Bool) -> [LispVal] -> ThrowsError LispVal
charPredicate Char -> Bool
cpred ([Char Char
c]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Char -> Bool
cpred Char
c 
charPredicate Char -> Bool
_ [LispVal]
_ = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if the given value is a character
--
--   Arguments:
--
--   * LispVal to check
--
--   Returns: Bool - True if the argument is a character, False otherwise
--
isChar :: [LispVal] -> ThrowsError LispVal
isChar :: [LispVal] -> ThrowsError LispVal
isChar ([Char Char
_]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isChar [LispVal]
_ = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if the given value is a string
--
--   Arguments:
--
--   * LispVal to check
--
--   Returns: Bool - True if the argument is a string, False otherwise
--
isString :: [LispVal] -> IOThrowsError LispVal
isString :: [LispVal] -> IOThrowsError LispVal
isString [p :: LispVal
p@(Pointer FilePath
_ Env
_)] = LispVal -> IOThrowsError LispVal
derefPtr LispVal
p IOThrowsError LispVal
-> (LispVal -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> ExceptT LispError IO [LispVal]
box ExceptT LispError IO [LispVal]
-> ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LispVal] -> IOThrowsError LispVal
isString
isString ([String FilePath
_]) = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isString [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if the given value is a boolean
--
--   Arguments:
--
--   * LispVal to check
--
--   Returns: Bool - True if the argument is a boolean, False otherwise
--
isBoolean :: [LispVal] -> ThrowsError LispVal
isBoolean :: [LispVal] -> ThrowsError LispVal
isBoolean ([Bool Bool
_]) = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isBoolean [LispVal]
_ = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if multiple boolean values are the same
--
--   Arguments
--
--   * A list of Bool values
--
--   Returns: True if the list contains booleans that are the same, False otherwise
isBooleanEq :: Monad m => [LispVal] -> m LispVal
isBooleanEq :: [LispVal] -> m LispVal
isBooleanEq (Bool Bool
a : Bool Bool
b : [LispVal]
bs)
    | Bool
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b = [LispVal] -> m LispVal
forall (m :: * -> *). Monad m => [LispVal] -> m LispVal
isBooleanEq (Bool -> LispVal
Bool Bool
b LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
bs)
    | Bool
otherwise = LispVal -> m LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> m LispVal) -> LispVal -> m LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
isBooleanEq [Bool Bool
_] = LispVal -> m LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> m LispVal) -> LispVal -> m LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isBooleanEq [LispVal]
_ = LispVal -> m LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> m LispVal) -> LispVal -> m LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- | Determine if multiple symbols values are the same
--
--   Arguments
--
--   * A list of Atom values
--
--   Returns: True if all of the symbols are the same, False otherwise
isSymbolEq :: Monad m => [LispVal] -> m LispVal
isSymbolEq :: [LispVal] -> m LispVal
isSymbolEq (Atom FilePath
a : Atom FilePath
b : [LispVal]
bs)
    | FilePath
a FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
b = [LispVal] -> m LispVal
forall (m :: * -> *). Monad m => [LispVal] -> m LispVal
isSymbolEq (FilePath -> LispVal
Atom FilePath
b LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
bs)
    | Bool
otherwise = LispVal -> m LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> m LispVal) -> LispVal -> m LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
isSymbolEq [Atom FilePath
_] = LispVal -> m LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> m LispVal) -> LispVal -> m LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
isSymbolEq [LispVal]
_ = LispVal -> m LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> m LispVal) -> LispVal -> m LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- |Utility type for unpackEquals
data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a)

-- |Determine if two lispval's are equal
unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals :: LispVal -> LispVal -> Unpacker -> Either LispError Bool
unpackEquals LispVal
arg1 LispVal
arg2 (AnyUnpacker LispVal -> ThrowsError a
unpacker) =
  do a
unpacked1 <- LispVal -> ThrowsError a
unpacker LispVal
arg1
     a
unpacked2 <- LispVal -> ThrowsError a
unpacker LispVal
arg2
     Bool -> Either LispError Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either LispError Bool) -> Bool -> Either LispError Bool
forall a b. (a -> b) -> a -> b
$ a
unpacked1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
unpacked2
  Either LispError Bool
-> (LispError -> Either LispError Bool) -> Either LispError Bool
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (Either LispError Bool -> LispError -> Either LispError Bool
forall a b. a -> b -> a
const (Either LispError Bool -> LispError -> Either LispError Bool)
-> Either LispError Bool -> LispError -> Either LispError Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Either LispError Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

-- |Helper function to perform a binary logic operation on two LispVal arguments.
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop :: (LispVal -> ThrowsError a)
-> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop LispVal -> ThrowsError a
unpacker a -> a -> Bool
op [LispVal]
args = if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
                             then LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args
                             else do
                                 Bool
result <- LispVal -> [LispVal] -> Either LispError Bool
cmp ([LispVal] -> LispVal
forall a. [a] -> a
head [LispVal]
args) ([LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
args)
                                 LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
result
 where 
    cmp :: LispVal -> [LispVal] -> Either LispError Bool
cmp LispVal
b1 (LispVal
b2 : [LispVal]
bs) = do
      a
b1' <- LispVal -> ThrowsError a
unpacker LispVal
b1
      a
b2' <- LispVal -> ThrowsError a
unpacker LispVal
b2
      let result :: Bool
result = a -> a -> Bool
op a
b1' a
b2'
      if Bool
result
         then LispVal -> [LispVal] -> Either LispError Bool
cmp LispVal
b2 [LispVal]
bs
         else Bool -> Either LispError Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    cmp LispVal
_ [LispVal]
_ = Bool -> Either LispError Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       

-- |Perform the given function against a single LispVal argument
unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
unaryOp :: (LispVal -> ThrowsError LispVal)
-> [LispVal] -> ThrowsError LispVal
unaryOp LispVal -> ThrowsError LispVal
f [LispVal
v] = LispVal -> ThrowsError LispVal
f LispVal
v
unaryOp LispVal -> ThrowsError LispVal
_ [] = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
unaryOp LispVal -> ThrowsError LispVal
_ args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Same as unaryOp but in the IO monad
unaryOp' :: (LispVal -> IOThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal
unaryOp' :: (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
unaryOp' LispVal -> IOThrowsError LispVal
f [LispVal
v] = LispVal -> IOThrowsError LispVal
f LispVal
v
unaryOp' LispVal -> IOThrowsError LispVal
_ [] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
unaryOp' LispVal -> IOThrowsError LispVal
_ args :: [LispVal]
args@(LispVal
_ : [LispVal]
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args

-- |Perform boolBinop against two string arguments
strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> IOThrowsError LispVal
strBoolBinop :: (FilePath -> FilePath -> Bool)
-> [LispVal] -> IOThrowsError LispVal
strBoolBinop FilePath -> FilePath -> Bool
fnc [LispVal]
args = do
  List [LispVal]
dargs <- LispVal -> IOThrowsError LispVal
recDerefPtrs (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args -- Deref any pointers
  ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ (LispVal -> ThrowsError FilePath)
-> (FilePath -> FilePath -> Bool)
-> [LispVal]
-> ThrowsError LispVal
forall a.
(LispVal -> ThrowsError a)
-> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop LispVal -> ThrowsError FilePath
unpackStr FilePath -> FilePath -> Bool
fnc [LispVal]
dargs

-- |Perform boolBinop against two char arguments
charBoolBinop :: (Char -> Char -> Bool)
              -> [LispVal] -> ThrowsError LispVal
charBoolBinop :: (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal
charBoolBinop = (LispVal -> ThrowsError Char)
-> (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal
forall a.
(LispVal -> ThrowsError a)
-> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop LispVal -> ThrowsError Char
unpackChar

-- |Perform boolBinop against two boolean arguments
boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBoolBinop = (LispVal -> Either LispError Bool)
-> (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal
forall a.
(LispVal -> ThrowsError a)
-> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop LispVal -> Either LispError Bool
unpackBool

-- | Unpack a LispVal char
--
--   Arguments:
--
--   * Char - Character to unpack
--
unpackChar :: LispVal -> ThrowsError Char
unpackChar :: LispVal -> ThrowsError Char
unpackChar (Char Char
c) = Char -> ThrowsError Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
unpackChar LispVal
notChar = LispError -> ThrowsError Char
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError Char) -> LispError -> ThrowsError Char
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"character" LispVal
notChar

-- | Unpack a LispVal String
--
--   Arguments:
--
--   * String - String to unpack
--
unpackStr :: LispVal -> ThrowsError String
unpackStr :: LispVal -> ThrowsError FilePath
unpackStr (String FilePath
s) = FilePath -> ThrowsError FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
s
unpackStr (Number Integer
s) = FilePath -> ThrowsError FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> ThrowsError FilePath)
-> FilePath -> ThrowsError FilePath
forall a b. (a -> b) -> a -> b
$ Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
s
unpackStr (Bool Bool
s) = FilePath -> ThrowsError FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> ThrowsError FilePath)
-> FilePath -> ThrowsError FilePath
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath
forall a. Show a => a -> FilePath
show Bool
s
unpackStr LispVal
notString = LispError -> ThrowsError FilePath
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError FilePath)
-> LispError -> ThrowsError FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" LispVal
notString

-- | Unpack a LispVal boolean
--
--   Arguments:
--
--   * Bool - Boolean to unpack
--
unpackBool :: LispVal -> ThrowsError Bool
unpackBool :: LispVal -> Either LispError Bool
unpackBool (Bool Bool
b) = Bool -> Either LispError Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
unpackBool LispVal
notBool = LispError -> Either LispError Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> Either LispError Bool)
-> LispError -> Either LispError Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"boolean" LispVal
notBool

-- | Return the current time, in seconds
--
--   Arguments: (None)
--
--   Returns: Current UNIX timestamp in seconds
currentTimestamp :: [LispVal] -> IOThrowsError LispVal
currentTimestamp :: [LispVal] -> IOThrowsError LispVal
currentTimestamp [LispVal]
_ = do
    POSIXTime
cur <- IO POSIXTime -> ExceptT LispError IO POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO POSIXTime -> ExceptT LispError IO POSIXTime)
-> IO POSIXTime -> ExceptT LispError IO POSIXTime
forall a b. (a -> b) -> a -> b
$ IO POSIXTime
Data.Time.Clock.POSIX.getPOSIXTime
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Double -> LispVal
Float (Double -> LispVal) -> Double -> LispVal
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac POSIXTime
cur

-- | Execute a system command on the underlying OS.
--
--   Arguments:
--
--   * String - Command to execute
--
--   Returns: Integer - program return status
--
system :: [LispVal] -> IOThrowsError LispVal
system :: [LispVal] -> IOThrowsError LispVal
system [String FilePath
cmd] = do
    ExitCode
result <- IO ExitCode -> ExceptT LispError IO ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> ExceptT LispError IO ExitCode)
-> IO ExitCode -> ExceptT LispError IO ExitCode
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ExitCode
System.Process.system FilePath
cmd
    case ExitCode
result of
        ExitCode
ExitSuccess -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number Integer
0
        ExitFailure Int
code -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
code
system [LispVal]
err = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ FilePath -> LispVal -> LispError
TypeMismatch FilePath
"string" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
err

-- | Retrieve all environment variables
--
--   Arguments: (none)
--
--   Returns: List - list of key/value alists
--
getEnvVars :: [LispVal] -> IOThrowsError LispVal
getEnvVars :: [LispVal] -> IOThrowsError LispVal
getEnvVars [LispVal]
_ = do
    [(FilePath, FilePath)]
vars <- IO [(FilePath, FilePath)]
-> ExceptT LispError IO [(FilePath, FilePath)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(FilePath, FilePath)]
 -> ExceptT LispError IO [(FilePath, FilePath)])
-> IO [(FilePath, FilePath)]
-> ExceptT LispError IO [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ IO [(FilePath, FilePath)]
SE.getEnvironment
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> LispVal)
-> [(FilePath, FilePath)] -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map (\ (FilePath
k, FilePath
v) -> [LispVal] -> LispVal -> LispVal
DottedList [FilePath -> LispVal
String FilePath
k] (FilePath -> LispVal
String FilePath
v)) [(FilePath, FilePath)]
vars

-- FUTURE (?):
-- systemRead :: [LispVal] -> IOThrowsError LispVal
-- systemRead ((String cmd) : args) = do
--   let args' = map conv args
--   result <- liftIO $ readProcess cmd args' ""
--   return $ String result
--  where
--    conv (String s) = s
--    conv _ = ""