--  --                                                          ; {{{1
--
--  File        : Koneko/IO.hs
--  Maintainer  : Felix C. Stegerman <flx@obfusk.net>
--  Date        : 2020-11-12
--
--  Copyright   : Copyright (C) 2020  Felix C. Stegerman
--  Version     : v0.0.1
--  License     : GPLv3+
--
--  --                                                          ; }}}1

{-# LANGUAGE OverloadedStrings #-}

module Koneko.IO (initCtx) where

import Control.Exception (throwIO)
import Data.Foldable (traverse_)
import System.IO.Error (tryIOError)

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

import Koneko.Data

initCtx :: Context -> IO ()
initCtx :: Context -> IO ()
initCtx Context
ctxMain = do
  Context
ctx <- Identifier -> Context -> IO Context
forkContext Identifier
"io" Context
ctxMain
  (Builtin -> IO ()) -> [Builtin] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Context -> Builtin -> IO ()
defPrim Context
ctx) [Builtin
ioContents, Builtin
ioLines]

ioContents, ioLines :: Builtin

ioContents :: Builtin
ioContents = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"contents!" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
    (Identifier
x, Stack
s') <- Stack -> IO (Identifier, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s
    (IO Identifier -> IO (Either IOError Identifier)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO Identifier -> IO (Either IOError Identifier))
-> IO Identifier -> IO (Either IOError Identifier)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Identifier
T.readFile (FilePath -> IO Identifier) -> FilePath -> IO Identifier
forall a b. (a -> b) -> a -> b
$ Identifier -> FilePath
T.unpack Identifier
x) IO (Either IOError Identifier)
-> (Either IOError Identifier -> IO Stack) -> IO Stack
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IOError -> IO Stack)
-> (Identifier -> IO Stack)
-> Either IOError Identifier
-> IO Stack
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOError -> IO Stack
forall a. IOError -> IO a
f (Stack -> Identifier -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s')
  where
    f :: IOError -> IO a
f = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> (IOError -> KException) -> IOError -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> KException
Fail (FilePath -> KException)
-> (IOError -> FilePath) -> IOError -> KException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"io.contents!: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> (IOError -> FilePath) -> IOError -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> FilePath
forall a. Show a => a -> FilePath
show

ioLines :: Builtin
ioLines = Identifier -> Evaluator -> Builtin
mkBltn Identifier
"lines!" (Evaluator -> Builtin) -> Evaluator -> Builtin
forall a b. (a -> b) -> a -> b
$ \Context
_ Stack
s -> do
    (Identifier
x, Stack
s') <- Stack -> IO (Identifier, Stack)
forall a. FromVal a => Stack -> IO (a, Stack)
pop' Stack
s
    (IO Stack -> IO (Either IOError Stack)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO Stack -> IO (Either IOError Stack))
-> IO Stack -> IO (Either IOError Stack)
forall a b. (a -> b) -> a -> b
$ (Identifier -> Stack) -> IO Identifier -> IO Stack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Identifier -> KValue) -> [Identifier] -> Stack
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> KValue
str ([Identifier] -> Stack)
-> (Identifier -> [Identifier]) -> Identifier -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> [Identifier]
T.lines) (IO Identifier -> IO Stack) -> IO Identifier -> IO Stack
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Identifier
T.readFile (FilePath -> IO Identifier) -> FilePath -> IO Identifier
forall a b. (a -> b) -> a -> b
$ Identifier -> FilePath
T.unpack Identifier
x)
      IO (Either IOError Stack)
-> (Either IOError Stack -> IO Stack) -> IO Stack
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IOError -> IO Stack)
-> (Stack -> IO Stack) -> Either IOError Stack -> IO Stack
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOError -> IO Stack
forall a. IOError -> IO a
f (Stack -> Stack -> IO Stack
forall a. ToVal a => Stack -> a -> IO Stack
rpush1 Stack
s')
  where
    f :: IOError -> IO a
f = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> (IOError -> KException) -> IOError -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> KException
Fail (FilePath -> KException)
-> (IOError -> FilePath) -> IOError -> KException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"io.lines!: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> (IOError -> FilePath) -> IOError -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> FilePath
forall a. Show a => a -> FilePath
show

-- vim: set tw=70 sw=2 sts=2 et fdm=marker :