IO.hs

{- |
Module      : Language.Egison.Primitives.IO
Licence     : MIT

This module implements primitive functions that performs IO operations.
-}

module Language.Egison.Primitives.IO
  ( ioPrimitives
  ) where

import           Control.Monad.IO.Class           (liftIO)

import           Data.IORef

import           System.IO                        hiding (readFile')
import           System.Process                   (readProcess)
import           System.Random                    (getStdRandom, randomR)

import qualified Data.Text                        as T
import qualified Data.Text.IO                     as T

import           Language.Egison.Core             (evalWHNF)
import           Language.Egison.Data
import           Language.Egison.Primitives.Utils


--
-- IO Primitives
--

ioPrimitives :: [(String, EgisonValue)]
ioPrimitives =
  map (\(name, fn) -> (name, PrimitiveFunc (fn name))) ioStrictPrimitives ++
    map (\(name, fn) -> (name, LazyPrimitiveFunc (fn name))) ioLazyPrimitives

ioStrictPrimitives :: [(String, String -> PrimitiveFunc)]
ioStrictPrimitives =
  [ ("return",          return')
  , ("openInputFile",   makePort ReadMode)
  , ("openOutputFile",  makePort WriteMode)
  , ("closeInputPort",  closePort)
  , ("closeOutputPort", closePort)
  , ("readChar",        readChar)
  , ("readLine",        readLine)
  , ("writeChar",       writeChar)
  , ("write",           writeString)

  , ("readCharFromPort", readCharFromPort)
  , ("readLineFromPort", readLineFromPort)
  , ("writeCharToPort",  writeCharToPort)
  , ("writeToPort",      writeStringToPort)

  , ("isEof",     isEOFStdin)
  , ("flush",     flushStdout)
  , ("isEofPort", isEOFPort)
  , ("flushPort", flushPort)
  , ("readFile",  readFile')

  , ("rand",       randRange)
  , ("f.rand",     randRangeDouble)

  , ("newIORef",   newIORef')
  , ("writeIORef", writeIORef')
  , ("readIORef",  readIORef')

  , ("readProcess", readProcess')
  ]

ioLazyPrimitives :: [(String, String -> LazyPrimitiveFunc)]
ioLazyPrimitives =
  [ ("io", io)
  ]

makeIO :: EvalM EgisonValue -> EgisonValue
makeIO m = IOFunc $ fmap (Value . Tuple . (World :) . (:[])) m

makeIO' :: EvalM () -> EgisonValue
makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []])

return' :: String -> PrimitiveFunc
return' = oneArg' $ \val -> return $ makeIO $ return val

makePort :: IOMode -> String -> PrimitiveFunc
makePort mode = oneArg' $ \val -> do
  filename <- fromEgison val
  port <- liftIO $ openFile (T.unpack filename) mode
  return $ makeIO $ return (Port port)

closePort :: String -> PrimitiveFunc
closePort = oneArg' $ \val -> do
  port <- fromEgison val
  return $ makeIO' $ liftIO $ hClose port

writeChar :: String -> PrimitiveFunc
writeChar = oneArg' $ \val -> do
  c <- fromEgison val
  return $ makeIO' $ liftIO $ putChar c

writeCharToPort :: String -> PrimitiveFunc
writeCharToPort = twoArgs' $ \val val' -> do
  port <- fromEgison val
  c <- fromEgison val'
  return $ makeIO' $ liftIO $ hPutChar port c

writeString :: String -> PrimitiveFunc
writeString = oneArg' $ \val -> do
  s <- fromEgison val
  return $ makeIO' $ liftIO $ T.putStr s

writeStringToPort :: String -> PrimitiveFunc
writeStringToPort = twoArgs' $ \val val' -> do
  port <- fromEgison val
  s <- fromEgison val'
  return $ makeIO' $ liftIO $ T.hPutStr port s

flushStdout :: String -> PrimitiveFunc
flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout

flushPort :: String -> PrimitiveFunc
flushPort = oneArg' $ \val -> do
  port <- fromEgison val
  return $ makeIO' $ liftIO $ hFlush port

readChar :: String -> PrimitiveFunc
readChar = noArg $ return $ makeIO $ liftIO (Char <$> getChar)

readCharFromPort :: String -> PrimitiveFunc
readCharFromPort = oneArg' $ \val -> do
  port <- fromEgison val
  return . makeIO $ liftIO (Char <$> hGetChar port)

readLine :: String -> PrimitiveFunc
readLine = noArg $ return $ makeIO $ liftIO (toEgison <$> T.getLine)

readLineFromPort :: String -> PrimitiveFunc
readLineFromPort = oneArg' $ \val -> do
  port <- fromEgison val
  return $ makeIO $ liftIO (toEgison <$> T.hGetLine port)

readFile' :: String -> PrimitiveFunc
readFile' =  oneArg' $ \val -> do
  filename <- fromEgison val
  return $ makeIO $ liftIO (toEgison <$> T.readFile (T.unpack filename))

isEOFStdin :: String -> PrimitiveFunc
isEOFStdin = noArg $ return $ makeIO $ liftIO (Bool <$> isEOF)

isEOFPort :: String -> PrimitiveFunc
isEOFPort = oneArg' $ \val -> do
  port <- fromEgison val
  return $ makeIO $ liftIO (Bool <$> hIsEOF port)

randRange :: String -> PrimitiveFunc
randRange = twoArgs' $ \val val' -> do
  i <- fromEgison val :: EvalM Integer
  i' <- fromEgison val' :: EvalM Integer
  return $ makeIO $ liftIO (toEgison <$> getStdRandom (randomR (i, i')))

randRangeDouble :: String -> PrimitiveFunc
randRangeDouble = twoArgs' $ \val val' -> do
  i <- fromEgison val :: EvalM Double
  i' <- fromEgison val' :: EvalM Double
  return $ makeIO $ liftIO (toEgison <$> getStdRandom (randomR (i, i')))

newIORef' :: String -> PrimitiveFunc
newIORef' = noArg $ do
  ref <- liftIO $ newIORef Undefined
  return $ makeIO $ return (RefBox ref)

writeIORef' :: String -> PrimitiveFunc
writeIORef' = twoArgs $ \ref val -> do
  ref' <- fromEgison ref
  return $ makeIO' $ liftIO $ writeIORef ref' val

readIORef' :: String -> PrimitiveFunc
readIORef' = oneArg $ \ref -> do
  ref' <- fromEgison ref
  return $ makeIO $ liftIO $ readIORef ref'

readProcess' :: String -> PrimitiveFunc
readProcess' = threeArgs' $ \cmd args input -> do
  cmd'   <- T.unpack <$> fromEgison cmd
  args'  <- map T.unpack <$> fromEgison args
  input' <- T.unpack <$> fromEgison input
  return $ makeIO $ do
    outputStr <- liftIO $ readProcess cmd' args' input'
    return (String (T.pack outputStr))

io :: String -> LazyPrimitiveFunc
io = lazyOneArg io'
  where
    io' (Value (IOFunc m)) = do
      val <- m >>= evalWHNF
      case val of
        Tuple [_, val'] -> return $ Value val'
        _               -> throwErrorWithTrace (TypeMismatch "io" (Value val))
    io' whnf = throwErrorWithTrace (TypeMismatch "io" whnf)