{- Copyright 2008 Uwe Hollerbach Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus Copyright Jonathan Tang (but there isn't much of his stuff left). This file is part of haskeem. haskeem is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. haskeem is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA $Id: library.hs,v 1.43 2010-01-18 00:08:49 uwe Exp $ -} {-# LANGUAGE FlexibleContexts #-} module Library (primitiveBindings, delayCounter, symbolCounter, contCounter, loadFile, eqv) where import Prelude import IO import Data.Bits import Data.Char import Data.Ratio import Control.Monad.Error as CME import Data.IORef import System.Directory import System.Posix.Env import System.Posix.Files import System.Posix.Types() import System.Exit import System.Time import System.CPUTime import System.Random import System.Process import qualified Data.IntMap as DIM import Network import LispData import Parser import Environment import WriteNumber errNumArgs :: MonadError LispError m => String -> Integer -> [LispVal] -> m a errNumArgs name want = throwError . NumArgs name want errTypeMismatch :: MonadError LispError m => String -> String -> LispVal -> m a errTypeMismatch name want = throwError . TypeMismatch name want genericBadArg :: [LispVal] -> String -> String -> Int -> ThrowsError LispVal genericBadArg badArgList func want num = if num < 0 || length badArgList == num then errTypeMismatch func want (List badArgList) else errNumArgs func (toInteger num) badArgList genericIOBadArg :: [LispVal] -> String -> String -> Int -> IOThrowsError LispVal genericIOBadArg badArgList func want num = if length badArgList == num then errTypeMismatch func want (head badArgList) else errNumArgs func (toInteger num) badArgList -- A bunch of library functions that don't do IO: -- these get put into the primitives table below isChar :: [LispVal] -> ThrowsError LispVal isChar [Char _] = return lispTrue isChar _ = return lispFalse isBool :: [LispVal] -> ThrowsError LispVal isBool [Boolean _] = return lispTrue isBool _ = return lispFalse isNumber :: [LispVal] -> ThrowsError LispVal isNumber [IntNumber _] = return lispTrue isNumber [RatNumber _] = return lispTrue isNumber [FltNumber _] = return lispTrue isNumber _ = return lispFalse isInteger :: [LispVal] -> ThrowsError LispVal isInteger [IntNumber _] = return lispTrue isInteger [RatNumber n] = return (Boolean (denominator n == 1)) isInteger _ = return lispFalse isRational :: [LispVal] -> ThrowsError LispVal isRational [IntNumber _] = return lispTrue isRational [RatNumber _] = return lispTrue isRational _ = return lispFalse isReal :: [LispVal] -> ThrowsError LispVal isReal [IntNumber _] = return lispTrue isReal [RatNumber _] = return lispTrue isReal [FltNumber _] = return lispTrue isReal _ = return lispFalse isString :: [LispVal] -> ThrowsError LispVal isString [String _] = return lispTrue isString _ = return lispFalse isSymbol :: [LispVal] -> ThrowsError LispVal isSymbol [Symbol _] = return lispTrue isSymbol _ = return lispFalse isList :: [LispVal] -> ThrowsError LispVal isList [List _] = return lispTrue isList _ = return lispFalse isPair :: [LispVal] -> ThrowsError LispVal isPair [List []] = return lispFalse isPair [List _] = return lispTrue isPair [DottedList _ _] = return lispTrue isPair _ = return lispFalse isPort :: [LispVal] -> ThrowsError LispVal isPort [Port _] = return lispTrue isPort [Socket _] = return lispTrue isPort _ = return lispFalse isProcedure :: [LispVal] -> ThrowsError LispVal isProcedure [Prim _] = return lispTrue isProcedure [IOPrim _] = return lispTrue isProcedure [Func _ _ _ _ _ _ _] = return lispTrue isProcedure _ = return lispFalse isVector :: [LispVal] -> ThrowsError LispVal isVector [Vector _ _] = return lispTrue isVector _ = return lispFalse isNull :: [LispVal] -> ThrowsError LispVal isNull [List []] = return lispTrue isNull _ = return lispFalse isZero :: [LispVal] -> ThrowsError LispVal isZero [IntNumber n] = if n == 0 then return lispTrue else return lispFalse isZero [RatNumber n] = if n == 0 then return lispTrue else return lispFalse isZero [FltNumber n] = if n == 0 then return lispTrue else return lispFalse isZero _ = return lispFalse isPositive :: [LispVal] -> ThrowsError LispVal isPositive [IntNumber n] = if n > 0 then return lispTrue else return lispFalse isPositive [RatNumber n] = if n > 0 then return lispTrue else return lispFalse isPositive [FltNumber n] = if n > 0 then return lispTrue else return lispFalse isPositive _ = return lispFalse isNegative :: [LispVal] -> ThrowsError LispVal isNegative [IntNumber n] = if n < 0 then return lispTrue else return lispFalse isNegative [RatNumber n] = if n < 0 then return lispTrue else return lispFalse isNegative [FltNumber n] = if n < 0 then return lispTrue else return lispFalse isNegative _ = return lispFalse isPromise :: [LispVal] -> ThrowsError LispVal isPromise [Delay _ _ _] = return lispTrue isPromise _ = return lispFalse -- The treatment of Inf and NaN is not quite according to R6RS here. they say -- (/ 1 0) causes an exception, but I can't find what happens if the parser -- sees the number 1/0. I think it ought to be Inf, or perhaps RatInf. So I'm -- going to return true for isInf for the rational numbers 1/0 and -1/0, and -- true for isNaN for 0/0, allow entering of both (/ 1 0) and 1/0 plus ninf -- and nan, and deal with these when they arise in computations lispIsNaN :: [LispVal] -> ThrowsError LispVal lispIsNaN [RatNumber n] = return (Boolean (numerator n == 0 && denominator n == 0)) lispIsNaN [FltNumber n] = return (Boolean (isNaN n)) lispIsNaN _ = return lispFalse lispIsInf :: [LispVal] -> ThrowsError LispVal lispIsInf [RatNumber n] = return (Boolean (numerator n /= 0 && denominator n == 0)) lispIsInf [FltNumber n] = return (Boolean (isInfinite n)) lispIsInf _ = return lispFalse lispIsFinite :: [LispVal] -> ThrowsError LispVal lispIsFinite [IntNumber _] = return lispTrue lispIsFinite [RatNumber n] = return (Boolean (denominator n /= 0)) lispIsFinite [FltNumber n] = return (Boolean (not (isInfinite n && isNaN n))) lispIsFinite _ = return lispFalse lispIsEven :: [LispVal] -> ThrowsError LispVal lispIsEven [IntNumber n] | even n = return lispTrue | otherwise = return lispFalse lispIsEven _ = return lispFalse lispIsOdd :: [LispVal] -> ThrowsError LispVal lispIsOdd [IntNumber n] | even n = return lispFalse | otherwise = return lispTrue lispIsOdd _ = return lispFalse lispId :: [LispVal] -> ThrowsError LispVal lispId [val@(_)] = return val lispId _ = progError "library/Id" lispNot :: [LispVal] -> ThrowsError LispVal lispNot [Boolean False] = return lispTrue lispNot _ = return lispFalse unpackChar :: LispVal -> ThrowsError Char unpackChar (Char c) = return c unpackChar notChar = errTypeMismatch "" "character" notChar unpackIntNum :: LispVal -> ThrowsError Integer unpackIntNum (IntNumber n) = return n unpackIntNum (RatNumber n) = if denominator n /= 0 then return (truncate n) else errTypeMismatch "" "number" (RatNumber n) unpackIntNum (FltNumber n) = return (truncate n) unpackIntNum (List [n]) = unpackIntNum n unpackIntNum notNum = errTypeMismatch "" "number" notNum unpackRatNum :: LispVal -> ThrowsError Rational unpackRatNum (IntNumber n) = return (fromInteger n) unpackRatNum (RatNumber n) = return n unpackRatNum (FltNumber n) = return (toRational n) unpackRatNum (List [n]) = unpackRatNum n unpackRatNum notNum = errTypeMismatch "" "number" notNum unpackFltNum :: LispVal -> ThrowsError Double unpackFltNum (IntNumber n) = return (fromInteger n) unpackFltNum (RatNumber n) = return (fromRational n) unpackFltNum (FltNumber n) = return n unpackFltNum (List [n]) = unpackFltNum n unpackFltNum notNum = errTypeMismatch "" "number" notNum unpackStr :: LispVal -> ThrowsError String unpackStr (String s) = return s unpackStr (IntNumber n) = return (show n) unpackStr (RatNumber n) = return (show n) unpackStr (FltNumber n) = return (show n) unpackStr (Boolean b) = return (show b) unpackStr notString = errTypeMismatch "" "string" notString -- first cut at "number tower": if we have a set of args that are all -- integers, we want to keep everything as an integer, including the result; -- if there's a rational in there somewhere, promote them all to rationals; -- ditto for doubles. isIntType, isRatType, isFltType, isOther :: Int isIntType = 0 isRatType = 1 isFltType = 2 isOther = 3 libRatNaN, libFltNaN, libRatPInf :: LispVal libRatNaN = RatNumber myRatNaN libFltNaN = FltNumber myFltNaN libRatPInf = RatNumber myRatPInf scanRatNaN :: [LispVal] -> Bool scanRatNaN [] = False scanRatNaN (IntNumber _:vs) = scanRatNaN vs scanRatNaN (RatNumber v:vs) = (v == myRatNaN) || scanRatNaN vs scanRatNaN _ = progError "library/scanRatNaN" scanFltNaN :: [LispVal] -> Bool scanFltNaN [] = False scanFltNaN (IntNumber _:vs) = scanFltNaN vs scanFltNaN (RatNumber v:vs) = (v == myRatNaN) || scanFltNaN vs scanFltNaN (FltNumber v:vs) = isNaN v || scanFltNaN vs scanFltNaN _ = progError "library/scanFltNaN" getType :: [LispVal] -> Int getType p = foldl1 max (map g p) where g (IntNumber _) = isIntType g (RatNumber _) = isRatType g (FltNumber _) = isFltType g _ = isOther isNumType :: Int -> Bool isNumType n = n == isIntType || n == isRatType || n == isFltType intOrRat :: Rational -> LispVal intOrRat n | denominator n == 1 = IntNumber (numerator n) | otherwise = RatNumber n numericBinop :: String -> (Integer -> Integer -> Integer) -> (Rational -> Rational -> Rational) -> (Double -> Double -> Double) -> [LispVal] -> ThrowsError LispVal numericBinop name intOp ratOp dblOp av = do let mytype = getType av if length av < 2 then errNumArgs name 2 (String (show (length av)) : av) else if mytype == isIntType then mapM unpackIntNum av >>= return . IntNumber . foldl1 intOp else if mytype == isRatType then if scanRatNaN av then return libRatNaN else mapM unpackRatNum av >>= return . intOrRat . foldl1 ratOp else if mytype == isFltType then if scanFltNaN av then return libFltNaN else mapM unpackFltNum av >>= return . FltNumber . foldl1 dblOp else errTypeMismatch name "number" (List av) integerBinop :: String -> (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal integerBinop name intOp av = do let mytype = getType av if length av < 2 then errNumArgs name 2 av else if mytype == isIntType then mapM unpackIntNum av >>= return . IntNumber . foldl1 intOp else errTypeMismatch name "number" (List av) -- wrappers around rational comparison operators so that -- we can deal properly with infinities and NaNs myRatEQ, myRatNE, myRatLT, myRatLE, myRatGT, myRatGE :: Rational -> Rational -> Bool myRatEQ n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False | otherwise = n1 == n2 myRatNE n1 n2 | n1 == myRatNaN || n2 == myRatNaN = True | otherwise = n1 /= n2 myRatLT n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False | n1 == myRatNInf = n2 /= myRatNInf | n2 == myRatPInf = n1 /= myRatPInf | otherwise = n1 < n2 myRatLE n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False | n1 == myRatNInf = True | n1 == myRatPInf = n2 == myRatPInf | otherwise = n1 <= n2 myRatGT n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False | n2 == myRatNInf = n1 /= myRatNInf | n1 == myRatPInf = n2 /= myRatPInf | otherwise = n1 > n2 myRatGE n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False | n1 == myRatPInf = True | n2 == myRatPInf = n1 == myRatPInf | otherwise = n1 >= n2 numBoolBinop :: String -> (Integer -> Integer -> Bool) -> (Rational -> Rational -> Bool) -> (Double -> Double -> Bool) -> Bool -> [LispVal] -> ThrowsError LispVal numBoolBinop name intOp ratOp dblOp nanval av = do let mytype = getType av if length av < 2 then errNumArgs name 2 av else if mytype == isIntType then do ll <- unpackIntNum (head av) rr <- unpackIntNum (av !! 1) return (Boolean (intOp ll rr)) else if mytype == isRatType then if scanRatNaN av then return (Boolean nanval) else do ll <- unpackRatNum (head av) rr <- unpackRatNum (av !! 1) return (Boolean (ratOp ll rr)) else if mytype == isFltType then if scanFltNaN av then return (Boolean nanval) else do ll <- unpackFltNum (head av) rr <- unpackFltNum (av !! 1) return (Boolean (dblOp ll rr)) else errTypeMismatch name "number" (List av) numericFunc :: String -> (Double -> Double) -> [LispVal] -> ThrowsError LispVal numericFunc name fun av = do let mytype = getType av if length av /= 1 then errNumArgs name 1 av else if isNumType mytype then if scanFltNaN av then return libFltNaN else unpackFltNum (head av) >>= return . FltNumber . fun else errTypeMismatch name "number" (List av) lispNumerator :: [LispVal] -> ThrowsError LispVal lispNumerator [IntNumber n] = return (IntNumber n) lispNumerator [RatNumber n] = return (IntNumber (numerator n)) lispNumerator (val:[]) = errTypeMismatch "-" "number" (String (show val)) lispNumerator badArgList = genericBadArg badArgList "numerator" "integer or rational" 1 lispDenominator :: [LispVal] -> ThrowsError LispVal lispDenominator [IntNumber _] = return (IntNumber 1) lispDenominator [RatNumber n] = return (IntNumber (denominator n)) lispDenominator (val:[]) = errTypeMismatch "-" "number" (String (show val)) lispDenominator badArgList = genericBadArg badArgList "denominator" "integer or rational" 1 -- I want haskeem to be able to deal with rational-number infinities and -- nans, so this stuff works around haskell's normalization of rational -- numbers, which breaks for non-finite numbers like 1/0 or 0/0. -- There are some asymmetries in these case tables, arising from the fact -- that there are positive and negative infinities, but not also positive -- and negative zero; so for example the reciprocal of -inf is 0, and thus -- (reciprocal (reciprocal -inf)) is +inf rather than -inf. In that respect, -- rational infs and nan aren't numbers; but then, they are also not -- number-like in that they are their own successors: inf + 1 = inf. One of -- the SRFIs points this out as a reason to only have inexact, ie -- floating-point, infinities and NaNs; but I still prefer to have -- rational-format infinities and NaNs when all calculations are only -- integers and rationals: if the final answer in such a calculation comes -- out finite, ie by dividing by an infinity, it will remain an exact -- quantity; that is mathematically correct, but would not be the case if -- infinities were necessarily inexact. myrecip :: Rational -> Rational myrecip n | n == myRatNaN = myRatNaN | n == myRatPInf || n == myRatNInf = 0 | n == 0 = myRatPInf | otherwise = recip n mymul :: Rational -> Rational -> Rational mymul n1 n2 | denominator n1 /= 0 && denominator n2 /= 0 = n1 * n2 | (n1 == myRatNaN || n2 == myRatNaN) || (n1 == 0 && (n2 == myRatPInf || n2 == myRatNInf)) || (n2 == 0 && (n1 == myRatPInf || n1 == myRatNInf)) = myRatNaN | sg n1 == sg n2 = myRatPInf | otherwise = myRatNInf where sg n = if n > 0 then 1::Int else -1::Int myadd :: Rational -> Rational -> Rational myadd n1 n2 | denominator n1 /= 0 && denominator n2 /= 0 = n1 + n2 | (n1 == myRatNaN || n2 == myRatNaN) || (n1 == myRatPInf && n2 == myRatNInf) || (n1 == myRatNInf && n2 == myRatPInf) = myRatNaN | denominator n1 /= 0 = n2 | otherwise = n1 mymin :: Rational -> Rational -> Rational mymin n1 n2 = if n1 == myRatNInf || n2 == myRatNInf then myRatNInf else min n1 n2 mymax :: Rational -> Rational -> Rational mymax n1 n2 = if n1 == myRatPInf || n2 == myRatPInf then myRatPInf else max n1 n2 mypow :: Rational -> Integer -> Rational mypow b e | b == myRatNaN = myRatNaN | b == myRatPInf && e > 0 = myRatPInf | b == myRatPInf && e == 0 = myRatNaN | b == myRatNInf && e > 0 && even e = myRatPInf | b == myRatNInf && e > 0 && odd e = myRatNInf | b == myRatNInf && e == 0 = myRatNaN | b == 0 && e > 0 = 0 | e == 0 = 1 -- including 0**0, -- mandated by R6RS | e < 0 = mypow (myrecip b) (negate e) | otherwise = b ^ e addOp, mulOp :: [LispVal] -> ThrowsError LispVal addOp = numericBinop "+" (+) myadd (+) mulOp = numericBinop "*" (*) mymul (*) lispPlus :: [LispVal] -> ThrowsError LispVal lispPlus [] = return (IntNumber 0) lispPlus [IntNumber n] = return (IntNumber n) lispPlus [RatNumber n] = return (RatNumber n) lispPlus [FltNumber n] = return (FltNumber n) lispPlus (val:[]) = errTypeMismatch "+" "number" (String (show val)) lispPlus (v:vs) = addOp (v:vs) lispMinus :: [LispVal] -> ThrowsError LispVal lispMinus [] = return (IntNumber 0) lispMinus [IntNumber n] = return (IntNumber (negate n)) lispMinus [RatNumber n] = return (RatNumber (negate n)) lispMinus [FltNumber n] = return (FltNumber (negate n)) lispMinus (val:[]) = errTypeMismatch "-" "number" (String (show val)) lispMinus (a:as) = do aux <- addOp (IntNumber 0 : as) rec <- lispMinus [aux] addOp (a:[rec]) lispMul :: [LispVal] -> ThrowsError LispVal lispMul [] = return (IntNumber 1) lispMul [IntNumber n] = return (IntNumber n) lispMul [RatNumber n] = return (RatNumber n) lispMul [FltNumber n] = return (FltNumber n) lispMul (val:[]) = errTypeMismatch "*" "number" (String (show val)) lispMul (v:vs) = mulOp (v:vs) lispDiv :: [LispVal] -> ThrowsError LispVal lispDiv [] = return (IntNumber 1) lispDiv [IntNumber n] = return (RatNumber (myrecip (fromInteger n))) lispDiv [RatNumber n] = let nr = myrecip n in if denominator nr == 1 then return (IntNumber (numerator nr)) else return (RatNumber nr) lispDiv [FltNumber n] = return (FltNumber (1.0 / n)) lispDiv (val:[]) = errTypeMismatch "/" "number" (String (show val)) lispDiv (a:as) = do aux <- mulOp (IntNumber 1 : as) rec <- lispDiv [aux] mulOp (a:[rec]) lispMin :: [LispVal] -> ThrowsError LispVal lispMin [] = errNumArgs "min" 1 [] lispMin [IntNumber n] = return (IntNumber n) lispMin [RatNumber n] = return (RatNumber n) lispMin [FltNumber n] = return (FltNumber n) lispMin (val:[]) = errTypeMismatch "min" "number" (String (show val)) lispMin (a:as) = numericBinop "min" min mymin min (a:as) lispMax :: [LispVal] -> ThrowsError LispVal lispMax [] = errNumArgs "max" 1 [] lispMax [IntNumber n] = return (IntNumber n) lispMax [RatNumber n] = return (RatNumber n) lispMax [FltNumber n] = return (FltNumber n) lispMax (val:[]) = errTypeMismatch "max" "number" (String (show val)) lispMax (a:as) = numericBinop "max" max mymax max (a:as) -- It would probably be more reasonable to just make everything -- involving infinities to return a NaN... that stuff is just too messy fltpow :: Double -> Double -> LispVal fltpow x y | y == 0 = if isInfinite x then libFltNaN else IntNumber 1 | x == 0 = if y > 0 then IntNumber 0 else libRatPInf | abs x < 1 && y > 0 && isInfinite y = IntNumber 0 | abs x > 1 && y < 0 && isInfinite y = IntNumber 0 | x == -1 && isInfinite y = libFltNaN | x < -1 && y > 0 && isInfinite y = libFltNaN | x > -1 && x < 0 && y < 0 && isInfinite y = libFltNaN | otherwise = FltNumber (x ** y) spow :: Rational -> Rational -> LispVal spow x y | x < -1 && y == myRatPInf = libRatNaN | x < 0 && x > -1 && y == myRatNInf = libRatNaN | x == -1 && abs y == myRatPInf = libRatNaN | x == myRatNInf && y > 0 && denominator y > 1 = libRatNaN | x == myRatPInf && y == 0 = libRatNaN | abs x == myRatPInf && y > 0 = libRatPInf | x > 1 && y == myRatPInf = libRatPInf | x > 0 && x < 1 && y == myRatNInf = libRatPInf | abs x == myRatPInf && y < 0 = IntNumber 0 | x == 1 = IntNumber 1 | otherwise = fltpow (fromRational x) (fromRational y) ratpow :: Rational -> Rational -> LispVal ratpow x y = if denominator y == 1 then let pow = mypow x (numerator y) in if denominator pow == 1 then IntNumber (numerator pow) else RatNumber pow else spow x y lispPow :: [LispVal] -> ThrowsError LispVal lispPow av = if length av /= 2 then errNumArgs "**" 2 av else do let mytype = getType av if isNumType mytype then if mytype == isIntType || mytype == isRatType then if scanRatNaN av then return libRatNaN else do b <- unpackRatNum (head av) e <- unpackRatNum (av !! 1) return (ratpow b e) else if scanFltNaN av then return libFltNaN else do b <- unpackFltNum (head av) e <- unpackFltNum (av !! 1) return (fltpow b e) else errTypeMismatch "expt" "number" (List av) boolBinop :: (LispVal -> ThrowsError a) -> String -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal boolBinop unpacker name op args = if length args /= 2 then errNumArgs name 2 args else do ll <- unpacker (head args) rr <- unpacker (args !! 1) return (Boolean (ll `op` rr)) strBoolBinop :: String -> (String -> String -> Bool) -> [LispVal] -> ThrowsError LispVal strBoolBinop = boolBinop unpackStr charBoolBinop :: String -> (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal charBoolBinop = boolBinop unpackChar car :: [LispVal] -> ThrowsError LispVal car [List (x:_)] = return x car [DottedList (x:_) _] = return x car badArgList = genericBadArg badArgList "car" "pair or list" 1 cdr :: [LispVal] -> ThrowsError LispVal cdr [List (_:xs)] = return (List xs) cdr [DottedList (_:[]) x] = return x cdr [DottedList (_:xs) x] = return (DottedList xs x) cdr badArgList = genericBadArg badArgList "cdr" "pair or list" 1 cons :: [LispVal] -> ThrowsError LispVal cons [xl, List []] = return (List [xl]) cons [x, List xs] = return (List (x : xs)) cons [x, DottedList xs xl] = return (DottedList (x : xs) xl) cons [x1, x2] = return (DottedList [x1] x2) cons badArgList = errNumArgs "cons" 2 badArgList eqv :: [LispVal] -> Bool eqv [(Boolean v1), (Boolean v2)] = v1 == v2 eqv [(Char c1), (Char c2)] = c1 == c2 eqv [(IntNumber v1), (IntNumber v2)] = v1 == v2 eqv [(RatNumber v1), (RatNumber v2)] = v1 == v2 eqv [(FltNumber v1), (FltNumber v2)] = v1 == v2 || (isNaN v1 && isNaN v2) eqv [(String v1), (String v2)] = v1 == v2 eqv [(Symbol v1), (Symbol v2)] = v1 == v2 eqv [(DottedList l1 t1), (DottedList l2 t2)] = eqv [List (l1 ++ [t1]), List (l2 ++ [t2])] eqv [(List l1), (List l2)] = length l1 == length l2 && all eqvPair (zip l1 l2) where eqvPair (x1,x2) = eqv [x1,x2] eqv [(Vector l1 v1), (Vector l2 v2)] = l1 == l2 && all eqvPair (zip (getval (DIM.toAscList v1)) (getval (DIM.toAscList v2))) where eqvPair (x1,x2) = eqv [x1,x2] getval [] = [] getval ((_,v):vs) = v : getval vs eqv _ = False eqvFunc :: [LispVal] -> ThrowsError LispVal eqvFunc (v1:v2:[]) = return (Boolean (eqv [v1,v2])) eqvFunc badArgList = genericBadArg badArgList "eqv?" "matched types" 2 char2int :: [LispVal] -> ThrowsError LispVal char2int [Char c] = return (IntNumber (toInteger (ord c))) char2int badArgList = genericBadArg badArgList "char->integer" "character" 1 int2char :: [LispVal] -> ThrowsError LispVal int2char [IntNumber c] = return (Char (chr (fromInteger c))) int2char badArgList = genericBadArg badArgList "integer->char" "integer" 1 char2str :: [LispVal] -> ThrowsError LispVal char2str [] = return (String "") char2str [List chars] = char2str chars char2str chars = mapM unpackChar chars >>= return . String . foldr (:) [] str2char :: [LispVal] -> ThrowsError LispVal str2char [] = return (List []) str2char [String s] = return (List (map Char s)) str2char badArgList = genericBadArg badArgList "string->char" "string" 1 symb2str :: [LispVal] -> ThrowsError LispVal symb2str [] = return (String "") symb2str [Symbol s] = return (String s) symb2str badArgList = genericBadArg badArgList "symbol->string" "string" 1 str2symb :: [LispVal] -> ThrowsError LispVal str2symb [String []] = genericBadArg [String ""] "string->symbol" "string" 1 str2symb [String s] = return (Symbol (sanitize s)) where sanitize (c:cs) = schar isAlpha c : map (schar isAlphaNum) cs sanitize [] = "_" schar pr c = if pr c || elem c specialSymbolChars then c else '_' str2symb badArgList = genericBadArg badArgList "string->symbol" "string" 1 readNum :: [LispVal] -> ThrowsError LispVal readNum [String s] = readNumber s readNum badArgList = genericBadArg badArgList "string->number" "string" 1 charIs :: (Char -> Bool) -> [LispVal] -> ThrowsError LispVal charIs op [Char c] = return (Boolean (op c)) charIs _ badArgList = genericBadArg badArgList "char-istype?" "character" 1 charTo :: (Char -> Char) -> [LispVal] -> ThrowsError LispVal charTo op [Char char] = return (Char (op char)) charTo op [List chars] = charTo op chars charTo op [String str] = return (String (map op str)) charTo op chars = mapM oneTo chars >>= return . List where oneTo (Char c) = return (Char (op c)) oneTo notChar = errTypeMismatch "charTo" "character" notChar lispFloor :: [LispVal] -> ThrowsError LispVal lispFloor [IntNumber c] = return (IntNumber c) lispFloor [RatNumber c] = if denominator c /= 0 then return (IntNumber (floor c)) else return (RatNumber c) lispFloor [FltNumber c] = return (IntNumber (floor c)) lispFloor badArgList = genericBadArg badArgList "floor" "number" 1 lispTruncate :: [LispVal] -> ThrowsError LispVal lispTruncate [IntNumber c] = return (IntNumber c) lispTruncate [RatNumber c] = if denominator c /= 0 then return (IntNumber (truncate c)) else return (RatNumber c) lispTruncate [FltNumber c] = return (IntNumber (truncate c)) lispTruncate badArgList = genericBadArg badArgList "truncate" "number" 1 -- TODO: implement relative-tolerance rounding, so that specifying -- 3 digits relative gives X.XXXeXX, for any exponent -- round to a {rational,floating-point} number with a specified non-negative -- number of digits to the right of the decimal point; this is a number of -- the same type as the input roundToAP :: RealFrac a => a -> Integer -> Integer -> a roundToAP n b d = let bd = fromInteger (b^d) in fromInteger (round (n * bd)) / bd -- equivalent of the above, except with the truncation point to the left -- of the decimal point; that means the result is always an integer roundToAN :: RealFrac a => a -> Integer -> Integer -> Integer roundToAN n b d = let bd = b^d in bd * round (n / fromInteger bd) lispRound :: [LispVal] -> ThrowsError LispVal lispRound [IntNumber c] = return (IntNumber c) lispRound [RatNumber c] = if denominator c /= 0 then return (IntNumber (round c)) else return (RatNumber c) lispRound [FltNumber c] = return (IntNumber (round c)) lispRound [IntNumber c, IntNumber b, IntNumber d] = if b > 1 then if d >= 0 then return (IntNumber c) else return (IntNumber (roundToAN (toRational c) b (- d))) else throwError (Default ("bad base arg to round: " ++ show b)) lispRound [RatNumber c, IntNumber b, IntNumber d] = if denominator c /= 0 then if b > 1 then if d > 0 then return (RatNumber (roundToAP c b d)) else return (IntNumber (roundToAN c b (- d))) else throwError (Default ("bad base arg to round: " ++ show b)) else return (RatNumber c) lispRound [FltNumber c, IntNumber b, IntNumber d] = if b > 1 then if d > 0 then return (FltNumber (roundToAP c b d)) else return (IntNumber (roundToAN c b (- d))) else throwError (Default ("bad base arg to round: " ++ show b)) lispRound badArgList = genericBadArg badArgList "round" "number" 1 lispCeiling :: [LispVal] -> ThrowsError LispVal lispCeiling [IntNumber c] = return (IntNumber c) lispCeiling [RatNumber c] = if denominator c /= 0 then return (IntNumber (ceiling c)) else return (RatNumber c) lispCeiling [FltNumber c] = return (IntNumber (ceiling c)) lispCeiling badArgList = genericBadArg badArgList "ceiling" "number" 1 lispAbs :: [LispVal] -> ThrowsError LispVal lispAbs [IntNumber c] = return (IntNumber (abs c)) lispAbs [RatNumber n] = return (RatNumber (abs n)) lispAbs [FltNumber c] = return (FltNumber (abs c)) lispAbs badArgList = genericBadArg badArgList "abs" "number" 1 lispATan2 :: [LispVal] -> ThrowsError LispVal lispATan2 av = do let mytype = getType av if isNumType mytype then if scanFltNaN av then return libFltNaN else case length av of 1 -> mapM unpackFltNum av >>= return . FltNumber . atan . head 2 -> mapM unpackFltNum av >>= return . FltNumber . at2 _ -> errNumArgs "atan" 2 av else errTypeMismatch "atan" "number" (List av) where at2 (y:x:[]) = atan2 y x at2 _ = progError "library/ATan2" lispListFromArgs :: [LispVal] -> ThrowsError LispVal lispListFromArgs = return . List lispReverse :: [LispVal] -> ThrowsError LispVal lispReverse [List lst] = return (List (reverse lst)) lispReverse badArgList = genericBadArg badArgList "reverse" "list" 1 lispLast :: [LispVal] -> ThrowsError LispVal lispLast [List []] = return (List []) lispLast [List lst] = return (last lst) lispLast badArgList = genericBadArg badArgList "last" "list" 1 lispLength :: [LispVal] -> ThrowsError LispVal lispLength [List lst] = return (IntNumber (toInteger (length lst))) lispLength badArgList = genericBadArg badArgList "length" "list" 1 lispListHead :: [LispVal] -> ThrowsError LispVal lispListHead [List lst, IntNumber n] = return (List (take (fromInteger n) lst)) lispListHead badArgList = genericBadArg badArgList "list-head" "list + number" 2 lispListTail :: [LispVal] -> ThrowsError LispVal lispListTail [List lst, IntNumber n] = return (List (drop (fromInteger n) lst)) lispListTail badArgList = genericBadArg badArgList "list-tail" "list + number" 2 lispListRef :: [LispVal] -> ThrowsError LispVal lispListRef [List lst, IntNumber n] = return (hON (drop (fromInteger n) lst)) where hON [] = List [] hON (x:_) = x lispListRef badArgList = genericBadArg badArgList "list-ref" "list + number" 2 lispILog :: [LispVal] -> ThrowsError LispVal lispILog [IntNumber n] = return (IntNumber (ilogb 2 n)) lispILog [IntNumber b, IntNumber n] = if b < 2 then errTypeMismatch "ilog" "b > 2" (IntNumber b) else return (IntNumber (ilogb b n)) lispILog badArgList = genericBadArg badArgList "ilog" "integer" 1 lispFactorial :: [LispVal] -> ThrowsError LispVal lispFactorial [IntNumber n] | n == 0 = return (IntNumber 1) | n > 0 = return (IntNumber (product [1 .. n])) | otherwise = genericBadArg [IntNumber n] "factorial" "non-negative integer" 1 lispFactorial badArgList = genericBadArg badArgList "factorial" "integer" 1 -- Vector primitives lispMakeVector :: [LispVal] -> ThrowsError LispVal lispMakeVector [IntNumber n] = lispMakeVector [IntNumber n, Boolean False] lispMakeVector [IntNumber n, val] = if n > 0 then return (Vector n (DIM.fromAscList (addkey val (fromInteger n)))) else errTypeMismatch "make-vector" "n > 0" (IntNumber n) where addkey _ 0 = [] addkey v k = ((k-1), v) : addkey v (k-1) lispMakeVector badArgList = genericBadArg badArgList "make-vector" "integer" 1 lispVecFromArgs :: [LispVal] -> ThrowsError LispVal lispVecFromArgs vals = return (Vector (toInteger (length vals)) (DIM.fromAscList (addkey 0 vals))) where addkey _ [] = [] addkey n (v:vs) = (n, v) : addkey (n+1) vs lispListToVec :: [LispVal] -> ThrowsError LispVal lispListToVec [List vals] = return (Vector (toInteger (length vals)) (DIM.fromAscList (addkey 0 vals))) where addkey _ [] = [] addkey n (v:vs) = (n, v) : addkey (n+1) vs lispListToVec badArgList = genericBadArg badArgList "list->vector" "list" 1 lispVecToList :: [LispVal] -> ThrowsError LispVal lispVecToList [Vector _ vec] = return (List (getval (DIM.toAscList vec))) where getval [] = [] getval ((_,v):vs) = v : getval vs lispVecToList badArgList = genericBadArg badArgList "vector->list" "vector" 1 lispVecSize :: [LispVal] -> ThrowsError LispVal lispVecSize [Vector len _] = return (IntNumber len) lispVecSize badArgList = genericBadArg badArgList "vector-length" "vector" 1 lispVecRef :: [LispVal] -> ThrowsError LispVal lispVecRef [Vector len vec, IntNumber n] = if n >= 0 && n < len then return (DIM.findWithDefault lispFalse (fromInteger n) vec) else throwError (VectorBounds len (IntNumber n)) lispVecRef badArgList = genericBadArg badArgList "vector-ref" "vector + integer" 2 getfn1 :: LispVal -> [LispVal] -> LispVal getfn1 a b = List (Symbol "lambda" : a : b) getfn :: [String] -> Maybe String -> [LispVal] -> LispVal getfn ps Nothing body = getfn1 (List (map Symbol ps)) body getfn [] (Just v) body = getfn1 (Symbol v) body getfn ps (Just v) body = getfn1 (DottedList (map Symbol ps) (Symbol v)) body proc2data :: [LispVal] -> ThrowsError LispVal proc2data [Func pars var body _ _ _ _] = return (getfn pars var body) proc2data [Delay obj _ _] = return obj proc2data [Prim _] = throwError (Default "procedure->data can't handle builtin functions") proc2data [IOPrim _] = throwError (Default "procedure->data can't handle builtin functions") proc2data badArgList = genericBadArg badArgList "procedure->data" "lisp function" 1 bitsAnd :: [LispVal] -> ThrowsError LispVal bitsAnd [IntNumber n1, IntNumber n2] = return (IntNumber (n1 .&. n2)) bitsAnd badArgList = genericBadArg badArgList "bits-and" "integer" 2 bitsOr :: [LispVal] -> ThrowsError LispVal bitsOr [IntNumber n1, IntNumber n2] = return (IntNumber (n1 .|. n2)) bitsOr badArgList = genericBadArg badArgList "bits-or" "integer" 2 bitsXOr :: [LispVal] -> ThrowsError LispVal bitsXOr [IntNumber n1, IntNumber n2] = return (IntNumber (xor n1 n2)) bitsXOr badArgList = genericBadArg badArgList "bits-xor" "integer" 2 -- It's not quite clear to me that this one is useful... -- it seems to implement the function -- bn :: Integer -> Integer -- bn n = -(n + 1) -- which is correct enough in infinite-bits 2-adic numbers, -- but the actual bit patterns returned don't look like complements. -- Use bitsFlip instead... -- bitsNot :: [LispVal] -> ThrowsError LispVal -- bitsNot [IntNumber n] = return (IntNumber (complement n)) -- bitsNot badArgList = genericBadArg badArgList "bits-not" "integer" 1 bitsShift :: [LispVal] -> ThrowsError LispVal bitsShift [IntNumber n1, IntNumber n2] = return (IntNumber (shift n1 (fromInteger n2))) bitsShift badArgList = genericBadArg badArgList "bits-shift" "integer" 2 bitsSet :: [LispVal] -> ThrowsError LispVal bitsSet [IntNumber n1, IntNumber n2] = return (IntNumber (setBit n1 (fromInteger n2))) bitsSet badArgList = genericBadArg badArgList "bits-set" "integer" 2 bitsClear :: [LispVal] -> ThrowsError LispVal bitsClear [IntNumber n1, IntNumber n2] = return (IntNumber (clearBit n1 (fromInteger n2))) bitsClear badArgList = genericBadArg badArgList "bits-clear" "integer" 2 bitsFlip :: [LispVal] -> ThrowsError LispVal bitsFlip [IntNumber n1, IntNumber n2] = return (IntNumber (complementBit n1 (fromInteger n2))) bitsFlip badArgList = genericBadArg badArgList "bits-flip" "integer" 2 bitsGet :: [LispVal] -> ThrowsError LispVal bitsGet [IntNumber n1, IntNumber n2] = return (IntNumber (n1 .&. bit (fromInteger n2))) bitsGet badArgList = genericBadArg badArgList "bits-get" "integer" 2 bitsIsSet :: [LispVal] -> ThrowsError LispVal bitsIsSet [IntNumber n1, IntNumber n2] = return (Boolean (testBit n1 (fromInteger n2))) bitsIsSet badArgList = genericBadArg badArgList "bits-set?" "integer" 2 primitives :: [(String, [LispVal] -> ThrowsError LispVal)] primitives = [("+", lispPlus), ("-", lispMinus), ("*", lispMul), ("/", lispDiv), ("expt", lispPow), ("min", lispMin), ("max", lispMax), ("modulo", integerBinop "modulo" mod), ("quotient", integerBinop "quotient" quot), ("remainder", integerBinop "remainder" rem), ("gcd", integerBinop "gcd" gcd), ("lcm", integerBinop "lcm" lcm), ("=", numBoolBinop "=" (==) myRatEQ (==) False), ("<", numBoolBinop "<" (<) myRatLT (<) False), (">", numBoolBinop ">" (>) myRatGT (>) False), ("/=", numBoolBinop "/=" (/=) myRatNE (/=) True), (">=", numBoolBinop ">=" (>=) myRatGE (>=) False), ("<=", numBoolBinop "<=" (<=) myRatLE (<=) False), ("boolean?", isBool), ("symbol?", Library.isSymbol), ("char?", isChar), ("number?", Library.isNumber), ("integer?", isInteger), ("rational?", isRational), ("real?", isReal), ("string?", isString), ("pair?", isPair), ("list?", isList), ("null?", isNull), ("port?", isPort), ("procedure?", isProcedure), ("promise?", isPromise), ("vector?", isVector), ("even?", lispIsEven), ("odd?", lispIsOdd), ("zero?", isZero), ("positive?", isPositive), ("negative?", isNegative), ("nan?", lispIsNaN), ("infinite?", lispIsInf), ("finite?", lispIsFinite), ("not", lispNot), ("id", lispId), ("string=?", strBoolBinop "string=?" (==)), ("string?", strBoolBinop "string>?" (>)), ("string>=?", strBoolBinop "string>=?" (>=)), ("string<=?", strBoolBinop "string<=?" (<=)), ("char=?", charBoolBinop "char=?" (==)), ("char?", charBoolBinop "char>?" (>)), ("char>=?", charBoolBinop "char>=?" (>=)), ("char<=?", charBoolBinop "char<=?" (<=)), ("char->string", char2str), ("string->char", str2char), ("string->number", readNum), ("number->string", writeNum), ("symbol->string", symb2str), ("string->symbol", str2symb), ("char-alphabetic?", charIs isAlpha), ("char-numeric?", charIs isDigit), ("char-oct-digit?", charIs isOctDigit), ("char-hex-digit?", charIs isHexDigit), ("char-whitespace?", charIs isSpace), ("char-upper-case?", charIs isUpper), ("char-lower-case?", charIs isLower), ("char-alphanumeric?", charIs isAlphaNum), ("char-control?", charIs isControl), ("char-printable?", charIs isPrint), ("char-upcase", charTo toUpper), ("char-downcase", charTo toLower), ("string-upcase", charTo toUpper), ("string-downcase", charTo toLower), ("car", car), ("cdr", cdr), ("cons", cons), ("eqv?", eqvFunc), ("char->integer", char2int), ("integer->char", int2char), ("floor", lispFloor), ("truncate", lispTruncate), ("round", lispRound), ("ceiling", lispCeiling), ("numerator", lispNumerator), ("denominator", lispDenominator), ("abs", lispAbs), ("sqrt", numericFunc "sqrt" sqrt), ("exp", numericFunc "exp" exp), ("log", numericFunc "log" log), ("sin", numericFunc "sin" sin), ("cos", numericFunc "cos" cos), ("tan", numericFunc "tan" tan), ("sinh", numericFunc "sinh" sinh), ("cosh", numericFunc "cosh" cosh), ("tanh", numericFunc "tanh" tanh), ("asin", numericFunc "asin" asin), ("acos", numericFunc "acos" acos), ("atan", lispATan2), ("asinh", numericFunc "asinh" asinh), ("acosh", numericFunc "acosh" acosh), ("atanh", numericFunc "atanh" atanh), ("list", lispListFromArgs), ("reverse", lispReverse), ("last", lispLast), ("length", lispLength), ("list-head", lispListHead), ("list-tail", lispListTail), ("list-ref", lispListRef), ("ilog", lispILog), ("factorial", lispFactorial), ("make-vector", lispMakeVector), ("vector", lispVecFromArgs), ("vector-length", lispVecSize), ("list->vector", lispListToVec), ("vector->list", lispVecToList), ("vector-ref", lispVecRef), ("procedure->data", proc2data), ("bits-and", bitsAnd), ("bits-or", bitsOr), ("bits-xor", bitsXOr), -- ("bits-not", bitsNot), ("bits-shift", bitsShift), ("bits-set", bitsSet), ("bits-clear", bitsClear), ("bits-flip", bitsFlip), ("bits-get", bitsGet), ("bits-set?", bitsIsSet)] -- A bunch of library functions that do IO: -- these get put into the ioPrimitives table below -- This is the wrapper which catches IO errors... I dunno what type it is -- This converts a system-level error into a lisp-level error by the -- kinda-funky (Default (show err)), assuming we don't swallow the error doIOAction :: (MonadIO m, MonadError LispError m) => IO a -> (a -> LispVal) -> (IOError -> Bool) -> m LispVal doIOAction action ctor epred = do ret <- liftIO (try action) case ret of Left err -> if epred err then throwError (Default (show err)) else return lispFalse Right val -> return (ctor val) -- A couple of utility functions for using doIOAction: dropToBool is a -- quasi-constructor which drops whatever it was handed, and instead only -- returns lispTrue; allErrs and noEOF are selectors for various errors: -- generally we want to hear about errors, but EOF when reading a line or -- character isn't really an error, so we silence that one. dropToBool :: t -> LispVal dropToBool _ = lispTrue allErrs :: t -> Bool allErrs _ = True noEOF :: IOError -> Bool noEOF = not . isEOFError makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal makePort mode [String filename] = doIOAction (openFile filename mode) Port allErrs makePort _ badArgList = genericIOBadArg badArgList "open-IO-file" "string" 1 closePort :: [LispVal] -> IOThrowsError LispVal closePort [Port port] = doIOAction (hClose port) dropToBool allErrs closePort [Socket sock] = doIOAction (sClose sock) dropToBool allErrs closePort _ = return lispFalse readLine :: [LispVal] -> IOThrowsError LispVal readLine [] = readLine [Port stdin] readLine [Port port] = doIOAction (hGetLine port) String noEOF readLine badArgList = genericIOBadArg badArgList "read-line" "read port" 1 readChar :: [LispVal] -> IOThrowsError LispVal readChar [] = readChar [Port stdin] readChar [Port port] = doIOAction (hGetChar port) Char noEOF readChar badArgList = genericIOBadArg badArgList "read-char" "read port" 1 displayProc :: [LispVal] -> IOThrowsError LispVal displayProc [obj] = displayProc [obj, Port stdout] displayProc [obj, Port port] = doIOAction (hPutStr port (show obj)) dropToBool allErrs displayProc badArgList = genericIOBadArg badArgList "display" "write port" 2 readContents :: [LispVal] -> IOThrowsError LispVal readContents [String filename] = doIOAction (readFile filename) String allErrs readContents badArgList = genericIOBadArg badArgList "read-contents" "string" 1 loadFile :: String -> IOThrowsError [LispVal] loadFile filename = do str <- doIOAction (readFile filename) String allErrs case str of Boolean False -> throwError (Default "operation failed") String val -> liftThrows (readExprList val) _ -> progError "library/loadFile" readAll :: [LispVal] -> IOThrowsError LispVal readAll [String filename] = liftM List (loadFile filename) readAll badArgList = genericIOBadArg badArgList "read-all" "string" 1 lispPutStr :: [LispVal] -> IOThrowsError LispVal lispPutStr [] = return lispFalse lispPutStr ((Port port):rest) = mapM_ outStr rest >> return lispTrue where outStr (String s) = doIOAction (hPutStr port s) dropToBool allErrs outStr (Char c) = doIOAction (hPutChar port c) dropToBool allErrs outStr notS = genericIOBadArg [notS] "write-string" "string" 1 lispPutStr (s:ss) = lispPutStr (Port stdout : s : ss) flushPort :: [LispVal] -> IOThrowsError LispVal flushPort [] = flushPort [Port stdout] flushPort [Port p] = doIOAction (hFlush p) dropToBool allErrs flushPort badArgList = genericIOBadArg badArgList "flush-port" "port" 1 lispError :: [LispVal] -> IOThrowsError LispVal lispError [] = throwError (UserException (List [])) lispError [val] = throwError (UserException val) lispError info = throwError (UserException (List info)) lispExit :: [LispVal] -> IOThrowsError LispVal lispExit [Boolean False] = liftIO (exitWith (ExitFailure 1)) lispExit [Boolean True] = liftIO (exitWith ExitSuccess) lispExit [IntNumber n] | n == 0 = liftIO (exitWith ExitSuccess) | otherwise = liftIO(exitWith (ExitFailure (fromInteger n))) lispExit [String s] = liftIO (hPutStrLn stderr s >> exitWith (ExitFailure 1)) lispExit _ = liftIO (hPutStrLn stderr "goodbye!" >> exitWith (ExitFailure 1)) lispFileExists :: [LispVal] -> IOThrowsError LispVal lispFileExists [String filename] = doIOAction (doesFileExist filename) Boolean allErrs lispFileExists badArgList = genericIOBadArg badArgList "file-exists?" "string" 1 lispDirExists :: [LispVal] -> IOThrowsError LispVal lispDirExists [String dirname] = doIOAction (doesDirectoryExist dirname) Boolean allErrs lispDirExists badArgList = genericIOBadArg badArgList "directory-exists?" "string" 1 lispRenameFile :: [LispVal] -> IOThrowsError LispVal lispRenameFile [String oldname, String newname] = doIOAction (renameFile oldname newname) dropToBool allErrs lispRenameFile badArgList = genericIOBadArg badArgList "rename-file" "string" 2 lispCreateLink :: [LispVal] -> IOThrowsError LispVal lispCreateLink [String oldname, String newname] = doIOAction (createLink oldname newname) dropToBool allErrs lispCreateLink badArgList = genericIOBadArg badArgList "create-link" "string" 2 lispCreateSymbolicLink :: [LispVal] -> IOThrowsError LispVal lispCreateSymbolicLink [String oldname, String newname] = doIOAction (createSymbolicLink oldname newname) dropToBool allErrs lispCreateSymbolicLink badArgList = genericIOBadArg badArgList "create-symbolic-link" "string" 2 lispRemoveFile :: [LispVal] -> IOThrowsError LispVal lispRemoveFile [String filename] = doIOAction (removeFile filename) dropToBool allErrs lispRemoveFile badArgList = genericIOBadArg badArgList "remove-file" "string" 2 lispCreateDir :: [LispVal] -> IOThrowsError LispVal lispCreateDir [String dirname] = doIOAction (createDirectory dirname) dropToBool allErrs lispCreateDir badArgList = genericIOBadArg badArgList "create-directory" "string" 1 lispRemoveDir :: [LispVal] -> IOThrowsError LispVal lispRemoveDir [String dirname] = doIOAction (removeDirectory dirname) dropToBool allErrs lispRemoveDir badArgList = genericIOBadArg badArgList "remove-directory" "string" 1 lispRenameDir :: [LispVal] -> IOThrowsError LispVal lispRenameDir [String oldname, String newname] = doIOAction (renameDirectory oldname newname) dropToBool allErrs lispRenameDir badArgList = genericIOBadArg badArgList "rename-directory" "string" 2 lispSetCurrentDir :: [LispVal] -> IOThrowsError LispVal lispSetCurrentDir [String dirname] = doIOAction (setCurrentDirectory dirname) dropToBool allErrs lispSetCurrentDir badArgList = genericIOBadArg badArgList "set-current-directory" "nothing" 0 lispGetCurrentDir :: [LispVal] -> IOThrowsError LispVal lispGetCurrentDir [] = doIOAction getCurrentDirectory String allErrs lispGetCurrentDir badArgList = genericIOBadArg badArgList "get-current-directory" "nothing" 0 lispGetDirContents :: [LispVal] -> IOThrowsError LispVal lispGetDirContents [String dirname] = doIOAction (getDirectoryContents dirname) (List . map String) allErrs lispGetDirContents badArgList = genericIOBadArg badArgList "read-directory" "string" 1 lispGetEnv :: [LispVal] -> IOThrowsError LispVal lispGetEnv [] = doIOAction getEnvironment (List . toSS) allErrs where toSS [] = [] toSS ((key,val):strs) = DottedList [String key] (String val) : toSS strs lispGetEnv [String key] = doIOAction (getEnvDefault key "") String allErrs lispGetEnv badArgList = genericIOBadArg badArgList "get-environment" "string" 1 lispSetEnv :: [LispVal] -> IOThrowsError LispVal lispSetEnv [String key, String val] = doIOAction (putEnv (key ++ "=" ++ val)) dropToBool allErrs lispSetEnv badArgList = genericIOBadArg badArgList "set-environment" "string" 2 lispUnSetEnv :: [LispVal] -> IOThrowsError LispVal lispUnSetEnv [String key] = doIOAction (unsetEnv key) dropToBool allErrs lispUnSetEnv badArgList = genericIOBadArg badArgList "unset-environment" "string" 1 lispEpochTime :: [LispVal] -> IOThrowsError LispVal lispEpochTime [] = doIOAction getClockTime getET allErrs where getET (TOD sec psec) = FltNumber (fromInteger sec + 1.0e-12 * fromInteger psec) lispEpochTime badArgList = genericIOBadArg badArgList "epochtime" "nothing" 0 lispLocalTime :: [LispVal] -> IOThrowsError LispVal lispLocalTime [] = doIOAction getClockTime toS allErrs where toS = String . show lispLocalTime [IntNumber n] = doIOAction (toCalendarTime (TOD n 0)) toS allErrs where toS = String . calendarTimeToString lispLocalTime [RatNumber n] = doIOAction (toCalendarTime (TOD (round n) 0)) toS allErrs where toS = String . calendarTimeToString lispLocalTime [FltNumber n] = doIOAction (toCalendarTime (TOD (round n) 0)) toS allErrs where toS = String . calendarTimeToString lispLocalTime badArgList = genericIOBadArg badArgList "localtime" "nothing" 0 lispUTCTime :: [LispVal] -> IOThrowsError LispVal lispUTCTime [] = doIOAction getClockTime toS allErrs where toS = String . calendarTimeToString . toUTCTime lispUTCTime [IntNumber n] = return (String (calendarTimeToString (toUTCTime (TOD n 0)))) lispUTCTime [RatNumber n] = return (String (calendarTimeToString (toUTCTime (TOD (round n) 0)))) lispUTCTime [FltNumber n] = return (String (calendarTimeToString (toUTCTime (TOD (round n) 0)))) lispUTCTime badArgList = genericIOBadArg badArgList "UTCtime" "nothing" 0 lispGetCPUTime :: [LispVal] -> IOThrowsError LispVal lispGetCPUTime [] = doIOAction getCPUTime toS allErrs where toS val = FltNumber (1.0e-12 * fromInteger val) lispGetCPUTime badArgList = genericIOBadArg badArgList "cputime" "nothing" 0 statData :: FileStatus -> LispVal statData stat = List [IntNumber (read (show (deviceID stat))), IntNumber (toInteger (fileID stat)), IntNumber (toInteger (fileMode stat)), IntNumber (toInteger (linkCount stat)), IntNumber (toInteger (fileOwner stat)), IntNumber (toInteger (fileGroup stat)), IntNumber (read (show (specialDeviceID stat))), IntNumber (toInteger (fileSize stat)), getET (accessTime stat), getET (modificationTime stat), getET (statusChangeTime stat)] where getET = FltNumber . realToFrac lispGetFileStatus :: [LispVal] -> IOThrowsError LispVal lispGetFileStatus [String filename] = doIOAction (getFileStatus filename) statData allErrs lispGetFileStatus badArgList = genericIOBadArg badArgList "get-file-status" "string" 1 lispGetLinkStatus :: [LispVal] -> IOThrowsError LispVal lispGetLinkStatus [String filename] = doIOAction (getSymbolicLinkStatus filename) statData allErrs lispGetLinkStatus badArgList = genericIOBadArg badArgList "get-link-status" "string" 1 lispIsBlockDevice :: [LispVal] -> IOThrowsError LispVal lispIsBlockDevice [String filename] = doIOAction (getFileStatus filename) (Boolean . isBlockDevice) allErrs lispIsBlockDevice badArgList = genericIOBadArg badArgList "is-block-device?" "string" 1 lispIsCharacterDevice :: [LispVal] -> IOThrowsError LispVal lispIsCharacterDevice [String filename] = doIOAction (getFileStatus filename) (Boolean . isCharacterDevice) allErrs lispIsCharacterDevice badArgList = genericIOBadArg badArgList "is-char-device?" "string" 1 lispIsNamedPipe :: [LispVal] -> IOThrowsError LispVal lispIsNamedPipe [String filename] = doIOAction (getFileStatus filename) (Boolean . isNamedPipe) allErrs lispIsNamedPipe badArgList = genericIOBadArg badArgList "is-named-pipe?" "string" 1 lispIsRegularFile :: [LispVal] -> IOThrowsError LispVal lispIsRegularFile [String filename] = doIOAction (getFileStatus filename) (Boolean . isRegularFile) allErrs lispIsRegularFile badArgList = genericIOBadArg badArgList "is-regular-file?" "string" 1 lispIsDirectory :: [LispVal] -> IOThrowsError LispVal lispIsDirectory [String filename] = doIOAction (getFileStatus filename) (Boolean . isDirectory) allErrs lispIsDirectory badArgList = genericIOBadArg badArgList "is-directory?" "string" 1 lispIsSymbolicLink :: [LispVal] -> IOThrowsError LispVal lispIsSymbolicLink [String filename] = doIOAction (getFileStatus filename) (Boolean . isSymbolicLink) allErrs lispIsSymbolicLink badArgList = genericIOBadArg badArgList "is-symbolic-link?" "string" 1 lispIsSocket :: [LispVal] -> IOThrowsError LispVal lispIsSocket [String filename] = doIOAction (getFileStatus filename) (Boolean . isSocket) allErrs lispIsSocket badArgList = genericIOBadArg badArgList "is-socket?" "string" 1 lispRandUni :: [LispVal] -> IOThrowsError LispVal lispRandUni [] = doIOAction (getStdRandom (randomR (0 :: Double, 1))) FltNumber allErrs lispRandUni [IntNumber lo, IntNumber hi] = if lo < hi then doIOAction (getStdRandom (randomR (lo, hi))) IntNumber allErrs else doIOAction (getStdRandom (randomR (hi, lo))) IntNumber allErrs lispRandUni [FltNumber lo, FltNumber hi] = if lo < hi then doIOAction (getStdRandom (randomR (lo, hi))) FltNumber allErrs else doIOAction (getStdRandom (randomR (hi, lo))) FltNumber allErrs lispRandUni badArgList = genericIOBadArg badArgList "random-uniform" "two numbers" 2 lispRandExp :: [LispVal] -> IOThrowsError LispVal lispRandExp [FltNumber m] = if m > 0 then getrand >>= return . FltNumber . (/ m) . negate . log else genericIOBadArg [FltNumber m] "random-exponential" "positive rate" 1 where getrand = do val <- lispRandUni [] if getnum val == 0 then getrand else return (getnum val) getnum (FltNumber n) = n getnum _ = progError "library/RandExp/getnum" lispRandExp [] = lispRandExp [FltNumber 1.0] lispRandExp [IntNumber m] = lispRandExp [FltNumber (fromInteger m)] lispRandExp [RatNumber m] = lispRandExp [FltNumber (fromRational m)] lispRandExp badArgList = genericIOBadArg badArgList "random-exponential" "number" 1 lispRandNorm :: [LispVal] -> IOThrowsError LispVal lispRandNorm [FltNumber m, FltNumber s] = if s > 0 then do x1 <- getrand x2 <- getrand let a = s*sqrt (-2.0 * log x1) b = 2.0*pi*x2 y1 = m + a * cos b y2 = m + a * sin b return (List [FltNumber y1, FltNumber y2]) else throwError (Default ("random-normal-pair needs a positive stddev," ++ " got " ++ show s)) where getrand = do val <- lispRandUni [] if getnum val == 0 then getrand else return (getnum val) getnum (FltNumber n) = n getnum _ = progError "library/RandNorm/getnum" lispRandNorm [] = lispRandNorm [FltNumber 0.0, FltNumber 1.0] lispRandNorm [IntNumber m, IntNumber s] = lispRandNorm [FltNumber (fromInteger m), FltNumber (fromInteger s)] lispRandNorm [IntNumber m, RatNumber s] = lispRandNorm [FltNumber (fromInteger m), FltNumber (fromRational s)] lispRandNorm [IntNumber m, FltNumber s] = lispRandNorm [FltNumber (fromInteger m), FltNumber s] lispRandNorm [RatNumber m, IntNumber s] = lispRandNorm [FltNumber (fromRational m), FltNumber (fromInteger s)] lispRandNorm [RatNumber m, RatNumber s] = lispRandNorm [FltNumber (fromRational m), FltNumber (fromRational s)] lispRandNorm [RatNumber m, FltNumber s] = lispRandNorm [FltNumber (fromRational m), FltNumber s] lispRandNorm [FltNumber m, IntNumber s] = lispRandNorm [FltNumber m, FltNumber (fromInteger s)] lispRandNorm [FltNumber m, RatNumber s] = lispRandNorm [FltNumber m, FltNumber (fromRational s)] lispRandNorm badArgList = genericIOBadArg badArgList "random-normal-pair" "number" 2 -- TODO: for large lambda, this will be slow! Fix! lispRandPoisson :: [LispVal] -> IOThrowsError LispVal lispRandPoisson [FltNumber lambda] = if lambda > 0 then do val <- doit (exp (-lambda)) (-1) (1 :: Double) return (IntNumber val) else throwError (Default ("random-poisson needs a positive lambda," ++ " got " ++ show lambda)) where doit l k p = do r <- lispRandUni [] let pp = p * getnum r kp = k + 1 if pp < l then return kp else doit l kp pp getnum (FltNumber n) = n getnum _ = progError "library/RandPoisson/getnum" lispRandPoisson [IntNumber m] = lispRandPoisson [FltNumber (fromInteger m)] lispRandPoisson [RatNumber m] = lispRandPoisson [FltNumber (fromRational m)] lispRandPoisson _ = progError "library/RandPoisson" lispSeedRandom :: [LispVal] -> IOThrowsError LispVal lispSeedRandom [IntNumber n] = doIOAction (setStdGen (mkStdGen (fromInteger n))) dropToBool allErrs lispSeedRandom [String s] = doIOAction (setStdGen (read s)) dropToBool allErrs lispSeedRandom badArgList = genericIOBadArg badArgList "random-seed!" "integer or string" 1 lispConnectTo :: [LispVal] -> IOThrowsError LispVal lispConnectTo [String hostname, IntNumber port] = doIOAction (connectTo hostname (PortNumber (fromInteger port))) Port allErrs lispConnectTo [String hostname, String usock] = doIOAction (connectTo hostname (UnixSocket usock)) Port allErrs lispConnectTo badArgList = genericIOBadArg badArgList "connect-to" "host port" 2 lispListenOn :: [LispVal] -> IOThrowsError LispVal lispListenOn [IntNumber port] = doIOAction (listenOn (PortNumber (fromInteger port))) Socket allErrs lispListenOn [String usock] = doIOAction (listenOn (UnixSocket usock)) Socket allErrs lispListenOn badArgList = genericIOBadArg badArgList "listen-on" "port" 1 lispAccept :: [LispVal] -> IOThrowsError LispVal lispAccept [Socket s] = do ret <- liftIO (try (accept s)) case ret of Left err -> throwError (Default (show err)) Right val -> return (List [Port (val1 val), String (val2 val), IntNumber (toInteger (val3 val))]) where val1 (a,_,_) = a val2 (_,b,_) = b val3 (_,_,c) = c lispAccept badArgList = genericIOBadArg badArgList "accept" "socket" 1 lispSetLineBuf :: [LispVal] -> IOThrowsError LispVal lispSetLineBuf [Port h] = doIOAction (hSetBuffering h LineBuffering) dropToBool allErrs lispSetLineBuf badArgList = genericIOBadArg badArgList "set-line-buffering!" "port" 1 lispSetNoBuf :: [LispVal] -> IOThrowsError LispVal lispSetNoBuf [Port h] = doIOAction (hSetBuffering h NoBuffering) dropToBool allErrs lispSetNoBuf badArgList = genericIOBadArg badArgList "set-no-buffering!" "port" 1 -- Old version that was just one argument, no optional working directory -- lispRunCmd :: [LispVal] -> IOThrowsError LispVal -- lispRunCmd [String cmd] = -- doIOAction (system cmd) getStatus allErrs -- where getStatus (ExitSuccess) = IntNumber 0 -- getStatus (ExitFailure n) = IntNumber (fromIntegral n) -- lispRunCmd badArgList = -- genericIOBadArg badArgList "run-command" "command" 1 lispRunCmd :: [LispVal] -> IOThrowsError LispVal lispRunCmd [String cmd] = lispRunCmd [String cmd, String ""] lispRunCmd [String cmd, String dir] = do ret <- liftIO (try (createProcess (shell cmd) { cwd = if dir /= "" then Just dir else Nothing })) case ret of Left err -> throwError (Default (show err)) Right _ -> return lispTrue lispRunCmd badArgList = genericIOBadArg badArgList "run-command" "command+dir" 2 lispReadCmd :: [LispVal] -> IOThrowsError LispVal lispReadCmd [String cmd] = lispReadCmd [String cmd, String ""] lispReadCmd [String cmd, String dir] = do ret <- liftIO (try (createProcess (shell cmd) { cwd = if dir /= "" then Just dir else Nothing, std_out = CreatePipe })) case ret of Left err -> throwError (Default (show err)) Right val -> return (Port (val2 val)) where val2 (_, Just hout, _, _) = hout val2 _ = progError "library/ReadCmd" lispReadCmd badArgList = genericIOBadArg badArgList "run-read-command" "command+dir" 2 lispWriteCmd :: [LispVal] -> IOThrowsError LispVal lispWriteCmd [String cmd] = lispWriteCmd [String cmd, String ""] lispWriteCmd [String cmd, String dir] = do ret <- liftIO (try (createProcess (shell cmd) { cwd = if dir /= "" then Just dir else Nothing, std_in = CreatePipe })) case ret of Left err -> throwError (Default (show err)) Right val -> return (Port (val1 val)) where val1 (Just hin, _, _, _) = hin val1 _ = progError "library/WriteCmd" lispWriteCmd badArgList = genericIOBadArg badArgList "run-write-command" "command+dir" 2 ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] ioPrimitives = [("open-input-file", makePort ReadMode), ("open-output-file", makePort WriteMode), ("open-append-file", makePort AppendMode), ("rename-file", lispRenameFile), ("remove-file", lispRemoveFile), ("create-link", lispCreateLink), ("create-symbolic-link", lispCreateSymbolicLink), ("close-port", closePort), ("raise", lispError), ("display", displayProc), ("read-line", readLine), ("read-char", readChar), ("read-contents", readContents), ("read-all", readAll), ("write-string", lispPutStr), ("flush-port", flushPort), ("exit", lispExit), ("get-current-directory", lispGetCurrentDir), ("set-current-directory", lispSetCurrentDir), ("create-directory", lispCreateDir), ("remove-directory", lispRemoveDir), ("rename-directory", lispRenameDir), ("read-directory", lispGetDirContents), ("file-exists?", lispFileExists), ("directory-exists?", lispDirExists), ("get-environment", lispGetEnv), ("set-environment", lispSetEnv), ("unset-environment", lispUnSetEnv), ("epochtime", lispEpochTime), ("localtime", lispLocalTime), ("UTCtime", lispUTCTime), ("cputime", lispGetCPUTime), ("get-file-status", lispGetFileStatus), ("get-link-status", lispGetLinkStatus), ("is-block-device?", lispIsBlockDevice), ("is-char-device?", lispIsCharacterDevice), ("is-named-pipe?", lispIsNamedPipe), ("is-regular-file?", lispIsRegularFile), ("is-directory?", lispIsDirectory), ("is-symbolic-link?", lispIsSymbolicLink), ("is-socket?", lispIsSocket), ("random-uniform", lispRandUni), ("random-exponential", lispRandExp), ("random-normal-pair", lispRandNorm), ("random-poisson", lispRandPoisson), ("random-seed!", lispSeedRandom), ("set-line-buffering!", lispSetLineBuf), ("set-no-buffering!", lispSetNoBuf), ("connect-to", lispConnectTo), ("listen-on", lispListenOn), ("accept", lispAccept), ("run-command", lispRunCmd), ("run-read-command", lispReadCmd), ("run-write-command", lispWriteCmd)] -- A couple of predefined data values ioPorts :: [(String, LispVal)] ioPorts = [("stdin", Port stdin), ("stdout", Port stdout), ("stderr", Port stderr), ("pi", FltNumber pi)] -- And finally some stuff for internal work -- delayCounter is the name under which a counter for delay objects -- is stored in the environment. It contains spaces, so that it is -- impossible for the user to enter this as a valid symbol. Ditto -- for symbolCounter: this is for generating new internal symbols. -- contCounter is for counting continuations operators; this could -- equally well be done by symbolCounter. delayCounter :: String delayCounter = " delay " symbolCounter :: String symbolCounter = " symbol " contCounter :: String contCounter = " continuation " internals :: [(String, LispVal)] internals = [(delayCounter, (IntNumber 0)), (symbolCounter, (IntNumber 0)), (contCounter, (IntNumber 0))] primitiveBindings :: IO Env primitiveBindings = newIORef [] >>= flip bindVars (internals ++ map (mkf IOPrim) ioPrimitives ++ map (mkf Prim) primitives ++ ioPorts) where mkf constructor (var, func) = (var, constructor func)