{-# 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 
 , hashTblRef
 , 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
 --data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a)

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

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

 -- ** Utility functions
 , 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 
 , closePort
 , currentOutputPort 
 , currentInputPort 
 , isOutputPort 
 , isInputPort
 , isCharReady
 , readProc 
 , readCharProc 
 , writeProc 
 , writeCharProc
 , readContents
 , load
 , readAll
 , fileExists
 , deleteFile
 -- ** Symbol generation
 , gensym
 , _gensym
 -- ** Time
 , currentTimestamp
 -- ** System
 , system

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

#if __GLASGOW_HASKELL__ < 702
try' = try
#else
try' = tryIOError
#endif

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

-- |Open the given file
--
--   LispVal Arguments:
--
--   * String - filename
--
--   Returns: Port
--
makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
makePort mode [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= makePort mode
makePort _ [] = throwError $ NumArgs (Just 1) []
makePort _ args@(_ : _) = throwError $ NumArgs (Just 1) args

-- |Close the given port
--
--   Arguments:
--
--   * Port
--
--   Returns: Bool - True if the port was closed, false otherwise
--
closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort _ = return $ 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 _ = return $ Port stdin
-- |Return the current input port
--
--   LispVal Arguments: (None)
--
--   Returns: Port
--
currentOutputPort :: [LispVal] -> IOThrowsError LispVal
currentOutputPort _ = return $ Port stdout

-- |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 [Port port] = liftM Bool $ liftIO $ hIsReadable port
isInputPort _ = return $ 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 [Port port] = liftM Bool $ liftIO $ hIsWritable port
isOutputPort _ = return $ Bool False

-- |Determine if a character is ready on the port
--
--   LispVal Arguments:
--
--   * Port
--
--   Returns: Bool
--
isCharReady :: [LispVal] -> IOThrowsError LispVal
isCharReady [Port port] = do --liftM Bool $ liftIO $ hReady port
    result <- liftIO $ try' (liftIO $ hReady port)
    case result of
        Left e -> if isEOFError e
                     then return $ Bool False
                     else throwError $ Default "I/O error reading from port" -- FUTURE: ioError e
        Right _ -> return $ Bool True
isCharReady _ = return $ Bool False

-- |Read from the given port
--
--   LispVal Arguments:
--
--   * Port
--
--   Returns: LispVal
--
readProc :: [LispVal] -> IOThrowsError LispVal
readProc [] = readProc [Port stdin]
readProc [Port port] = do
    input <- liftIO $ try' (liftIO $ hGetLine port)
    case input of
        Left e -> if isEOFError e
                     then return $ EOF
                     else throwError $ Default "I/O error reading from port" -- FUTURE: ioError e
        Right inpStr -> do
            liftThrows $ readExpr inpStr
readProc args@(_ : _) = throwError $ BadSpecialForm "" $ List args

-- |Read character from port
--
--   LispVal Arguments:
--
--   * Port
--
--   Returns: Char
--
readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal
readCharProc func [] = readCharProc func [Port stdin]
readCharProc func [Port port] = do
    liftIO $ hSetBuffering port NoBuffering
    input <- liftIO $ try' (liftIO $ func port)
    liftIO $ hSetBuffering port LineBuffering
    case input of
        Left e -> if isEOFError e
                     then return $ EOF
                     else throwError $ Default "I/O error reading from port"
        Right inpChr -> do
            return $ Char inpChr
readCharProc _ args@(_ : _) = throwError $ BadSpecialForm "" $ List 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 func [obj] = do
    dobj <- recDerefPtrs obj -- Last opportunity to do this before writing
    writeProc func [dobj, Port stdout]
writeProc func [obj, Port port] = do
    dobj <- recDerefPtrs obj -- Last opportunity to do this before writing
    output <- liftIO $ try' (liftIO $ func port dobj)
    case output of
        Left _ -> throwError $ Default "I/O error writing to port"
        Right _ -> return $ Nil ""
writeProc _ other = if length other == 2
                     then throwError $ TypeMismatch "(value port)" $ List other
                     else throwError $ NumArgs (Just 2) 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 [obj] = writeCharProc [obj, Port stdout]
writeCharProc [obj@(Char _), Port port] = do
    output <- liftIO $ try' (liftIO $ (hPutStr port $ show obj))
    case output of
        Left _ -> throwError $ Default "I/O error writing to port"
        Right _ -> return $ Nil ""
writeCharProc other = if length other == 2
                     then throwError $ TypeMismatch "(character port)" $ List other
                     else throwError $ NumArgs (Just 2) 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 [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= fileExists
fileExists [String filename] = do
    exists <- liftIO $ doesFileExist filename
    return $ Bool exists
fileExists [] = throwError $ NumArgs (Just 1) []
fileExists args@(_ : _) = throwError $ NumArgs (Just 1) 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 [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= deleteFile
deleteFile [String filename] = do
    output <- liftIO $ try' (liftIO $ removeFile filename)
    case output of
        Left _ -> return $ Bool False
        Right _ -> return $ Bool True
deleteFile [] = throwError $ NumArgs (Just 1) []
deleteFile args@(_ : _) = throwError $ NumArgs (Just 1) 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 [String filename] = liftM String $ liftIO $ readFile filename
readContents [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= readContents
readContents [] = throwError $ NumArgs (Just 1) []
readContents args@(_ : _) = throwError $ NumArgs (Just 1) 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 filename = do
  result <- liftIO $ doesFileExist filename
  if result
     then do
        f <- liftIO $ readFile filename

        case lines f of
            -- Skip comment header for shell scripts
            -- TODO: this could be much more robust
            (('#':'!':'/' : _) : ls) -> liftThrows . readExprList $ unlines ls
            (('#':'!':' ':'/' : _) : ls) -> liftThrows . readExprList $ unlines ls
            _ -> (liftThrows . readExprList) f
     else throwError $ Default $ "File does not exist: " ++ 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 [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= readAll
readAll [String filename] = liftM List $ load filename
readAll [] = throwError $ NumArgs (Just 1) []
readAll args@(_ : _) = throwError $ NumArgs (Just 1) args

-- |Version of gensym that can be conveniently called from Haskell.
_gensym :: String -> IOThrowsError LispVal
_gensym prefix = do
    u <- liftIO $ newUnique
    return $ Atom $ prefix ++ (show $ Number $ toInteger $ hashUnique 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 [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= gensym
gensym [String prefix] = _gensym prefix
gensym [] = _gensym " g"
gensym args@(_ : _) = throwError $ NumArgs (Just 1) 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 [p@(Pointer _ _)] = derefPtr p >>= box >>= car
car [List (x : _)] = return x
car [DottedList (x : _) _] = return x
car [badArg] = throwError $ TypeMismatch "pair" badArg
car badArgList = throwError $ NumArgs (Just 1) 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 [p@(Pointer _ _)] = derefPtr p >>= box >>= cdr
cdr [List (_ : xs)] = return $ List xs
cdr [DottedList [_] x] = return x
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [badArg] = throwError $ TypeMismatch "pair" badArg
cdr badArgList = throwError $ NumArgs (Just 1) 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 [x, p@(Pointer _ _)] = do
  y <- derefPtr p
  cons [x, y]
cons [x1, List []] = return $ List [x1]
cons [x, List xs] = return $ List $ x : xs
cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast
cons [x1, x2] = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs (Just 2) badArgList

makeList :: [LispVal] -> ThrowsError LispVal
makeList [(Number n)] = makeList [Number n, List []]
makeList [(Number n), a] = do
  let l = replicate (fromInteger n) a
  return $ List l
makeList [badType] = throwError $ TypeMismatch "integer" badType
makeList badArgList = throwError $ NumArgs (Just 1) badArgList

listCopy :: [LispVal] -> IOThrowsError LispVal
listCopy [p@(Pointer _ _)] = do
  l <- derefPtr p
  listCopy [l]
listCopy [(List ls)] = return $ List ls
listCopy [badType] = return badType
listCopy badArgList = throwError $ NumArgs (Just 1) badArgList

vectorCopy :: [LispVal] -> IOThrowsError LispVal
vectorCopy (p@(Pointer _ _) : args) = do
  v <- derefPtr p
  vectorCopy (v : args)
vectorCopy [Vector vs] = do
    let l = elems vs
    return $ Vector $ listArray (0, length l - 1) l 
vectorCopy [Vector vs, Number start] = do
    let l = drop (fromInteger start) $ 
              elems vs
    return $ Vector $ listArray (0, length l - 1) l 
vectorCopy [Vector vs, Number start, Number end] = do
    let l = take (fromInteger $ end - start) $
              drop (fromInteger start) $ 
                elems vs
    return $ Vector $ listArray (0, length l - 1) l 
vectorCopy [badType] = return badType
vectorCopy badArgList = throwError $ NumArgs (Just 1) badArgList

-- | Use pointer equality to compare two objects if possible, otherwise
--   fall back to the normal equality comparison
eq :: [LispVal] -> IOThrowsError LispVal
eq [(Pointer pA envA), (Pointer pB envB)] = do
    if pA == pB 
       then do
         refA <- getNamespacedRef envA varNamespace pA
         refB <- getNamespacedRef envB varNamespace pB
         return $ Bool $ refA == refB
       else return $ Bool False
eq args = recDerefToFnc eqv args

-- | Recursively compare two LispVals for equality
--
--   Arguments:
--
--   * LispVal
--
--   * LispVal
--
--   Returns: Bool - True if equal, false otherwise
--
equal :: [LispVal] -> ThrowsError LispVal
equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)]
equal [l1@(List _), l2@(List _)] = eqvList equal [l1, l2]
equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]]
equal [arg1, arg2] = do
  primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
                     [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
  eqvEquals <- eqv [arg1, arg2]
  return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs (Just 2) 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 [(Number n)] = makeVector [Number n, List []]
makeVector [(Number n), a] = do
  let l = replicate (fromInteger n) a
  return $ Vector $ (listArray (0, length l - 1)) l
makeVector [badType] = throwError $ TypeMismatch "integer" badType
makeVector badArgList = throwError $ NumArgs (Just 1) badArgList

-- | Create a vector from the given lisp values
--
--   Arguments:
--
--   * LispVal (s)
--
--   Returns: Vector
--
buildVector :: [LispVal] -> ThrowsError LispVal
buildVector lst@(o : os) = do
  return $ Vector $ (listArray (0, length lst - 1)) lst
buildVector badArgList = throwError $ NumArgs (Just 1) badArgList

-- | Determine the length of the given vector
--
--   Arguments:
--
--   * Vector
--
--   Returns: Number
--
vectorLength :: [LispVal] -> ThrowsError LispVal
vectorLength [(Vector v)] = return $ Number $ toInteger $ length (elems v)
vectorLength [badType] = throwError $ TypeMismatch "vector" badType
vectorLength badArgList = throwError $ NumArgs (Just 1) 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 [(Vector v), (Number n)] = do
    let len = toInteger $ (length $ elems v) - 1
    if n > len || n < 0
       then throwError $ Default "Invalid index"
       else return $ v ! (fromInteger n)
vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType
vectorRef badArgList = throwError $ NumArgs (Just 2) badArgList

-- | Convert the given vector to a list
--
--   Arguments:
--
--   * Vector
--
--   Returns: List
--
vectorToList :: [LispVal] -> ThrowsError LispVal
vectorToList [(Vector v)] = return $ List $ elems v
vectorToList [badType] = throwError $ TypeMismatch "vector" badType
vectorToList badArgList = throwError $ NumArgs (Just 1) badArgList

-- | Convert the given list to a vector
--
--   Arguments:
--
--   * List to convert
--
--   Returns: Vector
--
listToVector :: [LispVal] -> ThrowsError LispVal
listToVector [(List l)] = return $ Vector $ (listArray (0, length l - 1)) l
listToVector [badType] = throwError $ TypeMismatch "list" badType
listToVector badArgList = throwError $ NumArgs (Just 1) 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 [(Number n)] = do
  let ls = replicate (fromInteger n) (0 :: Word8)
  return $ ByteVector $ BS.pack ls
makeByteVector [Number n, Number byte] = do
  let ls = replicate (fromInteger n) (fromInteger byte :: Word8)
  return $ ByteVector $ BS.pack ls
makeByteVector [badType] = throwError $ TypeMismatch "integer" badType
makeByteVector badArgList = throwError $ NumArgs (Just 2) 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 bs = do
 return $ ByteVector $ BS.pack $ map conv bs
 where 
   conv (Number n) = fromInteger n :: Word8
   conv n = 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 (p@(Pointer _ _) : lvs) = do
    bv <- derefPtr p
    byteVectorCopy (bv : lvs)
byteVectorCopy [ByteVector bv] = do
    return $ ByteVector $ BS.copy
        bv
byteVectorCopy [ByteVector bv, Number start] = do
    return $ ByteVector $ BS.drop 
        (fromInteger start)
        bv
byteVectorCopy [ByteVector bv, Number start, Number end] = do
    return $ ByteVector $ BS.take 
        (fromInteger $ end - start)
        (BS.drop 
            (fromInteger start)
            bv)
byteVectorCopy [badType] = throwError $ TypeMismatch "bytevector" badType
byteVectorCopy badArgList = throwError $ NumArgs (Just 1) 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 bs = do
    let acc = BS.pack []
        conv :: LispVal -> IOThrowsError BSU.ByteString
        conv p@(Pointer _ _) = do
          bs <- derefPtr p
          conv bs
        conv (ByteVector bs) = return bs
        conv x = return BS.empty
    bs' <- mapM conv bs
    return $ ByteVector $ BS.concat bs'
-- TODO: error handling

-- | Find the length of a bytevector
--
--   Arguments:
--
--   * ByteVector
--
--   Returns: Number - Length of the given bytevector
--
byteVectorLength :: [LispVal] -> IOThrowsError LispVal
byteVectorLength [p@(Pointer _ _)] = derefPtr p >>= box >>= byteVectorLength
byteVectorLength [(ByteVector bv)] = return $ Number $ toInteger $ BS.length bv
byteVectorLength [badType] = throwError $ TypeMismatch "bytevector" badType
byteVectorLength badArgList = throwError $ NumArgs (Just 1) 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 (p@(Pointer _ _) : lvs) = do
    bv <- derefPtr p
    byteVectorRef (bv : lvs)
byteVectorRef [(ByteVector bv), (Number n)] = do
    let len = toInteger $ (BS.length bv) - 1
    if n > len || n < 0
       then throwError $ Default "Invalid index"
       else return $ Number $ toInteger $ BS.index bv (fromInteger n)
byteVectorRef [badType] = throwError $ TypeMismatch "bytevector integer" badType
byteVectorRef badArgList = throwError $ NumArgs (Just 2) badArgList

-- | Convert a bytevector to a string
--
--   Arguments:
--
--   * ByteVector
--
--   Returns: String
--
byteVectorUtf2Str :: [LispVal] -> IOThrowsError LispVal
byteVectorUtf2Str [p@(Pointer _ _)] = derefPtr p >>= box >>= byteVectorUtf2Str
byteVectorUtf2Str [(ByteVector bv)] = do
    return $ String $ BSU.toString bv 
-- TODO: need to support other overloads of this function
byteVectorUtf2Str [badType] = throwError $ TypeMismatch "bytevector" badType
byteVectorUtf2Str badArgList = throwError $ NumArgs (Just 1) badArgList

-- | Convert a string to a bytevector
--
--   Arguments:
--
--   * String
--
--   Returns: ByteVector
--
byteVectorStr2Utf :: [LispVal] -> IOThrowsError LispVal
byteVectorStr2Utf [p@(Pointer _ _)] = derefPtr p >>= box >>= byteVectorStr2Utf
byteVectorStr2Utf [(String s)] = do
    return $ ByteVector $ BSU.fromString s
-- TODO: need to support other overloads of this function
byteVectorStr2Utf [badType] = throwError $ TypeMismatch "string" badType
byteVectorStr2Utf badArgList = throwError $ NumArgs (Just 1) 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 fnc [p@(Pointer _ _)] = do
  val <- derefPtr p
  liftThrows $ fnc [val]
wrapHashTbl fnc (p@(Pointer _ _) : key : args) = do
  ht <- derefPtr p
  k <- recDerefPtrs key
  liftThrows $ fnc (ht : k : args)
wrapHashTbl fnc args = liftThrows $ fnc 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 fnc [p@(Pointer _ _)] = do
  val <- derefPtr p
  liftThrows $ fnc [val]
wrapLeadObj fnc (p@(Pointer _ _) : args) = do
  obj <- derefPtr p
  liftThrows $ fnc (obj : args)
wrapLeadObj fnc args = liftThrows $ fnc args

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

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

-- | Create a new hashtable
--
--   Arguments: (None)
--
--   Returns: HashTable
--
hashTblMake :: [LispVal] -> ThrowsError LispVal
hashTblMake _ = return $ HashTable $ 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 [(HashTable _)] = return $ Bool True
isHashTbl _ = return $ 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 [(HashTable ht), key@(_)] = do
  case Data.Map.lookup key ht of
    Just _ -> return $ Bool True
    Nothing -> return $ Bool False
hashTblExists [] = throwError $ NumArgs (Just 2) []
hashTblExists args@(_ : _) = throwError $ NumArgs (Just 2) args

-- | Retrieve the value from the hashtable for the given key.
--   An error is thrown if the key is not found.
--
--   Arguments:
--
--   * HashTable to copy
--
--   * Object that is the key to query the table for
--
--   Returns: Object containing the key's value
--
hashTblRef :: [LispVal] -> ThrowsError LispVal
hashTblRef [(HashTable ht), key@(_)] = do
  case Data.Map.lookup key ht of
    Just val -> return val
    Nothing -> throwError $ BadSpecialForm "Hash table does not contain key" key
hashTblRef [(HashTable ht), key@(_), Func _ _ _ _] = do
  case Data.Map.lookup key ht of
    Just val -> return $ val
    Nothing -> throwError $ NotImplemented "thunk"
{- FUTURE: a thunk can optionally be specified, this drives definition of /default
Nothing -> apply thunk [] -}
hashTblRef [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblRef badArgList = throwError $ NumArgs (Just 2) badArgList

-- | Return the number of key/value associations in the hashtable
--
--   Arguments:
--
--   * HashTable
--
--   Returns: Number - number of associations
--
hashTblSize :: [LispVal] -> ThrowsError LispVal
hashTblSize [(HashTable ht)] = return $ Number $ toInteger $ Data.Map.size ht
hashTblSize [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblSize badArgList = throwError $ NumArgs (Just 1) 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 [(HashTable ht)] = do
  return $ List $ map (\ (k, v) -> List [k, v]) $ Data.Map.toList ht
hashTbl2List [badType] = throwError $ TypeMismatch "hash-table" badType
hashTbl2List badArgList = throwError $ NumArgs (Just 1) badArgList

-- | Create a list containing all keys in the hashtable
--
--   Arguments:
--
--   * HashTable
--
--   Returns: List containing the keys
--
hashTblKeys :: [LispVal] -> ThrowsError LispVal
hashTblKeys [(HashTable ht)] = do
  return $ List $ map (\ (k, _) -> k) $ Data.Map.toList ht
hashTblKeys [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblKeys badArgList = throwError $ NumArgs (Just 1) badArgList

-- | Create a list containing all values in the hashtable
--
--   Arguments:
--
--   * HashTable
--
--   Returns: List containing the values
--
hashTblValues :: [LispVal] -> ThrowsError LispVal
hashTblValues [(HashTable ht)] = do
  return $ List $ map (\ (_, v) -> v) $ Data.Map.toList ht
hashTblValues [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblValues badArgList = throwError $ NumArgs (Just 1) badArgList

-- | Create a new copy of a hashtable
--
--   Arguments:
--
--   * HashTable to copy
--
--   Returns: HashTable
--
hashTblCopy :: [LispVal] -> ThrowsError LispVal
hashTblCopy [(HashTable ht)] = do
  return $ HashTable $ Data.Map.fromList $ Data.Map.toList ht
hashTblCopy [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblCopy badArgList = throwError $ NumArgs (Just 1) 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 [(Char c)] = return $ String [c]
buildString (Char c : rest) = do
  cs <- buildString rest
  case cs of
    String s -> return $ String $ [c] ++ s
    badType -> throwError $ TypeMismatch "character" badType
buildString [badType] = throwError $ TypeMismatch "character" badType
buildString badArgList = throwError $ NumArgs (Just 1) 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 [(Number n)] = return $ doMakeString n ' ' ""
makeString [(Number n), (Char c)] = return $ doMakeString n c ""
makeString badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Helper function
doMakeString :: forall a . (Num a, Eq a) => a -> Char -> String -> LispVal
doMakeString n char s =
    if n == 0
       then String s
       else doMakeString (n - 1) char (s ++ [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 [p@(Pointer _ _)] = derefPtr p  >>= box >>= stringLength
stringLength [String s] = return $ Number $ foldr (const (+ 1)) 0 s -- Could probably do 'length s' instead...
stringLength [badType] = throwError $ TypeMismatch "string" badType
stringLength badArgList = throwError $ NumArgs (Just 1) 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 [p@(Pointer _ _), k@(Number _)] = do
    s <- derefPtr p 
    stringRef [s, k]
stringRef [(String s), (Number k)] = return $ Char $ s !! fromInteger k
stringRef [badType] = throwError $ TypeMismatch "string number" badType
stringRef badArgList = throwError $ NumArgs (Just 2) 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 (p@(Pointer _ _) : lvs) = do
  s <- derefPtr p
  substring (s : lvs)
substring [(String s), (Number start), (Number end)] =
  do let slength = fromInteger $ end - start
     let begin = fromInteger start
     return $ String $ (take slength . drop begin) s
substring [badType] = throwError $ TypeMismatch "string number number" badType
substring badArgList = throwError $ NumArgs (Just 3) 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 args = do
  List dargs <- recDerefPtrs $ List args
  case dargs of
    [(String str1), (String str2)] -> do
      if (length str1) /= (length str2)
         then return $ Bool False
         else return $ Bool $ ciCmp str1 str2 0
    [badType] -> throwError $ TypeMismatch "string string" badType
    badArgList -> throwError $ NumArgs (Just 2) badArgList
 where ciCmp s1 s2 idx = 
         if idx == (length s1)
            then True
            else if (toLower $ s1 !! idx) == (toLower $ s2 !! idx)
                    then ciCmp s1 s2 (idx + 1)
                    else False

-- |Helper function
stringCIBoolBinop :: ([Char] -> [Char] -> Bool) -> [LispVal] -> IOThrowsError LispVal
stringCIBoolBinop op args = do 
  List dargs <- recDerefPtrs $ List args -- Deref any pointers
  case dargs of
    [(String s1), (String s2)] ->
      liftThrows $ boolBinop unpackStr op [(String $ strToLower s1), (String $ strToLower s2)]
    [badType] -> throwError $ TypeMismatch "string string" badType
    badArgList -> throwError $ NumArgs (Just 2) badArgList
  where strToLower str = map (toLower) str

-- |Helper function
charCIBoolBinop :: (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal
charCIBoolBinop op [(Char s1), (Char s2)] = boolBinop unpackChar op [(Char $ toLower s1), (Char $ toLower s2)]
charCIBoolBinop _ [badType] = throwError $ TypeMismatch "character character" badType
charCIBoolBinop _ badArgList = throwError $ NumArgs (Just 2) 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 (p@(Pointer _ _) : lvs) = do
  s <- derefPtr p
  stringAppend (s : lvs)
stringAppend [(String s)] = return $ String s -- Needed for "last" string value
stringAppend (String st : sts) = do
  rest <- stringAppend sts
  case rest of
    String s -> return $ String $ st ++ s
    other -> throwError $ TypeMismatch "string" other
stringAppend [badType] = throwError $ TypeMismatch "string" badType
stringAppend badArgList = throwError $ NumArgs (Just 1) 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 (p@(Pointer _ _) : lvs) = do
  s <- derefPtr p
  stringToNumber (s : lvs)
stringToNumber [(String s)] = do
  result <- liftThrows $ readExpr s
  case result of
    n@(Number _) -> return n
    n@(Rational _) -> return n
    n@(Float _) -> return n
    n@(Complex _) -> return n
    _ -> return $ Bool False
stringToNumber [(String s), Number radix] = do
  case radix of
    2 -> stringToNumber [String $ "#b" ++ s]
    8 -> stringToNumber [String $ "#o" ++ s]
    10 -> stringToNumber [String s]
    16 -> stringToNumber [String $ "#x" ++ s]
    _ -> throwError $ Default $ "Invalid radix: " ++ show radix
stringToNumber [badType] = throwError $ TypeMismatch "string" badType
stringToNumber badArgList = throwError $ NumArgs (Just 1) 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 [p@(Pointer _ _)] = derefPtr p >>= box >>= stringToList
stringToList [(String s)] = return $ List $ map (Char) s
stringToList [badType] = throwError $ TypeMismatch "string" badType
stringToList badArgList = throwError $ NumArgs (Just 1) badArgList

-- | 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 [p@(Pointer _ _)] = derefPtr p >>= box >>= listToString
listToString [(List [])] = return $ String ""
listToString [(List l)] = liftThrows $ buildString l
listToString [badType] = throwError $ TypeMismatch "list" badType
listToString [] = throwError $ NumArgs (Just 1) []
listToString args@(_ : _) = throwError $ NumArgs (Just 1) args

stringToVector :: [LispVal] -> IOThrowsError LispVal
stringToVector args = do
    List l <- stringToList args
    return $ Vector $ listArray (0, length l - 1) l
vectorToString :: [LispVal] -> IOThrowsError LispVal
vectorToString [p@(Pointer _ _)] = derefPtr p >>= box >>= listToString
--vectorToString [(List [])] = return $ String ""
--vectorToString [(List l)] = liftThrows $ buildString l
vectorToString [(Vector v)] = do
    let l = elems v
    case l of
        [] -> return $ String ""
        _ -> liftThrows $ buildString l
vectorToString [badType] = throwError $ TypeMismatch "vector" badType
vectorToString [] = throwError $ NumArgs (Just 1) []
vectorToString args@(_ : _) = throwError $ NumArgs (Just 1) 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 (p@(Pointer _ _) : args) = do
    s <- derefPtr p 
    stringCopy (s : args)
stringCopy [String s] = return $ String s
stringCopy [String s, Number start] = do
    return $ String $ 
        drop (fromInteger start) s
stringCopy [String s, Number start, Number end] = do
    return $ String $ 
        take (fromInteger $ end - start) $
            drop (fromInteger start) s
stringCopy [badType] = throwError $ TypeMismatch "string" badType
stringCopy badArgList = throwError $ NumArgs (Just 2) 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 ([p@(Pointer _ _)]) = derefPtr p >>= box >>= isDottedList
isDottedList ([DottedList _ _]) = return $ Bool True
-- Must include lists as well since they are made up of 'chains' of pairs
isDottedList ([List []]) = return $ Bool False
isDottedList ([List _]) = return $ Bool True
isDottedList _ = return $ 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 ([Continuation _ _ _ _ _]) = return $ Bool True
isProcedure ([PrimitiveFunc _]) = return $ Bool True
isProcedure ([Func _ _ _ _]) = return $ Bool True
isProcedure ([HFunc _ _ _ _]) = return $ Bool True
isProcedure ([IOFunc _]) = return $ Bool True
isProcedure ([EvalFunc _]) = return $ Bool True
isProcedure ([CustFunc _]) = return $ Bool True
isProcedure _ = return $ Bool False

-- | Determine if given object is a bytevector
--
--   Arguments:
--
--   * Value to check
--
--   Returns: Bool - True if bytevector, False otherwise
--
isVector :: LispVal -> IOThrowsError LispVal
isVector p@(Pointer _ _) = derefPtr p >>= isVector
isVector (Vector _) = return $ Bool True
isVector _ = return $ 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 p@(Pointer _ _) = derefPtr p >>= isVector
isByteVector (ByteVector _) = return $ Bool True
isByteVector _ = return $ 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 p@(Pointer _ _) = derefPtr p >>= isList
isList (List _) = return $ Bool True
isList _ = return $ 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 ([p@(Pointer _ _)]) = derefPtr p >>= box >>= isNull
isNull ([List []]) = return $ Bool True
isNull _ = return $ 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 ([EOF]) = return $ Bool True
isEOFObject _ = return $ Bool False

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

-- | Convert the given symbol to a string
--
--   Arguments:
--
--   * Atom - Symbol to convert
--
--   Returns: String
--
symbol2String :: [LispVal] -> ThrowsError LispVal
symbol2String ([Atom a]) = return $ String a
symbol2String [notAtom] = throwError $ TypeMismatch "symbol" notAtom
symbol2String [] = throwError $ NumArgs (Just 1) []
symbol2String args@(_ : _) = throwError $ NumArgs (Just 1) args

-- | Convert a string to a symbol
--
--   Arguments:
--
--   * String (or pointer) - String to convert
--
--   Returns: Atom
--
string2Symbol :: [LispVal] -> IOThrowsError LispVal
string2Symbol ([p@(Pointer _ _)]) = derefPtr p >>= box >>= string2Symbol
string2Symbol ([String s]) = return $ Atom s
string2Symbol [] = throwError $ NumArgs (Just 1) []
string2Symbol [notString] = throwError $ TypeMismatch "string" notString
string2Symbol args@(_ : _) = throwError $ NumArgs (Just 1) args

-- | Convert a character to uppercase
--
--   Arguments:
--
--   * Char
--
--   Returns: Char - Character in uppercase
--
charUpper :: [LispVal] -> ThrowsError LispVal
charUpper [Char c] = return $ Char $ toUpper c
charUpper [notChar] = throwError $ TypeMismatch "char" notChar

-- | Convert a character to lowercase
--
--   Arguments:
--
--   * Char
--
--   Returns: Char - Character in lowercase
--
charLower :: [LispVal] -> ThrowsError LispVal
charLower [Char c] = return $ Char $ toLower c
charLower [notChar] = throwError $ TypeMismatch "char" notChar

-- | Convert from a charater to an integer
--
--   Arguments:
--
--   * Char
--
--   Returns: Number
--
char2Int :: [LispVal] -> ThrowsError LispVal
char2Int [Char c] = return $ Number $ toInteger $ ord c 
char2Int [notChar] = throwError $ TypeMismatch "char" notChar

-- | Convert from an integer to a character
--
--   Arguments:
--
--   * Number
--
--   Returns: Char
--
int2Char :: [LispVal] -> ThrowsError LispVal
int2Char [Number n] = return $ Char $ chr $ fromInteger n 
int2Char [notInt] = throwError $ TypeMismatch "integer" notInt

-- |Determine if given character satisfies the given predicate
charPredicate :: (Char -> Bool) -> [LispVal] -> ThrowsError LispVal
charPredicate pred ([Char c]) = return $ Bool $ pred c 
charPredicate _ _ = return $ 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 ([Char _]) = return $ Bool True
isChar _ = return $ 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 [p@(Pointer _ _)] = derefPtr p >>= box >>= isString
isString ([String _]) = return $ Bool True
isString _ = return $ 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 ([Bool _]) = return $ Bool True
isBoolean _ = return $ Bool False


-- Utility functions
data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a)

-- |Determine if two lispval's are equal
unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
  do unpacked1 <- unpacker arg1
     unpacked2 <- unpacker arg2
     return $ unpacked1 == unpacked2
  `catchError` (const $ return False)

-- |Helper function to perform a binary logic operation on two LispVal arguments.
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
                             then throwError $ NumArgs (Just 2) args
                             else do left <- unpacker $ args !! 0
                                     right <- unpacker $ args !! 1
                                     return $ Bool $ left `op` right

-- |Perform the given function against a single LispVal argument
unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
unaryOp f [v] = f v
unaryOp _ [] = throwError $ NumArgs (Just 1) []
unaryOp _ args@(_ : _) = throwError $ NumArgs (Just 1) args

-- |Same as unaryOp but in the IO monad
unaryOp' :: (LispVal -> IOThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal
unaryOp' f [v] = f v
unaryOp' _ [] = throwError $ NumArgs (Just 1) []
unaryOp' _ args@(_ : _) = throwError $ NumArgs (Just 1) args

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

-- |Perform boolBinop against two char arguments
charBoolBinop = boolBinop unpackChar

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

-- | Unpack a LispVal char
--
--   Arguments:
--
--   * Char - Character to unpack
--
unpackChar :: LispVal -> ThrowsError Char
unpackChar (Char c) = return c
unpackChar notChar = throwError $ TypeMismatch "character" notChar

-- | Unpack a LispVal String
--
--   Arguments:
--
--   * String - String to unpack
--
unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number s) = return $ show s
unpackStr (Bool s) = return $ show s
unpackStr notString = throwError $ TypeMismatch "string" notString

-- | Unpack a LispVal boolean
--
--   Arguments:
--
--   * Bool - Boolean to unpack
--
unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool

-- | Return the current time, in seconds
--
--   Arguments: (None)
--
--   Returns: Current UNIX timestamp in seconds
currentTimestamp :: [LispVal] -> IOThrowsError LispVal
currentTimestamp _ = do
    cur <- liftIO $ Data.Time.Clock.POSIX.getPOSIXTime
    return $ Float $ realToFrac cur

-- | Execute a system command on the underlying OS.
--
--   Arguments:
--
--   * String - Command to execute
--
--   Returns: Integer - program return status
--
system :: [LispVal] -> IOThrowsError LispVal
system [String cmd] = do
    result <- liftIO $ System.Cmd.system cmd
    case result of
        ExitSuccess -> return $ Number 0
        ExitFailure code -> return $ Number $ toInteger code
system err = throwError $ TypeMismatch "string" $ List err