{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{- |
Module      : Language.Scheme.Types
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

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

This module contains top-level data type definitions, environments, error types, and associated functions.

-}

module Language.Scheme.Types
    ( 
    -- * Environments
      Env (..)
    , nullEnv 
    -- * Error Handling
    , LispError (..)
    , ThrowsError 
    , IOThrowsError 
    , liftThrows 
    , showCallHistory
    -- * Types and related functions
    , LispVal (
          Atom
        , List
        , DottedList
        , Vector
        , ByteVector
        , HashTable
        , Number
        , Float
        , Complex
        , Rational
        , String
        , Char
        , Bool
        , PrimitiveFunc
        , Func
             , params
             , vararg
             , body
             , closure
        , HFunc
             , hparams
             , hvararg
             , hbody
             , hclosure
        , IOFunc
        , CustFunc
        , EvalFunc
        , Pointer
             , pointerVar
             , pointerEnv
        , Opaque
        , Port
        , Continuation
             , contClosure
             , currentCont
             , nextCont
             , dynamicWind
             , contCallHist
        , Syntax
             , synClosure
             , synRenameClosure
             , synDefinedInMacro
             , synEllipsis
             , synIdentifiers
             , synRules
        , SyntaxExplicitRenaming
        , LispEnv
        , EOF
        , Nil)
    , nullLisp
    , toOpaque
    , fromOpaque
    , DeferredCode (..)
    , DynamicWinders (..)
    , makeNullContinuation 
    , makeCPS 
    , makeCPSWArgs 
    , eqv 
    , eqvList
    , eqVal 
    , box
    , makeFunc
    , makeNormalFunc
    , makeVarargs
    , makeHFunc
    , makeNormalHFunc
    , makeHVarargs
    , validateFuncParams
    )
 where
import Control.Monad.Except
import Data.Complex
import Data.Array
import qualified Data.ByteString as BS
import Data.Dynamic
import qualified Data.Knob as DK
import qualified Data.List as DL
import Data.IORef
import qualified Data.Map
-- import Data.Maybe
import Data.Ratio
import System.IO
import Text.ParserCombinators.Parsec hiding (spaces)

-- Environment management

-- |A Scheme environment containing variable bindings of form @(namespaceName, variableName), variableValue@
data Env = Environment {
        Env -> Maybe Env
parentEnv :: (Maybe Env), 
        Env -> IORef (Map String (IORef LispVal))
bindings :: (IORef (Data.Map.Map String (IORef LispVal))),
        Env -> IORef (Map String (IORef [LispVal]))
pointers :: (IORef (Data.Map.Map String (IORef [LispVal])))
    }

instance Eq Env where
    (Environment Maybe Env
_ IORef (Map String (IORef LispVal))
xb IORef (Map String (IORef [LispVal]))
xpts) == :: Env -> Env -> Bool
== (Environment Maybe Env
_ IORef (Map String (IORef LispVal))
yb IORef (Map String (IORef [LispVal]))
ypts) = 
      (IORef (Map String (IORef LispVal))
xb IORef (Map String (IORef LispVal))
-> IORef (Map String (IORef LispVal)) -> Bool
forall a. Eq a => a -> a -> Bool
== IORef (Map String (IORef LispVal))
yb) Bool -> Bool -> Bool
&& (IORef (Map String (IORef [LispVal]))
xpts IORef (Map String (IORef [LispVal]))
-> IORef (Map String (IORef [LispVal])) -> Bool
forall a. Eq a => a -> a -> Bool
== IORef (Map String (IORef [LispVal]))
ypts)

-- |An empty environment
nullEnv :: IO Env
nullEnv :: IO Env
nullEnv = do 
    IORef (Map String (IORef LispVal))
nullBindings <- Map String (IORef LispVal)
-> IO (IORef (Map String (IORef LispVal)))
forall a. a -> IO (IORef a)
newIORef (Map String (IORef LispVal)
 -> IO (IORef (Map String (IORef LispVal))))
-> Map String (IORef LispVal)
-> IO (IORef (Map String (IORef LispVal)))
forall a b. (a -> b) -> a -> b
$ [(String, IORef LispVal)] -> Map String (IORef LispVal)
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList []
    IORef (Map String (IORef [LispVal]))
nullPointers <- Map String (IORef [LispVal])
-> IO (IORef (Map String (IORef [LispVal])))
forall a. a -> IO (IORef a)
newIORef (Map String (IORef [LispVal])
 -> IO (IORef (Map String (IORef [LispVal]))))
-> Map String (IORef [LispVal])
-> IO (IORef (Map String (IORef [LispVal])))
forall a b. (a -> b) -> a -> b
$ [(String, IORef [LispVal])] -> Map String (IORef [LispVal])
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList []
    Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$ Maybe Env
-> IORef (Map String (IORef LispVal))
-> IORef (Map String (IORef [LispVal]))
-> Env
Environment Maybe Env
forall a. Maybe a
Nothing IORef (Map String (IORef LispVal))
nullBindings IORef (Map String (IORef [LispVal]))
nullPointers

-- |Types of errors that may occur when evaluating Scheme code
data LispError = NumArgs (Maybe Integer) [LispVal] -- ^Invalid number of function arguments
  | TypeMismatch String LispVal -- ^Type error
  | Parser ParseError -- ^Parsing error
  | BadSpecialForm String LispVal -- ^Invalid special (built-in) form
  | UnboundVar String String -- ^ A referenced variable has not been declared
  | DivideByZero -- ^Divide by Zero error
  | NotImplemented String -- ^ Feature is not implemented
  | InternalError String {- ^An internal error within husk; in theory user (Scheme) code
                         should never allow one of these errors to be triggered. -}
  | Default String -- ^Default error
  | ErrorWithCallHist LispError [LispVal] -- ^Wraps an error to also include the current call history

-- |Create a textual description for a 'LispError'
showError :: LispError -> String
showError :: LispError -> String
showError (NumArgs (Just Integer
expected) [LispVal]
found) = String
"Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
expected
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" args but found " 
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
found)
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" values: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
unwordsList [LispVal]
found
showError (NumArgs Maybe Integer
Nothing [LispVal]
found) = String
"Incorrect number of args, "
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found "
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
found)
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" values: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
unwordsList [LispVal]
found
showError (TypeMismatch String
expected LispVal
found) = String
"Invalid type: expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expected
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
forall a. Show a => a -> String
show LispVal
found
showError (Parser ParseError
parseErr) = String
"Parse error at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
parseErr
showError (BadSpecialForm String
message LispVal
form) = String
message String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
forall a. Show a => a -> String
show LispVal
form
showError (UnboundVar String
message String
varname) = String
message String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
varname
showError (LispError
DivideByZero) = String
"Division by zero"
showError (NotImplemented String
message) = String
"Not implemented: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
message
showError (InternalError String
message) = String
"An internal error occurred: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
message
showError (Default String
message) = String
"Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
message
showError (ErrorWithCallHist LispError
err [LispVal]
stack) = String -> [LispVal] -> String
showCallHistory (LispError -> String
forall a. Show a => a -> String
show LispError
err) [LispVal]
stack

instance Show LispError where show :: LispError -> String
show = LispError -> String
showError

-- |Display call history for an error
showCallHistory :: String -> [LispVal] -> String
showCallHistory :: String -> [LispVal] -> String
showCallHistory String
message [LispVal]
hist = do
  let nums :: [Int]
      nums :: [Int]
nums = [Int
0..]
      ns :: [Int]
ns = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
hist) [Int]
nums
  String
message String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\nCall History:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
    ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Int, LispVal) -> String) -> [(Int, LispVal)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
n, LispVal
s) -> (Char
'#' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
forall a. Show a => a -> String
show LispVal
s) 
                   ([Int] -> [LispVal] -> [(Int, LispVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ns ([LispVal] -> [(Int, LispVal)]) -> [LispVal] -> [(Int, LispVal)]
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
reverse [LispVal]
hist))

-- |Container used by operations that could throw an error
type ThrowsError = Either LispError

-- |Container used to provide error handling in the IO monad
type IOThrowsError = ExceptT LispError IO

-- |Lift a ThrowsError into the IO monad
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left LispError
err) = LispError -> IOThrowsError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError LispError
err
liftThrows (Right a
val) = a -> IOThrowsError a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- |Scheme data types
data LispVal = Atom String
 -- ^Symbol
 | List [LispVal]
 -- ^List
 | DottedList [LispVal] LispVal
 -- ^Pair
 | Vector (Array Int LispVal)
 -- ^Vector
 | ByteVector BS.ByteString
 -- ^ByteVector from R7RS
 | HashTable (Data.Map.Map LispVal LispVal)
 {- ^Hash table.
 Technically this could be a derived data type instead of being built-in to the
 interpreter. And perhaps in the future it will be. But for now, a hash table
 is too important of a data type to not be included. -}
 --
 -- Map is technically the wrong structure to use for a hash table since it is based on a binary tree and hence operations tend to be O(log n) instead of O(1). However, according to <http://www.opensubscriber.com/message/haskell-cafe@haskell.org/10779624.html> Map has good performance characteristics compared to the alternatives. So it stays for the moment...
 --
 | Number Integer -- ^Integer number
 {- FUTURE: rename this to @Integer@ (or @WholeNumber@ or something else more meaningful)
 Integer -}
 | Float Double -- ^Double-precision floating point number
 {- FUTURE: rename this @Real@ instead of @Float@...
 Floating point -}
 | Complex (Complex Double)
 -- ^Complex number
 | Rational Rational
 -- ^Rational number
 | String String
 -- ^String
 | Char Char
 -- ^Character
 | Bool Bool
 -- ^Boolean
 | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
 -- ^Primitive function
 | Func {LispVal -> [String]
params :: [String],
         LispVal -> Maybe String
vararg :: (Maybe String),
         LispVal -> [LispVal]
body :: [LispVal],
         LispVal -> Env
closure :: Env
        }
 -- ^Function written in Scheme
 | HFunc {LispVal -> [String]
hparams :: [String],
          LispVal -> Maybe String
hvararg :: (Maybe String),
          LispVal
-> Env
-> LispVal
-> LispVal
-> Maybe [LispVal]
-> IOThrowsError LispVal
hbody :: (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal),
          LispVal -> Env
hclosure :: Env
        }
 -- ^Function formed from a Haskell function
 | IOFunc ([LispVal] -> IOThrowsError LispVal)
 -- ^Primitive function within the IO monad
 | EvalFunc ([LispVal] -> IOThrowsError LispVal)
 {- ^Function within the IO monad with access to
 the current environment and continuation. -}
 | CustFunc ([LispVal] -> IOThrowsError LispVal)
 -- ^A custom function written by code outside of husk.
 --  Any code that uses the Haskell API should define custom
 --  functions using this data type.
 | Pointer { LispVal -> String
pointerVar :: String
            ,LispVal -> Env
pointerEnv :: Env } 
 -- ^Pointer to an environment variable.
 | Opaque Dynamic
 -- ^Opaque Haskell value.
 | Port Handle (Maybe DK.Knob)
 -- ^I/O port
 | Continuation {  LispVal -> Env
contClosure :: Env                   -- Environment of the continuation
                 , LispVal -> Maybe DeferredCode
currentCont :: (Maybe DeferredCode)  -- Code of current continuation
                 , LispVal -> Maybe LispVal
nextCont :: (Maybe LispVal)          -- Code to resume after body of cont
                 , LispVal -> Maybe [DynamicWinders]
dynamicWind :: (Maybe [DynamicWinders]) -- Functions injected by (dynamic-wind)
                 , LispVal -> [LispVal]
contCallHist :: [LispVal] -- Active call history
                }
 -- ^Continuation
 | Syntax { LispVal -> Maybe Env
synClosure :: Maybe Env       -- ^ Code env in effect at definition time, if applicable
          , LispVal -> Maybe Env
synRenameClosure :: Maybe Env -- ^ Renames (from macro hygiene) in effect at def time;
                                          --   only applicable if this macro defined inside another macro.
          , LispVal -> Bool
synDefinedInMacro :: Bool     -- ^ Set if macro is defined within another macro
          , LispVal -> String
synEllipsis :: String         -- ^ String to use as the ellipsis identifier
          , LispVal -> [LispVal]
synIdentifiers :: [LispVal]   -- ^ Literal identifiers from syntax-rules 
          , LispVal -> [LispVal]
synRules :: [LispVal]         -- ^ Rules from syntax-rules
   } -- ^ Type to hold a syntax object that is created by a macro definition.
     --   Syntax objects are not used like regular types in that they are not
     --   passed around within variables. In other words, you cannot use set! to
     --   assign a variable to a syntax object. But they are used during function
     --   application. In any case, it is convenient to define the type here 
     --   because syntax objects are stored in the same environments and 
     --   manipulated by the same functions as regular variables.
 | SyntaxExplicitRenaming LispVal
   -- ^ Syntax for an explicit-renaming macro
 | LispEnv Env
   -- ^ Wrapper for a scheme environment
 | EOF
   -- ^ End of file indicator
 | Nil String
 -- ^Internal use only; do not use this type directly.

-- | Scheme /null/ value
nullLisp :: LispVal
nullLisp :: LispVal
nullLisp = [LispVal] -> LispVal
List []

-- |Convert a Haskell value to an opaque Lisp value.
toOpaque :: Typeable a => a -> LispVal
toOpaque :: a -> LispVal
toOpaque = Dynamic -> LispVal
Opaque (Dynamic -> LispVal) -> (a -> Dynamic) -> a -> LispVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn

-- |Convert an opaque Lisp value back into a Haskell value of the appropriate
--  type, or produce a TypeMismatch error.
fromOpaque :: forall a. Typeable a => LispVal -> ThrowsError a
-- fromOpaque (Opaque o) | isJust $ fromDynamic o = fromJust $ fromDynamic o
-- fromOpaque badArg = throwError $ TypeMismatch (show $ toOpaque (undefined :: a)) badArg

-- Old version that used ViewPatterns
fromOpaque :: LispVal -> ThrowsError a
fromOpaque (Opaque (Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic -> Just a
v)) = a -> ThrowsError a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
fromOpaque LispVal
badArg = LispError -> ThrowsError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError a) -> LispError -> ThrowsError a
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch (LispVal -> String
forall a. Show a => a -> String
show (LispVal -> String) -> LispVal -> String
forall a b. (a -> b) -> a -> b
$ a -> LispVal
forall a. Typeable a => a -> LispVal
toOpaque (a
forall a. HasCallStack => a
undefined :: a)) LispVal
badArg

-- |Container to hold code that is passed to a continuation for deferred execution
data DeferredCode =
    SchemeBody [LispVal] | -- ^A block of Scheme code
    HaskellBody {
       DeferredCode
-> Env
-> LispVal
-> LispVal
-> Maybe [LispVal]
-> IOThrowsError LispVal
contFunction :: (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
     , DeferredCode -> Maybe [LispVal]
contFunctionArgs :: (Maybe [LispVal]) -- Arguments to the higher-order function
    } -- ^A Haskell function

-- |Container to store information from a dynamic-wind
data DynamicWinders = DynamicWinders {
    DynamicWinders -> LispVal
before :: LispVal -- ^Function to execute when resuming continuation within extent of dynamic-wind
  , DynamicWinders -> LispVal
after :: LispVal -- ^Function to execute when leaving extent of dynamic-wind
}

showDWVal :: DynamicWinders -> String
showDWVal :: DynamicWinders -> String
showDWVal (DynamicWinders LispVal
b LispVal
a) = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
b) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" . " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
a) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

instance Show DynamicWinders where show :: DynamicWinders -> String
show = DynamicWinders -> String
showDWVal

-- |Make an /empty/ continuation that does not contain any code
makeNullContinuation :: Env -> LispVal
makeNullContinuation :: Env -> LispVal
makeNullContinuation Env
env = Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
env Maybe DeferredCode
forall a. Maybe a
Nothing Maybe LispVal
forall a. Maybe a
Nothing Maybe [DynamicWinders]
forall a. Maybe a
Nothing []

-- |Make a continuation that takes a higher-order function (written in Haskell)
makeCPS :: Env 
        -- ^ Environment
        -> LispVal 
        -- ^ Current continuation
        -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) 
        -- ^ Haskell function
        -> LispVal
        -- ^ The Haskell function packaged as a LispVal
makeCPS :: Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env cont :: LispVal
cont@(Continuation {contCallHist :: LispVal -> [LispVal]
contCallHist=[LispVal]
hist}) Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps = Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
env (DeferredCode -> Maybe DeferredCode
forall a. a -> Maybe a
Just ((Env
 -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> Maybe [LispVal] -> DeferredCode
HaskellBody Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps Maybe [LispVal]
forall a. Maybe a
Nothing)) (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
cont) (LispVal -> Maybe [DynamicWinders]
dynamicWind LispVal
cont) [LispVal]
hist
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps = Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
env (DeferredCode -> Maybe DeferredCode
forall a. a -> Maybe a
Just ((Env
 -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> Maybe [LispVal] -> DeferredCode
HaskellBody Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps Maybe [LispVal]
forall a. Maybe a
Nothing)) (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
cont) Maybe [DynamicWinders]
forall a. Maybe a
Nothing [] -- This overload just here for completeness; it should never be used

-- |Make a continuation that stores a higher-order function and arguments to that function
makeCPSWArgs :: Env
        -- ^ Environment
        -> LispVal 
        -- ^ Current continuation
        -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) 
        -- ^ Haskell function
        -> [LispVal]
        -- ^ Arguments to the function
        -> LispVal
        -- ^ The Haskell function packaged as a LispVal
makeCPSWArgs :: Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
env cont :: LispVal
cont@(Continuation {dynamicWind :: LispVal -> Maybe [DynamicWinders]
dynamicWind=Maybe [DynamicWinders]
dynWind,contCallHist :: LispVal -> [LispVal]
contCallHist=[LispVal]
hist}) Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps [LispVal]
args = 
    Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation 
        Env
env 
        (DeferredCode -> Maybe DeferredCode
forall a. a -> Maybe a
Just ((Env
 -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> Maybe [LispVal] -> DeferredCode
HaskellBody Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps ([LispVal] -> Maybe [LispVal]
forall a. a -> Maybe a
Just [LispVal]
args))) 
        (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
cont) Maybe [DynamicWinders]
dynWind [LispVal]
hist
makeCPSWArgs Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps [LispVal]
args = 
    -- This overload just here for completeness; it should never be used
    Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation 
        Env
env 
        (DeferredCode -> Maybe DeferredCode
forall a. a -> Maybe a
Just ((Env
 -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> Maybe [LispVal] -> DeferredCode
HaskellBody Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps ([LispVal] -> Maybe [LispVal]
forall a. a -> Maybe a
Just [LispVal]
args))) 
        (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
cont) Maybe [DynamicWinders]
forall a. Maybe a
Nothing []

instance Ord LispVal where
  compare :: LispVal -> LispVal -> Ordering
compare (Bool Bool
a) (Bool Bool
b) = Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bool
a Bool
b
  compare (Number Integer
a) (Number Integer
b) = Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
a Integer
b
  compare (Rational Rational
a) (Rational Rational
b) = Rational -> Rational -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Rational
a Rational
b
  compare (Float Double
a) (Float Double
b) = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
a Double
b
  compare (String String
a) (String String
b) = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
a String
b
  compare (Char Char
a) (Char Char
b) = Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Char
a Char
b
  compare (Atom String
a) (Atom String
b) = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
a String
b
{- compare (DottedList xs x) (DottedList xs x) = compare a b
Vector
HashTable
List
Func
Others? -}
  compare LispVal
a LispVal
b = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (LispVal -> String
forall a. Show a => a -> String
show LispVal
a) (LispVal -> String
forall a. Show a => a -> String
show LispVal
b) -- Hack (??): sort alphabetically when types differ or have no handlers

-- |Compare two 'LispVal' instances
eqv :: [LispVal] 
    -- ^ A list containing two values to compare
    -> ThrowsError LispVal
    -- ^ Result wrapped as a Bool
eqv :: [LispVal] -> ThrowsError LispVal
eqv [(Bool Bool
arg1), (Bool Bool
arg2)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Bool
arg1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
arg2
eqv [(Number Integer
arg1), (Number Integer
arg2)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Integer
arg1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
arg2
eqv [(Complex Complex Double
arg1), (Complex Complex Double
arg2)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Complex Double
arg1 Complex Double -> Complex Double -> Bool
forall a. Eq a => a -> a -> Bool
== Complex Double
arg2
eqv [(Rational Rational
arg1), (Rational Rational
arg2)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Rational
arg1 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
arg2
eqv [(Float Double
arg1), (Float Double
arg2)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Double
arg1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
arg2
eqv [(String String
arg1), (String String
arg2)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ String
arg1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
arg2
eqv [(Char Char
arg1), (Char Char
arg2)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Char
arg1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
arg2
eqv [(Atom String
arg1), (Atom String
arg2)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ String
arg1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
arg2
eqv [(DottedList [LispVal]
xs LispVal
x), (DottedList [LispVal]
ys LispVal
y)] = [LispVal] -> ThrowsError LispVal
eqv [[LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
xs [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
x], [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
ys [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
y]]
eqv [(Vector Array Int LispVal
arg1), (Vector Array Int LispVal
arg2)] = [LispVal] -> ThrowsError LispVal
eqv [[LispVal] -> LispVal
List (Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
arg1), [LispVal] -> LispVal
List (Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
arg2)]
eqv [(ByteVector ByteString
a), (ByteVector ByteString
b)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ ByteString
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
b
eqv [(HashTable Map LispVal LispVal
arg1), (HashTable Map LispVal LispVal
arg2)] =
  [LispVal] -> ThrowsError LispVal
eqv [[LispVal] -> LispVal
List (((LispVal, LispVal) -> LispVal)
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map (\ (LispVal
x, LispVal
y) -> [LispVal] -> LispVal
List [LispVal
x, LispVal
y]) ([(LispVal, LispVal)] -> [LispVal])
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> [(LispVal, LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toAscList Map LispVal LispVal
arg1),
       [LispVal] -> LispVal
List (((LispVal, LispVal) -> LispVal)
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map (\ (LispVal
x, LispVal
y) -> [LispVal] -> LispVal
List [LispVal
x, LispVal
y]) ([(LispVal, LispVal)] -> [LispVal])
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> [(LispVal, LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toAscList Map LispVal LispVal
arg2)]
--
-- This comparison function may be too simplistic. Basically we check to see if
-- functions have the same calling interface. If they do, then we compare the 
-- function bodies for equality.
--
--FUTURE:
--
-- The real solution for this and many of the other comparison functions is to
-- assign memory locations to data. Then we can just compare memory locations
-- in cases such as this one. But that is a much larger change.
eqv [x :: LispVal
x@(Func [String]
_ Maybe String
_ [LispVal]
xBody Env
_), y :: LispVal
y@(Func [String]
_ Maybe String
_ [LispVal]
yBody Env
_)] = do
  if (LispVal -> String
forall a. Show a => a -> String
show LispVal
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= (LispVal -> String
forall a. Show a => a -> String
show LispVal
y)
     then LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
     else ([LispVal] -> ThrowsError LispVal)
-> [LispVal] -> ThrowsError LispVal
eqvList [LispVal] -> ThrowsError LispVal
eqv [[LispVal] -> LispVal
List [LispVal]
xBody, [LispVal] -> LispVal
List [LispVal]
yBody] 
eqv [x :: LispVal
x@(HFunc{}), y :: LispVal
y@(HFunc{})] = do
  if (LispVal -> String
forall a. Show a => a -> String
show LispVal
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= (LispVal -> String
forall a. Show a => a -> String
show LispVal
y)
     then LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
     else LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
True
--
eqv [x :: LispVal
x@(PrimitiveFunc [LispVal] -> ThrowsError LispVal
_), y :: LispVal
y@(PrimitiveFunc [LispVal] -> ThrowsError LispVal
_)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ (LispVal -> String
forall a. Show a => a -> String
show LispVal
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (LispVal -> String
forall a. Show a => a -> String
show LispVal
y)
eqv [x :: LispVal
x@(IOFunc [LispVal] -> IOThrowsError LispVal
_), y :: LispVal
y@(IOFunc [LispVal] -> IOThrowsError LispVal
_)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ (LispVal -> String
forall a. Show a => a -> String
show LispVal
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (LispVal -> String
forall a. Show a => a -> String
show LispVal
y)
eqv [x :: LispVal
x@(CustFunc [LispVal] -> IOThrowsError LispVal
_), y :: LispVal
y@(CustFunc [LispVal] -> IOThrowsError LispVal
_)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ (LispVal -> String
forall a. Show a => a -> String
show LispVal
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (LispVal -> String
forall a. Show a => a -> String
show LispVal
y)
eqv [x :: LispVal
x@(EvalFunc [LispVal] -> IOThrowsError LispVal
_), y :: LispVal
y@(EvalFunc [LispVal] -> IOThrowsError LispVal
_)] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ (LispVal -> String
forall a. Show a => a -> String
show LispVal
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (LispVal -> String
forall a. Show a => a -> String
show LispVal
y)
-- FUTURE: comparison of two continuations
eqv [l1 :: LispVal
l1@(List [LispVal]
_), l2 :: LispVal
l2@(List [LispVal]
_)] = ([LispVal] -> ThrowsError LispVal)
-> [LispVal] -> ThrowsError LispVal
eqvList [LispVal] -> ThrowsError LispVal
eqv [LispVal
l1, LispVal
l2]
eqv [LispVal
_, LispVal
_] = LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False
eqv [LispVal]
badArgList = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
badArgList

-- |Compare two lists of haskell values, using the given comparison function
eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
eqvList :: ([LispVal] -> ThrowsError LispVal)
-> [LispVal] -> ThrowsError LispVal
eqvList [LispVal] -> ThrowsError LispVal
eqvFunc [(List [LispVal]
arg1), (List [LispVal]
arg2)] = 
    LispVal -> ThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ThrowsError LispVal) -> LispVal -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
arg1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
arg2) Bool -> Bool -> Bool
&&
                    ((LispVal, LispVal) -> Bool) -> [(LispVal, LispVal)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (LispVal, LispVal) -> Bool
eqvPair ([LispVal] -> [LispVal] -> [(LispVal, LispVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LispVal]
arg1 [LispVal]
arg2)
    where eqvPair :: (LispVal, LispVal) -> Bool
eqvPair (LispVal
x1, LispVal
x2) = case [LispVal] -> ThrowsError LispVal
eqvFunc [LispVal
x1, LispVal
x2] of
                               Left LispError
_ -> Bool
False
                               Right (Bool Bool
val) -> Bool
val
                               ThrowsError LispVal
_ -> Bool
False -- OK?
eqvList [LispVal] -> ThrowsError LispVal
_ [LispVal]
_ = LispError -> ThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError LispVal)
-> LispError -> ThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default String
"Unexpected error in eqvList"

-- |A more convenient way to call /eqv/
eqVal :: LispVal -> LispVal -> Bool
eqVal :: LispVal -> LispVal -> Bool
eqVal LispVal
a LispVal
b = do
  let result :: ThrowsError LispVal
result = [LispVal] -> ThrowsError LispVal
eqv [LispVal
a, LispVal
b]
  case ThrowsError LispVal
result of
    Left LispError
_ -> Bool
False
    Right (Bool Bool
val) -> Bool
val
    ThrowsError LispVal
_ -> Bool
False -- Is this OK?

instance Eq LispVal where
  LispVal
x == :: LispVal -> LispVal -> Bool
== LispVal
y = LispVal -> LispVal -> Bool
eqVal LispVal
x LispVal
y

-- |Create a textual description of a 'LispVal'
showVal :: LispVal -> String
showVal :: LispVal -> String
showVal (Nil String
_) = String
""
showVal (LispVal
EOF) = String
"#!EOF"
showVal (LispEnv Env
_) = String
"<env>"
showVal (String String
contents) = String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
contents String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
showVal (Char Char
chr) = [Char
chr]
showVal (Atom String
name) = String
name
showVal (Number Integer
contents) = Integer -> String
forall a. Show a => a -> String
show Integer
contents
showVal (Complex Complex Double
contents) = Double -> String
forall a. Show a => a -> String
show (Complex Double -> Double
forall a. Complex a -> a
realPart Complex Double
contents) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"+" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Double -> String
forall a. Show a => a -> String
show (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ Complex Double -> Double
forall a. Complex a -> a
imagPart Complex Double
contents) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"i"
showVal (Rational Rational
contents) = (Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
contents)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
contents))
showVal (Float Double
contents) = Double -> String
forall a. Show a => a -> String
show Double
contents
showVal (Bool Bool
True) = String
"#t"
showVal (Bool Bool
False) = String
"#f"
showVal (Vector Array Int LispVal
contents) = String
"#(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
unwordsList (Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
Data.Array.elems Array Int LispVal
contents) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showVal (ByteVector ByteString
contents) = String
"#u8(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Word8 -> String) -> [Word8] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> String
forall a. Show a => a -> String
show (ByteString -> [Word8]
BS.unpack ByteString
contents)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showVal (HashTable Map LispVal LispVal
_) = String
"<hash-table>"
showVal (List [LispVal]
contents) = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
unwordsList [LispVal]
contents String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showVal (DottedList [LispVal]
h LispVal
t) = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
unwordsList [LispVal]
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" . " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
showVal LispVal
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showVal (PrimitiveFunc [LispVal] -> ThrowsError LispVal
_) = String
"<primitive>"
showVal (Continuation {}) = String
"<continuation>"
showVal (Syntax {}) = String
"<syntax>"
showVal (SyntaxExplicitRenaming LispVal
_) = String
"<er-macro-transformer syntax>"
showVal (Func {params :: LispVal -> [String]
params = [String]
args, vararg :: LispVal -> Maybe String
vararg = Maybe String
varargs, body :: LispVal -> [LispVal]
body = [LispVal]
_, closure :: LispVal -> Env
closure = Env
_}) =
  String
"(lambda (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++
    (case Maybe String
varargs of
      Maybe String
Nothing -> String
""
      Just String
arg -> String
" . " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ...)"
showVal (HFunc {hparams :: LispVal -> [String]
hparams = [String]
args, hvararg :: LispVal -> Maybe String
hvararg = Maybe String
varargs, hbody :: LispVal
-> Env
-> LispVal
-> LispVal
-> Maybe [LispVal]
-> IOThrowsError LispVal
hbody = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
_, hclosure :: LispVal -> Env
hclosure = Env
_}) =
  String
"(lambda (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++
    (case Maybe String
varargs of
      Maybe String
Nothing -> String
""
      Just String
arg -> String
" . " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ...)"
showVal (Port Handle
_ Maybe Knob
_) = String
"<IO port>"
showVal (IOFunc [LispVal] -> IOThrowsError LispVal
_) = String
"<IO primitive>"
showVal (CustFunc [LispVal] -> IOThrowsError LispVal
_) = String
"<custom primitive>"
showVal (EvalFunc [LispVal] -> IOThrowsError LispVal
_) = String
"<procedure>"
showVal (Pointer String
p Env
_) = String
"<ptr " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
showVal (Opaque Dynamic
d) = String
"<Haskell " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeTypeRep -> String
forall a. Show a => a -> String
show (Dynamic -> SomeTypeRep
dynTypeRep Dynamic
d) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

-- |A helper function to make pointer deref code more concise
box :: LispVal -> IOThrowsError [LispVal]
box :: LispVal -> IOThrowsError [LispVal]
box LispVal
a = [LispVal] -> IOThrowsError [LispVal]
forall (m :: * -> *) a. Monad m => a -> m a
return [LispVal
a]

-- |Convert a list of Lisp objects into a space-separated string
unwordsList :: [LispVal] -> String
unwordsList :: [LispVal] -> String
unwordsList = [String] -> String
unwords ([String] -> String)
-> ([LispVal] -> [String]) -> [LispVal] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LispVal -> String) -> [LispVal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LispVal -> String
showVal

-- |Allow conversion of lispval instances to strings
instance Show LispVal where show :: LispVal -> String
show = LispVal -> String
showVal


-- Functions required by the interpreter --

-- |Create a scheme function
makeFunc :: -- forall (m :: * -> *).
            (Monad m) =>
            Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeFunc :: Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeFunc Maybe String
varargs Env
env [LispVal]
fparams [LispVal]
fbody = LispVal -> m LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> m LispVal) -> LispVal -> m LispVal
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe String -> [LispVal] -> Env -> LispVal
Func ((LispVal -> String) -> [LispVal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LispVal -> String
showVal [LispVal]
fparams) Maybe String
varargs [LispVal]
fbody Env
env

-- |Create a normal scheme function
makeNormalFunc :: (Monad m) => Env
               -> [LispVal]
               -> [LispVal]
               -> m LispVal
makeNormalFunc :: Env -> [LispVal] -> [LispVal] -> m LispVal
makeNormalFunc = Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal
forall (m :: * -> *).
Monad m =>
Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeFunc Maybe String
forall a. Maybe a
Nothing

-- |Create a scheme function that can receive any number of arguments
makeVarargs :: (Monad m) => LispVal -> Env
                        -> [LispVal]
                        -> [LispVal]
                        -> m LispVal
makeVarargs :: LispVal -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeVarargs = Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal
forall (m :: * -> *).
Monad m =>
Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeFunc (Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal)
-> (LispVal -> Maybe String)
-> LispVal
-> Env
-> [LispVal]
-> [LispVal]
-> m LispVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (LispVal -> String) -> LispVal -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LispVal -> String
showVal

-- Functions required by a compiled program --

-- |Create a haskell function
makeHFunc ::
            (Monad m) =>
            Maybe String 
         -> Env 
         -> [String] 
         -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) 
--         -> String 
         -> m LispVal
makeHFunc :: Maybe String
-> Env
-> [String]
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> m LispVal
makeHFunc Maybe String
varargs Env
env [String]
fparams Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
fbody = LispVal -> m LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> m LispVal) -> LispVal -> m LispVal
forall a b. (a -> b) -> a -> b
$ [String]
-> Maybe String
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> Env
-> LispVal
HFunc [String]
fparams Maybe String
varargs Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
fbody Env
env --(map showVal fparams) varargs fbody env
-- |Create a normal haskell function
makeNormalHFunc :: (Monad m) =>
                  Env
               -> [String]
               -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
               -> m LispVal
makeNormalHFunc :: Env
-> [String]
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> m LispVal
makeNormalHFunc = Maybe String
-> Env
-> [String]
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> m LispVal
forall (m :: * -> *).
Monad m =>
Maybe String
-> Env
-> [String]
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> m LispVal
makeHFunc Maybe String
forall a. Maybe a
Nothing

-- |Create a haskell function that can receive any number of arguments
makeHVarargs :: (Monad m) => LispVal 
                        -> Env
                        -> [String]
                        -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
                        -> m LispVal
makeHVarargs :: LispVal
-> Env
-> [String]
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> m LispVal
makeHVarargs = Maybe String
-> Env
-> [String]
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> m LispVal
forall (m :: * -> *).
Monad m =>
Maybe String
-> Env
-> [String]
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> m LispVal
makeHFunc (Maybe String
 -> Env
 -> [String]
 -> (Env
     -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
 -> m LispVal)
-> (LispVal -> Maybe String)
-> LispVal
-> Env
-> [String]
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> m LispVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (LispVal -> String) -> LispVal -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LispVal -> String
showVal

-- |Validate formal function parameters.
validateFuncParams :: [LispVal] -> Maybe Integer -> IOThrowsError Bool
--validateFuncParams [Atom _] _ = return True
validateFuncParams :: [LispVal] -> Maybe Integer -> IOThrowsError Bool
validateFuncParams [LispVal]
ps (Just Integer
n) = do
  if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
ps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n
     then LispError -> IOThrowsError Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError Bool)
-> LispError -> IOThrowsError Bool
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n) [LispVal]
ps
     else [LispVal] -> Maybe Integer -> IOThrowsError Bool
validateFuncParams [LispVal]
ps Maybe Integer
forall a. Maybe a
Nothing
validateFuncParams [LispVal]
ps Maybe Integer
Nothing = do
  let syms :: [LispVal]
syms = (LispVal -> Bool) -> [LispVal] -> [LispVal]
forall a. (a -> Bool) -> [a] -> [a]
filter LispVal -> Bool
filterArgs [LispVal]
ps
  if ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
syms) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
ps)
     then LispError -> IOThrowsError Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError Bool)
-> LispError -> IOThrowsError Bool
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ 
             String
"Invalid lambda parameter(s): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
forall a. Show a => a -> String
show ([LispVal] -> LispVal
List [LispVal]
ps)
     else do
         let strs :: [String]
strs = [String] -> [String]
forall a. Ord a => [a] -> [a]
DL.sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (LispVal -> String) -> [LispVal] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Atom String
a) -> String
a) [LispVal]
ps
         case [String] -> Maybe String
forall a. Eq a => [a] -> Maybe a
dupe [String]
strs of
            Just String
d -> LispError -> IOThrowsError Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError Bool)
-> LispError -> IOThrowsError Bool
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ 
                         String
"Duplicate lambda parameter " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d
            Maybe String
_ -> Bool -> IOThrowsError Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
 where
  filterArgs :: LispVal -> Bool
filterArgs (Atom String
_) = Bool
True
  filterArgs LispVal
_ = Bool
False

  dupe :: [a] -> Maybe a
dupe (a
a : a
b : [a]
rest)
    | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = a -> Maybe a
forall a. a -> Maybe a
Just a
a
    | Bool
otherwise = [a] -> Maybe a
dupe (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rest)
  dupe [a]
_ = Maybe a
forall a. Maybe a
Nothing