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

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

-}

module Language.Scheme.Environments
    (
      primitives
    , ioPrimitives
    ) where
import Language.Scheme.Libraries
import Language.Scheme.Numerical
import Language.Scheme.Primitives
import Language.Scheme.Types
import Language.Scheme.Variables
import Control.Monad.Error
import qualified Data.Char
import System.IO

-- |Primitive functions that execute within the IO monad
ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives = [("open-input-file", makePort openFile ReadMode ),
                ("open-binary-input-file", makePort openBinaryFile ReadMode),
                ("open-output-file", makePort openFile WriteMode),
                ("open-binary-output-file", makePort openBinaryFile WriteMode),
                ("open-output-string", openOutputString),
                ("open-input-string", openInputString),
                ("get-output-string", getOutputString),
                ("open-output-bytevector", openOutputByteVector),
                ("open-input-bytevector", openInputByteVector),
                ("get-output-bytevector", getOutputByteVector),
                ("close-port", closePort),
                ("close-input-port", closePort),
                ("close-output-port", closePort),
                ("flush-output-port", flushOutputPort),
                ("textual-port?", isTextPort),
                ("binary-port?", isBinaryPort),
                ("input-port-open?", isInputPortOpen),
                ("output-port-open?", isOutputPortOpen),
                ("input-port?", isInputPort),
                ("output-port?", isOutputPort),
                ("char-ready?", isCharReady),
                ("u8-ready?", isCharReady), -- Good enough?

               -- The following optional procedures are NOT implemented:
               --
               {- with-input-from-file
               with-output-from-file
               transcript-on
               transcript-off -}
               --
               {- Consideration may be given in a future release, but keep in mind
               the impact to the other I/O functions. -}

                ("current-input-port", currentInputPort),
                ("current-output-port", currentOutputPort),
                ("read", readProc True),
                ("read-line", readProc False),
                ("read-char", readCharProc hGetChar),
                ("read-bytevector", readByteVector),
                ("read-string", readString),
                ("peek-char", readCharProc hLookAhead),
                ("write", writeProc hPrint),
                ("write-char", writeCharProc),
                ("write-bytevector", writeByteVector),
                ("write-string", writeString),
                ("display", writeProc (\ port obj -> do
                  case obj of
                    String str -> hPutStr port str
                    _ -> hPutStr port $ show obj)),

              ("string=?", strBoolBinop (==)),
              ("string<?", strBoolBinop (<)),
              ("string>?", strBoolBinop (>)),
              ("string<=?", strBoolBinop (<=)),
              ("string>=?", strBoolBinop (>=)),
              ("string-ci=?", stringCIEquals),
              ("string-ci<?", stringCIBoolBinop (<)),
              ("string-ci>?", stringCIBoolBinop (>)),
              ("string-ci<=?", stringCIBoolBinop (<=)),
              ("string-ci>=?", stringCIBoolBinop (>=)),
              ("string->symbol", string2Symbol),

              ("car", car),
              ("cdr", cdr),
              ("cons", cons),

              ("eq?",    eq),
              ("eqv?",   eq), -- TODO: not quite right, but maybe good enough for now
              ("equal?", recDerefToFnc equal),

              ("pair?", isDottedList),
              ("list?", unaryOp' isList),
              ("vector?", unaryOp' isVector),
              ("record?", unaryOp' isRecord),
              ("null?", isNull),
              ("string?", isString),

              ("list-copy", listCopy),

              ("string-length", stringLength),
              ("string-ref", stringRef),
              ("substring", substring),
              ("string-append", stringAppend),
              ("string->number", stringToNumber),
              ("string->list", stringToList),
              ("list->string", listToString),
              ("string->vector", stringToVector),
              ("vector->string", vectorToString),
              ("string-copy", stringCopy),
              ("string->utf8", byteVectorStr2Utf),

              ("bytevector?", unaryOp' isByteVector),
              ("bytevector-length", byteVectorLength),
              ("bytevector-u8-ref", byteVectorRef),
              ("bytevector-append", byteVectorAppend),
              ("bytevector-copy", byteVectorCopy),
              ("utf8->string", byteVectorUtf2Str),

              ("vector-length",wrapLeadObj vectorLength),
              ("vector-ref",   wrapLeadObj vectorRef),
              ("vector-copy",  vectorCopy),
              ("vector->list", wrapLeadObj vectorToList),
              ("list->vector", wrapLeadObj listToVector),

              ("hash-table?",       wrapHashTbl isHashTbl),
              ("hash-table-exists?",wrapHashTbl hashTblExists),
              ("hash-table-size",   wrapHashTbl hashTblSize),
              ("hash-table->alist", wrapHashTbl hashTbl2List),
              ("hash-table-keys",   wrapHashTbl hashTblKeys),
              ("hash-table-values", wrapHashTbl hashTblValues),
              ("hash-table-copy",   wrapHashTbl hashTblCopy),

                -- From SRFI 96
                ("file-exists?", fileExists),
                ("delete-file", deleteFile),

                -- husk internal functions
                --("husk-path", getDataFileFullPath'),

                -- Other I/O functions
                ("print-env", printEnv'),
                ("env-exports", exportsFromEnv'),
                ("read-contents", readContents),
                ("read-all", readAll),
                ("find-module-file", findModuleFile),
                ("system", system),
                ("get-environment-variables", getEnvVars),
--                ("system-read", systemRead),
                ("gensym", gensym)]


printEnv' :: [LispVal] -> IOThrowsError LispVal
printEnv' [LispEnv env] = do
    result <- liftIO $ printEnv env
    return $ String result
printEnv' [] = throwError $ NumArgs (Just 1) []
printEnv' args = throwError $ TypeMismatch "env" $ List args

exportsFromEnv' :: [LispVal] -> IOThrowsError LispVal
exportsFromEnv' [LispEnv env] = do
    result <- liftIO $ exportsFromEnv env
    return $ List result
exportsFromEnv' _ = return $ List []

-- | Pure primitive functions
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numAdd),
              ("-", numSub),
              ("*", numMul),
              ("/", numDiv),
              ("modulo", numMod),
              ("quotient", numericBinop quot),
              ("remainder", numericBinop rem),
              ("rationalize", numRationalize),

              ("round", numRound),
              ("floor", numFloor),
              ("ceiling", numCeiling),
              ("truncate", numTruncate),

              ("numerator", numNumerator),
              ("denominator", numDenominator),

              ("exp", numExp),
              ("log", numLog),
              ("sin", numSin),
              ("cos", numCos),
              ("tan", numTan),
              ("asin", numAsin),
              ("acos", numAcos),
              ("atan", numAtan),

              ("sqrt", numSqrt),
              ("expt", numExpt),

              ("make-rectangular", numMakeRectangular),
              ("make-polar", numMakePolar),
              ("real-part", numRealPart ),
              ("imag-part", numImagPart),
              ("magnitude", numMagnitude),
              ("angle", numAngle ),

              ("exact->inexact", numExact2Inexact),
              ("inexact->exact", numInexact2Exact),

              ("number->string", num2String),

              ("=", numBoolBinopEq),
              (">", numBoolBinopGt),
              (">=", numBoolBinopGte),
              ("<", numBoolBinopLt),
              ("<=", numBoolBinopLte),

              ("&&", boolBoolBinop (&&)),
              ("||", boolBoolBinop (||)),

              ("char=?",  charBoolBinop (==)),
              ("char<?",  charBoolBinop (<)),
              ("char>?",  charBoolBinop (>)),
              ("char<=?", charBoolBinop (<=)),
              ("char>=?", charBoolBinop (>=)),
              ("char-ci=?",  charCIBoolBinop (==)),
              ("char-ci<?",  charCIBoolBinop (<)),
              ("char-ci>?",  charCIBoolBinop (>)),
              ("char-ci<=?", charCIBoolBinop (<=)),
              ("char-ci>=?", charCIBoolBinop (>=)),
              ("char-alphabetic?", charPredicate Data.Char.isAlpha),
              ("char-numeric?", charPredicate Data.Char.isNumber),
              ("char-whitespace?", charPredicate Data.Char.isSpace),
              ("char-upper-case?", charPredicate Data.Char.isUpper),
              ("char-lower-case?", charPredicate Data.Char.isLower),
              ("char->integer", char2Int),
              ("integer->char", int2Char),
              ("char-upcase", charUpper),
              ("char-downcase", charLower),
              ("digit-value", charDigitValue),

              ("procedure?", isProcedure),
              ("nan?", isNumNaN),
              ("infinite?", isNumInfinite),
              ("finite?", isNumFinite),
              ("exact?", isNumExact),
              ("inexact?", isNumInexact),
              ("number?", isNumber),
              ("complex?", isComplex),
              ("real?", isReal),
              ("rational?", isRational),
              ("integer?", isInteger),
              ("eof-object?", isEOFObject),
              ("eof-object", eofObject),
              ("symbol?", isSymbol),
              ("symbol=?", isSymbolEq),
              ("symbol->string", symbol2String),
              ("char?", isChar),

              ("make-list", makeList),
              ("make-vector", makeVector),
              ("vector", buildVector),

              ("make-bytevector", makeByteVector),
              ("bytevector", byteVector),

              ("make-hash-table", hashTblMake),
              ("string", buildString),
              ("make-string", makeString),

              ("boolean?", isBoolean),
              ("boolean=?", isBooleanEq),

              ("husk-interpreter?", isInterpreter)]

-- |Custom function used internally in the test suite
isInterpreter :: [LispVal] -> ThrowsError LispVal
isInterpreter [] = return $ Bool True
isInterpreter _ = return $ Bool False