module Language.Egison.Primitives (primitiveEnv, primitiveEnvNoIO) where
import Control.Arrow
import Control.Monad.Error
import Control.Monad.Trans.Maybe
import Data.IORef
import Data.Ratio
import System.IO
import System.Random
import qualified Data.Sequence as Sq
import Data.Char (ord, chr)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Language.Egison.Types
import Language.Egison.Parser
import Language.Egison.Core
primitiveEnv :: IO Env
primitiveEnv = do
let ops = map (second PrimitiveFunc) (primitives ++ ioPrimitives)
bindings <- forM (constants ++ ops) $ \(name, op) -> do
ref <- newIORef . WHNF $ Value op
return (name, ref)
return $ extendEnv nullEnv bindings
primitiveEnvNoIO :: IO Env
primitiveEnvNoIO = do
let ops = map (second PrimitiveFunc) primitives
bindings <- forM (constants ++ ops) $ \(name, op) -> do
ref <- newIORef . WHNF $ Value op
return (name, ref)
return $ extendEnv nullEnv bindings
noArg :: EgisonM EgisonValue -> PrimitiveFunc
noArg f = \args -> do
args' <- tupleToList args
case args' of
[] -> f >>= return . Value
_ -> throwError $ ArgumentsNumPrimitive 0 $ length args'
oneArg :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc
oneArg f = \args -> do
args' <- evalWHNF args
f args' >>= return . Value
twoArgs :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc
twoArgs f = \args -> do
args' <- tupleToList args
case args' of
[val, val'] -> f val val' >>= return . Value
_ -> throwError $ ArgumentsNumPrimitive 2 $ length args'
threeArgs :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc
threeArgs f = \args -> do
args' <- tupleToList args
case args' of
[val, val', val''] -> f val val' val'' >>= return . Value
_ -> throwError $ ArgumentsNumPrimitive 3 $ length args'
tupleToList :: WHNFData -> EgisonM [EgisonValue]
tupleToList whnf = do
val <- evalWHNF whnf
return $ tupleToList' val
where
tupleToList' (Tuple vals) = vals
tupleToList' val = [val]
constants :: [(String, EgisonValue)]
constants = [ ("pi", Float 3.141592653589793) ]
primitives :: [(String, PrimitiveFunc)]
primitives = [ ("+", plus)
, ("-", minus)
, ("*", multiply)
, ("/", divide)
, ("numerator", numerator')
, ("denominator", denominator')
, ("modulo", integerBinaryOp mod)
, ("quotient", integerBinaryOp quot)
, ("remainder", integerBinaryOp rem)
, ("neg", integerUnaryOp negate)
, ("abs", integerUnaryOp abs)
, ("eq?", eq)
, ("lt?", lt)
, ("lte?", lte)
, ("gt?", gt)
, ("gte?", gte)
, ("round", floatToIntegerOp round)
, ("floor", floatToIntegerOp floor)
, ("ceiling", floatToIntegerOp ceiling)
, ("truncate", floatToIntegerOp truncate)
, ("sqrt", floatUnaryOp sqrt)
, ("exp", floatUnaryOp exp)
, ("log", floatUnaryOp log)
, ("sin", floatUnaryOp sin)
, ("cos", floatUnaryOp cos)
, ("tan", floatUnaryOp tan)
, ("asin", floatUnaryOp asin)
, ("acos", floatUnaryOp acos)
, ("atan", floatUnaryOp atan)
, ("sinh", floatUnaryOp sinh)
, ("cosh", floatUnaryOp cosh)
, ("tanh", floatUnaryOp tanh)
, ("asinh", floatUnaryOp asinh)
, ("acosh", floatUnaryOp acosh)
, ("atanh", floatUnaryOp atanh)
, ("itof", integerToFloat)
, ("rtof", rationalToFloat)
, ("ctoi", charToInteger)
, ("itoc", integerToChar)
, ("pack", pack)
, ("unpack", unpack)
, ("uncons-string", unconsString)
, ("length-string", lengthString)
, ("append-string", appendString)
, ("split-string", splitString)
, ("read", read')
, ("read-tsv", readTSV)
, ("show", show')
, ("show-tsv", showTSV')
, ("empty?", isEmpty')
, ("uncons", uncons')
, ("unsnoc", unsnoc')
, ("bool?", isBool)
, ("integer?", isInteger)
, ("rational?", isRational)
, ("float?", isFloat)
, ("char?", isChar)
, ("string?", isString)
, ("tuple?", isTuple)
, ("collection?", isCollection)
, ("array?", isArray)
, ("hash?", isHash)
, ("assert", assert)
, ("assert-equal", assertEqual)
]
integerUnaryOp :: (Integer -> Integer) -> PrimitiveFunc
integerUnaryOp op = oneArg $ \val -> do
i <- fromEgison val
return $ Integer $ op i
integerBinaryOp :: (Integer -> Integer -> Integer) -> PrimitiveFunc
integerBinaryOp op = twoArgs $ \val val' -> do
i <- fromEgison val
i' <- fromEgison val'
return $ Integer $ op i i'
integerBinaryPred :: (Integer -> Integer -> Bool) -> PrimitiveFunc
integerBinaryPred pred = twoArgs $ \val val' -> do
i <- fromEgison val
i' <- fromEgison val'
return $ Bool $ pred i i'
floatUnaryOp :: (Double -> Double) -> PrimitiveFunc
floatUnaryOp op = oneArg $ \val -> do
case val of
(Float f) -> return $ Float $ op f
(Integer i) -> return $ Float $ op (fromIntegral i)
(Rational r) -> return $ Float $ op (fromRational r)
floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc
floatBinaryOp op = twoArgs $ \val val' -> do
f <- fromEgison val
f' <- fromEgison val'
return $ Float $ op f f'
floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc
floatBinaryPred pred = twoArgs $ \val val' -> do
f <- fromEgison val
f' <- fromEgison val'
return $ Bool $ pred f f'
plus :: PrimitiveFunc
plus = twoArgs $ \val val' -> numberBinaryOp' val val'
where
numberBinaryOp' (Integer i) (Integer i') = return $ Integer $ (+) i i'
numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val
numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1))
numberBinaryOp' (Rational r) (Rational r') = let y = (+) r r' in
if denominator y == 1
then return $ Integer $ numerator y
else return $ Rational y
numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f)
numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r))
numberBinaryOp' (Float f) (Float f') = return $ Float $ (+) f f'
numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val)
minus :: PrimitiveFunc
minus = twoArgs $ \val val' -> numberBinaryOp' val val'
where
numberBinaryOp' (Integer i) (Integer i') = return $ Integer $ () i i'
numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val
numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1))
numberBinaryOp' (Rational r) (Rational r') = let y = () r r' in
if denominator y == 1
then return $ Integer $ numerator y
else return $ Rational y
numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f)
numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r))
numberBinaryOp' (Float f) (Float f') = return $ Float $ () f f'
numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val)
multiply :: PrimitiveFunc
multiply = twoArgs $ \val val' -> numberBinaryOp' val val'
where
numberBinaryOp' (Integer i) (Integer i') = return $ Integer $ (*) i i'
numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val
numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1))
numberBinaryOp' (Rational r) (Rational r') = let y = (*) r r' in
if denominator y == 1
then return $ Integer $ numerator y
else return $ Rational y
numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f)
numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r))
numberBinaryOp' (Float f) (Float f') = return $ Float $ (*) f f'
numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val)
divide :: PrimitiveFunc
divide = twoArgs $ \val val' -> numberBinaryOp' val val'
where
numberBinaryOp' (Integer i) (Integer i') = numberBinaryOp' (Rational (i % 1)) (Rational (i' % 1))
numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val
numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1))
numberBinaryOp' (Rational r) (Rational r') =
let m = numerator r' in
let n = denominator r' in
let y = (r * (n % m)) in
if denominator y == 1
then return $ Integer $ numerator y
else return $ Rational y
numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f)
numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r))
numberBinaryOp' (Float f) (Float f') = return $ Float $ (/) f f'
numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val)
numerator' :: PrimitiveFunc
numerator' = oneArg $ numerator''
where
numerator'' (Rational rat) = do
return $ Integer (numerator rat)
numerator'' (Integer x) = do
return $ Integer x
numerator'' val = throwError $ TypeMismatch "rational" (Value val)
denominator' :: PrimitiveFunc
denominator' = oneArg $ denominator''
where
denominator'' (Rational rat) = do
return $ Integer (denominator rat)
denominator'' (Integer x) = do
return $ Integer 1
denominator'' val = throwError $ TypeMismatch "rational" (Value val)
eq :: PrimitiveFunc
eq = twoArgs $ \val val' ->
return $ Bool $ val == val'
lt :: PrimitiveFunc
lt = twoArgs $ \val val' -> numberBinaryPred' val val'
where
numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (<) i i'
numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val
numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1))
numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (<) r r'
numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f)
numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r))
numberBinaryPred' (Float f) (Float f') = return $ Bool $ (<) f f'
numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val)
lte :: PrimitiveFunc
lte = twoArgs $ \val val' -> numberBinaryPred' val val'
where
numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (<=) i i'
numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val
numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1))
numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (<=) r r'
numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f)
numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r))
numberBinaryPred' (Float f) (Float f') = return $ Bool $ (<=) f f'
numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val)
gt :: PrimitiveFunc
gt = twoArgs $ \val val' -> numberBinaryPred' val val'
where
numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (>) i i'
numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val
numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1))
numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (>) r r'
numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f)
numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r))
numberBinaryPred' (Float f) (Float f') = return $ Bool $ (>) f f'
numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val)
gte :: PrimitiveFunc
gte = twoArgs $ \val val' -> numberBinaryPred' val val'
where
numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (>=) i i'
numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val
numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1))
numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (>=) r r'
numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f)
numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r))
numberBinaryPred' (Float f) (Float f') = return $ Bool $ (>=) f f'
numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val)
numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val)
integerToFloat :: PrimitiveFunc
integerToFloat = oneArg $ \val -> do
i <- fromEgison val
return $ Float $ fromInteger i
rationalToFloat :: PrimitiveFunc
rationalToFloat = oneArg $ \val -> do
case val of
Integer i -> return $ Float $ fromInteger i
Rational r -> return $ Float $ fromRational r
_ -> throwError $ TypeMismatch "integer of rational number" (Value val)
charToInteger :: PrimitiveFunc
charToInteger = oneArg $ \val -> do
case val of
Char c -> return $ Integer $ fromIntegral $ ord c
_ -> throwError $ TypeMismatch "character" (Value val)
integerToChar :: PrimitiveFunc
integerToChar = oneArg $ \val -> do
case val of
Integer i -> return $ Char $ chr $ fromIntegral i
_ -> throwError $ TypeMismatch "character" (Value val)
floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc
floatToIntegerOp op = oneArg $ \val -> do
f <- fromEgison val
return $ Integer $ op f
pack :: PrimitiveFunc
pack = oneArg $ \val -> do
str <- packStringValue val
return $ String str
unpack :: PrimitiveFunc
unpack = oneArg $ \val -> do
case val of
String str -> return $ toEgison (T.unpack str)
_ -> throwError $ TypeMismatch "string" (Value val)
unconsString :: PrimitiveFunc
unconsString = oneArg $ \val -> do
case val of
String str -> case T.uncons str of
Just (c, rest) -> return $ Tuple [Char c, String rest]
Nothing -> throwError $ Default "Tried to unsnoc empty string"
_ -> throwError $ TypeMismatch "string" (Value val)
lengthString :: PrimitiveFunc
lengthString = oneArg $ \val -> do
case val of
String str -> return . Integer . toInteger $ T.length str
_ -> throwError $ TypeMismatch "string" (Value val)
appendString :: PrimitiveFunc
appendString = twoArgs $ \val1 val2 -> do
case (val1, val2) of
(String str1, String str2) -> return . String $ T.append str1 str2
(String _, _) -> throwError $ TypeMismatch "string" (Value val2)
(_, _) -> throwError $ TypeMismatch "string" (Value val1)
splitString :: PrimitiveFunc
splitString = twoArgs $ \pat src -> do
case (pat, src) of
(String patStr, String srcStr) -> return . Collection . Sq.fromList $ map String $ T.splitOn patStr srcStr
(String _, _) -> throwError $ TypeMismatch "string" (Value src)
(_, _) -> throwError $ TypeMismatch "string" (Value pat)
read' :: PrimitiveFunc
read'= oneArg $ \val -> fromEgison val >>= readExpr . T.unpack >>= evalExprDeep nullEnv
readTSV :: PrimitiveFunc
readTSV= oneArg $ \val -> do rets <- fromEgison val >>= readExprs . T.unpack >>= mapM (evalExprDeep nullEnv)
case rets of
[ret] -> return ret
_ -> return (Tuple rets)
show' :: PrimitiveFunc
show'= oneArg $ \val -> return $ toEgison $ T.pack $ show val
showTSV' :: PrimitiveFunc
showTSV'= oneArg $ \val -> return $ toEgison $ T.pack $ showTSV val
isEmpty' :: PrimitiveFunc
isEmpty' whnf = do
b <- isEmptyCollection whnf
if b
then return $ Value $ Bool True
else return $ Value $ Bool False
uncons' :: PrimitiveFunc
uncons' whnf = do
mRet <- runMaybeT (unconsCollection whnf)
case mRet of
Just (carObjRef, cdrObjRef) -> return $ Intermediate $ ITuple [carObjRef, cdrObjRef]
Nothing -> throwError $ Default $ "cannot uncons collection"
unsnoc' :: PrimitiveFunc
unsnoc' whnf = do
mRet <- runMaybeT (unsnocCollection whnf)
case mRet of
Just (racObjRef, rdcObjRef) -> return $ Intermediate $ ITuple [racObjRef, rdcObjRef]
Nothing -> throwError $ Default $ "cannot unsnoc collection"
isBool :: PrimitiveFunc
isBool (Value (Bool _)) = return $ Value $ Bool True
isBool _ = return $ Value $ Bool False
isInteger :: PrimitiveFunc
isInteger (Value (Integer _)) = return $ Value $ Bool True
isInteger _ = return $ Value $ Bool False
isRational :: PrimitiveFunc
isRational (Value (Integer _)) = return $ Value $ Bool True
isRational (Value (Rational _)) = return $ Value $ Bool True
isRational _ = return $ Value $ Bool False
isFloat :: PrimitiveFunc
isFloat (Value (Float _)) = return $ Value $ Bool True
isFloat _ = return $ Value $ Bool False
isChar :: PrimitiveFunc
isChar (Value (Char _)) = return $ Value $ Bool True
isChar _ = return $ Value $ Bool False
isString :: PrimitiveFunc
isString (Value (String _)) = return $ Value $ Bool True
isString _ = return $ Value $ Bool False
isTuple :: PrimitiveFunc
isTuple args = do
args' <- fromTuple args
case args' of
((Value (Integer n)):whnf:[]) -> isTuple' n whnf
(whnf:_) -> throwError $ TypeMismatch "number" whnf
where
fromTuple :: WHNFData -> EgisonM [WHNFData]
fromTuple (Intermediate (ITuple refs)) = do
objs <- liftIO $ mapM readIORef refs
mapM (\obj -> case obj of
Thunk thunk -> thunk
WHNF whnf -> return whnf) objs
fromTuple (Value (Tuple vals)) = return $ map Value vals
fromTuple whnf = return [whnf]
isTuple' :: Integer -> WHNFData -> EgisonM WHNFData
isTuple' n (Value (Tuple vals)) =
if n == ((fromIntegral (length vals)) :: Integer)
then return $ Value $ Bool True
else return $ Value $ Bool False
isTuple' n (Intermediate (ITuple refs)) =
if n == ((fromIntegral (length refs)) :: Integer)
then return $ Value $ Bool True
else return $ Value $ Bool False
isTuple' 1 _ = return $ Value $ Bool True
isTuple' _ _ = return $ Value $ Bool False
isCollection :: PrimitiveFunc
isCollection (Value (Collection _)) = return $ Value $ Bool True
isCollection (Intermediate (ICollection _)) = return $ Value $ Bool True
isCollection _ = return $ Value $ Bool False
isArray :: PrimitiveFunc
isArray (Value (Array _)) = return $ Value $ Bool True
isArray (Intermediate (IArray _)) = return $ Value $ Bool True
isArray _ = return $ Value $ Bool False
isHash :: PrimitiveFunc
isHash (Value (IntHash _)) = return $ Value $ Bool True
isHash (Value (StrHash _)) = return $ Value $ Bool True
isHash (Intermediate (IIntHash _)) = return $ Value $ Bool True
isHash (Intermediate (IStrHash _)) = return $ Value $ Bool True
isHash _ = return $ Value $ Bool False
assert :: PrimitiveFunc
assert = twoArgs $ \label test -> do
test <- fromEgison test
if test
then return $ Bool True
else throwError $ Assertion $ show label
assertEqual :: PrimitiveFunc
assertEqual = threeArgs $ \label actual expected -> do
if actual == expected
then return $ Bool True
else throwError $ Assertion $ show label ++ "\n expected: " ++ show expected ++
"\n but found: " ++ show actual
ioPrimitives :: [(String, PrimitiveFunc)]
ioPrimitives = [
("return", return')
, ("open-input-file", makePort ReadMode)
, ("open-output-file", makePort WriteMode)
, ("close-input-port", closePort)
, ("close-output-port", closePort)
, ("read-char", readChar)
, ("read-line", readLine)
, ("write-char", writeChar)
, ("write", writeString)
, ("read-char-from-port", readCharFromPort)
, ("read-line-from-port", readLineFromPort)
, ("write-char-to-port", writeCharToPort)
, ("write-to-port", writeStringToPort)
, ("eof?", isEOFStdin)
, ("flush", flushStdout)
, ("eof-port?", isEOFPort)
, ("flush-port", flushPort)
, ("read-file", readFile')
, ("rand", randRange)
]
makeIO :: EgisonM EgisonValue -> EgisonValue
makeIO m = IOFunc $ liftM (Value . Tuple . (World :) . (:[])) m
makeIO' :: EgisonM () -> EgisonValue
makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []])
return' :: PrimitiveFunc
return' = oneArg $ \val -> return $ makeIO $ return val
makePort :: IOMode -> PrimitiveFunc
makePort mode = oneArg $ \val -> do
filename <- fromEgison val
port <- liftIO $ openFile (T.unpack filename) mode
return $ makeIO $ return (Port port)
closePort :: PrimitiveFunc
closePort = oneArg $ \val -> do
port <- fromEgison val
return $ makeIO' $ liftIO $ hClose port
writeChar :: PrimitiveFunc
writeChar = oneArg $ \val -> do
c <- fromEgison val
return $ makeIO' $ liftIO $ putChar c
writeCharToPort :: PrimitiveFunc
writeCharToPort = twoArgs $ \val val' -> do
port <- fromEgison val
c <- fromEgison val'
return $ makeIO' $ liftIO $ hPutChar port c
writeString :: PrimitiveFunc
writeString = oneArg $ \val -> do
s <- fromEgison val
return $ makeIO' $ liftIO $ T.putStr s
writeStringToPort :: PrimitiveFunc
writeStringToPort = twoArgs $ \val val' -> do
port <- fromEgison val
s <- fromEgison val'
return $ makeIO' $ liftIO $ T.hPutStr port s
flushStdout :: PrimitiveFunc
flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout
flushPort :: PrimitiveFunc
flushPort = oneArg $ \val -> do
port <- fromEgison val
return $ makeIO' $ liftIO $ hFlush port
readChar :: PrimitiveFunc
readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar
readCharFromPort :: PrimitiveFunc
readCharFromPort = oneArg $ \val -> do
port <- fromEgison val
c <- liftIO $ hGetChar port
return $ makeIO $ return (Char c)
readLine :: PrimitiveFunc
readLine = noArg $ return $ makeIO $ liftIO $ liftM toEgison T.getLine
readLineFromPort :: PrimitiveFunc
readLineFromPort = oneArg $ \val -> do
port <- fromEgison val
s <- liftIO $ T.hGetLine port
return $ makeIO $ return $ toEgison s
readFile' :: PrimitiveFunc
readFile' = oneArg $ \val -> do
filename <- fromEgison val
s <- liftIO $ T.readFile filename
return $ makeIO $ return $ toEgison s
isEOFStdin :: PrimitiveFunc
isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF
isEOFPort :: PrimitiveFunc
isEOFPort = oneArg $ \val -> do
port <- fromEgison val
b <- liftIO $ hIsEOF port
return $ makeIO $ return (Bool b)
randRange :: PrimitiveFunc
randRange = twoArgs $ \val val' -> do
i <- fromEgison val
i' <- fromEgison val'
n <- liftIO $ getStdRandom $ randomR (i, i')
return $ makeIO $ return (Integer n)