<commit_before>{-# LANGUAGE QuasiQuotes #-}
module Atomo.Kernel.Ports (load) where

import Data.Char (isSpace)
import Data.Maybe (catMaybes)
import System.Console.Haskeline as Haskeline
import System.Directory
import System.FilePath ((</>), (<.>))
import System.IO
import qualified Data.Text.IO as TIO

import Atomo
import Atomo.Parser
import Atomo.Pretty


load :: VM ()
load = do
    ([$p|Port|] =::) =<< eval [$e|Object clone|]
    ([$p|File|] =::) =<< eval [$e|Object clone|]
    ([$p|Directory|] =::) =<< eval [$e|Object clone|]

    sinp <- portObj stdin
    soutp <- portObj stdout
    serrp <- portObj stderr
    [$p|Port standard-input|] =:: sinp
    [$p|Port standard-output|] =:: soutp
    [$p|Port standard-error|] =:: serrp

    [$p|(p: Port) show|] =: do
        hdl <- getHandle [$e|p handle|] >>= liftIO . hShow
        return (string ("<port " ++ hdl ++ ">"))

    [$p|Port new: (fn: String)|] =::: [$e|Port new: fn mode: @read-write|]
    [$p|Port new: (fn: String) mode: (m: Particle)|] =: do
        fn <- getString [$e|fn|]
        Particle m <- here "m" >>= findParticle

        hdl <- case m of
            PMSingle "read" ->
                liftIO (openFile fn ReadMode)
            PMSingle "write" ->
                liftIO (openFile fn WriteMode)
            PMSingle "append" ->
                liftIO (openFile fn AppendMode)
            PMSingle "read-write" ->
                liftIO (openFile fn ReadWriteMode)
            _ ->
                error $ "unknown port mode: " ++ show (pretty m) ++ ", must be one of: @read, @write, @append, @read-write"

        portObj hdl

    [$p|(p: Port) print: x|] =: do
        x <- here "x"
        port <- here "p"
        hdl <- getHandle [$e|p handle|]

        c <- liftIO (hIsClosed hdl)
        when c (raise ["port-closed", "for"] [port, x])

        String s <- eval [$e|x as: String|] >>= findString

        liftIO (TIO.hPutStrLn hdl s)
        liftIO (hFlush hdl)
        return x

    [$p|(p: Port) display: x|] =: do
        x <- here "x"
        port <- here "p"
        hdl <- getHandle [$e|p handle|]

        c <- liftIO (hIsClosed hdl)
        when c (raise ["port-closed", "for"] [port, x])

        String s <- eval [$e|x as: String|] >>= findString

        liftIO (TIO.hPutStr hdl s)
        liftIO (hFlush hdl)
        return x

    [$p|(p: Port) read|] =: do
        h <- getHandle [$e|p handle|]

        segment <- liftIO (hGetSegment h)
        parsed <- continuedParse segment "<read>"

        let isPrimitive (Primitive {}) = True
            isPrimitive (EParticle { eParticle = PMSingle _ }) = True
            isPrimitive (EParticle { eParticle = PMKeyword _ ts }) =
                all isPrimitive (catMaybes ts)
            isPrimitive (EList { eContents = ts }) = all isPrimitive ts
            isPrimitive _ = False

        case parsed of
            [] -> raise' "no-expressions-parsed"
            is | all isPrimitive is -> evalAll is
            (i:_) -> return (Expression i)

    [$p|(p: Port) read-line|] =: do
        h <- getHandle [$e|p handle|]
        done <- liftIO (hIsEOF h)

        if done
            then raise' "end-of-input"
            else liftM String $ liftIO (TIO.hGetLine h)

    [$p|(p: Port) read-char|] =: do
        h <- getHandle [$e|p handle|]
        b <- liftIO (hGetBuffering h)
        liftIO (hSetBuffering h NoBuffering)
        c <- liftIO (hGetChar h)
        liftIO (hSetBuffering h b)

        return (Char c)

    [$p|(p: Port) contents|] =:
        getHandle [$e|p handle|] >>= liftM String . liftIO . TIO.hGetContents

    [$p|(p: Port) flush|] =:
        getHandle [$e|p handle|] >>= liftIO . hFlush
            >> return (particle "ok")

    [$p|(p: Port) close|] =:
        getHandle [$e|p handle|] >>= liftIO . hClose
            >> return (particle "ok")

    [$p|(p: Port) open?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsOpen

    [$p|(p: Port) closed?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsClosed

    [$p|(p: Port) readable?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsReadable

    [$p|(p: Port) writable?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsWritable

    [$p|(p: Port) seekable?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsSeekable

    [$p|(p: Port) ready?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hReady

    [$p|(p: Port) eof?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsEOF


    [$p|File new: (fn: String)|] =::: [$e|Port new: fn|]
    [$p|File open: (fn: String)|] =::: [$e|Port new: fn|]

    [$p|File read: (fn: String)|] =:::
        [$e|Port (new: fn mode: @read) ensuring: @close do: @contents|]

    [$p|File delete: (fn: String)|] =: do
        fn <- getString [$e|fn|]
        liftIO (removeFile fn)
        return (particle "ok")

    [$p|File move: (from: String) to: (to: String)|] =:::
        [$e|File rename: from to: to|]
    [$p|File rename: (from: String) to: (to: String)|] =: do
        from <- getString [$e|from|]
        to <- getString [$e|to|]
        liftIO (renameFile from to)
        return (particle "ok")

    [$p|File copy: (from: String) to: (to: String)|] =: do
        from <- getString [$e|from|]
        to <- getString [$e|to|]
        liftIO (copyFile from to)
        return (particle "ok")

    [$p|File canonicalize-path: (fn: String)|] =: do
        fn <- getString [$e|fn|]
        liftM string $ liftIO (canonicalizePath fn)

    [$p|File make-relative: (fn: String)|] =: do
        fn <- getString [$e|fn|]
        liftM string $ liftIO (makeRelativeToCurrentDirectory fn)

    [$p|File exists?: (fn: String)|] =: do
        fn <- getString [$e|fn|]
        liftM Boolean $ liftIO (doesFileExist fn)<commit_msg>corrected @(File delete: String) crashing and burning if the file does not exist<commit_after>{-# LANGUAGE QuasiQuotes #-}
module Atomo.Kernel.Ports (load) where

import Data.Char (isSpace)
import Data.Maybe (catMaybes)
import System.Console.Haskeline as Haskeline
import System.Directory
import System.FilePath ((</>), (<.>))
import System.IO
import qualified Data.Text.IO as TIO

import Atomo
import Atomo.Parser
import Atomo.Pretty


load :: VM ()
load = do
    ([$p|Port|] =::) =<< eval [$e|Object clone|]
    ([$p|File|] =::) =<< eval [$e|Object clone|]
    ([$p|Directory|] =::) =<< eval [$e|Object clone|]

    sinp <- portObj stdin
    soutp <- portObj stdout
    serrp <- portObj stderr
    [$p|Port standard-input|] =:: sinp
    [$p|Port standard-output|] =:: soutp
    [$p|Port standard-error|] =:: serrp

    [$p|(p: Port) show|] =: do
        hdl <- getHandle [$e|p handle|] >>= liftIO . hShow
        return (string ("<port " ++ hdl ++ ">"))

    [$p|Port new: (fn: String)|] =::: [$e|Port new: fn mode: @read-write|]
    [$p|Port new: (fn: String) mode: (m: Particle)|] =: do
        fn <- getString [$e|fn|]
        Particle m <- here "m" >>= findParticle

        hdl <- case m of
            PMSingle "read" ->
                liftIO (openFile fn ReadMode)
            PMSingle "write" ->
                liftIO (openFile fn WriteMode)
            PMSingle "append" ->
                liftIO (openFile fn AppendMode)
            PMSingle "read-write" ->
                liftIO (openFile fn ReadWriteMode)
            _ ->
                error $ "unknown port mode: " ++ show (pretty m) ++ ", must be one of: @read, @write, @append, @read-write"

        portObj hdl

    [$p|(p: Port) print: x|] =: do
        x <- here "x"
        port <- here "p"
        hdl <- getHandle [$e|p handle|]

        c <- liftIO (hIsClosed hdl)
        when c (raise ["port-closed", "for"] [port, x])

        String s <- eval [$e|x as: String|] >>= findString

        liftIO (TIO.hPutStrLn hdl s)
        liftIO (hFlush hdl)
        return x

    [$p|(p: Port) display: x|] =: do
        x <- here "x"
        port <- here "p"
        hdl <- getHandle [$e|p handle|]

        c <- liftIO (hIsClosed hdl)
        when c (raise ["port-closed", "for"] [port, x])

        String s <- eval [$e|x as: String|] >>= findString

        liftIO (TIO.hPutStr hdl s)
        liftIO (hFlush hdl)
        return x

    [$p|(p: Port) read|] =: do
        h <- getHandle [$e|p handle|]

        segment <- liftIO (hGetSegment h)
        parsed <- continuedParse segment "<read>"

        let isPrimitive (Primitive {}) = True
            isPrimitive (EParticle { eParticle = PMSingle _ }) = True
            isPrimitive (EParticle { eParticle = PMKeyword _ ts }) =
                all isPrimitive (catMaybes ts)
            isPrimitive (EList { eContents = ts }) = all isPrimitive ts
            isPrimitive _ = False

        case parsed of
            [] -> raise' "no-expressions-parsed"
            is | all isPrimitive is -> evalAll is
            (i:_) -> return (Expression i)

    [$p|(p: Port) read-line|] =: do
        h <- getHandle [$e|p handle|]
        done <- liftIO (hIsEOF h)

        if done
            then raise' "end-of-input"
            else liftM String $ liftIO (TIO.hGetLine h)

    [$p|(p: Port) read-char|] =: do
        h <- getHandle [$e|p handle|]
        b <- liftIO (hGetBuffering h)
        liftIO (hSetBuffering h NoBuffering)
        c <- liftIO (hGetChar h)
        liftIO (hSetBuffering h b)

        return (Char c)

    [$p|(p: Port) contents|] =:
        getHandle [$e|p handle|] >>= liftM String . liftIO . TIO.hGetContents

    [$p|(p: Port) flush|] =:
        getHandle [$e|p handle|] >>= liftIO . hFlush
            >> return (particle "ok")

    [$p|(p: Port) close|] =:
        getHandle [$e|p handle|] >>= liftIO . hClose
            >> return (particle "ok")

    [$p|(p: Port) open?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsOpen

    [$p|(p: Port) closed?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsClosed

    [$p|(p: Port) readable?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsReadable

    [$p|(p: Port) writable?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsWritable

    [$p|(p: Port) seekable?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsSeekable

    [$p|(p: Port) ready?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hReady

    [$p|(p: Port) eof?|] =:
        getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsEOF


    [$p|File new: (fn: String)|] =::: [$e|Port new: fn|]
    [$p|File open: (fn: String)|] =::: [$e|Port new: fn|]

    [$p|File read: (fn: String)|] =:::
        [$e|Port (new: fn mode: @read) ensuring: @close do: @contents|]

    [$p|File delete: (fn: String)|] =: do
        fn <- getString [$e|fn|]
        b <- liftIO (doesFileExist fn)

        if b
           then liftIO (removeFile fn)
           else raise ["file-not-found"] [string fn]

        return (particle "ok")

    [$p|File move: (from: String) to: (to: String)|] =:::
        [$e|File rename: from to: to|]
    [$p|File rename: (from: String) to: (to: String)|] =: do
        from <- getString [$e|from|]
        to <- getString [$e|to|]
        liftIO (renameFile from to)
        return (particle "ok")

    [$p|File copy: (from: String) to: (to: String)|] =: do
        from <- getString [$e|from|]
        to <- getString [$e|to|]
        liftIO (copyFile from to)
        return (particle "ok")

    [$p|File canonicalize-path: (fn: String)|] =: do
        fn <- getString [$e|fn|]
        liftM string $ liftIO (canonicalizePath fn)

    [$p|File make-relative: (fn: String)|] =: do
        fn <- getString [$e|fn|]
        liftM string $ liftIO (makeRelativeToCurrentDirectory fn)

    [$p|File exists?: (fn: String)|] =: do
        fn <- getString [$e|fn|]
        liftM Boolean $ liftIO (doesFileExist fn)
{'fraction_non_alphanumeric': 0.16863805339641771, 'fraction_numerical': 0.0, 'mean_word_length': 2.1556918155158624, 'pattern_counts': {'":': 0, '<': 90, '<?xml version=': 0, '>': 91, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2455807', 'n_tokens_mistral': 4378, 'n_tokens_neox': 4078, 'n_words': 1183}