{-# 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
 , equal 
 -- ** Vector
 , buildVector 
 , vectorLength 
 , vectorRef 
 , 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
 , 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 Data.Unique
import qualified Data.Map
import qualified Data.Time.Clock.POSIX
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

-- | 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

-- | 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 _ _)] = derefPtr p >>= box >>= stringCopy
stringCopy [String s] = return $ String 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