atomo-0.1: src/Atomo/Kernel/Ports.hs
{-# LANGUAGE QuasiQuotes #-}
module Atomo.Kernel.Ports (load) where
import Data.Char (isSpace)
import Data.Dynamic
import Data.Maybe (catMaybes)
import System.Directory
import System.FilePath ((</>), (<.>))
import System.IO
import qualified Data.Text.IO as TIO
import Atomo.Environment
import Atomo.Haskell
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|current-output-port|] =::) =<< eval [$e|Parameter new: Port standard-output|]
([$p|current-input-port|] =::) =<< eval [$e|Parameter new: Port standard-input|]
[$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|(x: Object) print|] =::: [$e|current-output-port _? print: x|]
[$p|(p: Port) print: x|] =: do
x <- here "x"
hdl <- getHandle [$e|p handle|]
String s <- eval [$e|x as: String|] >>= findString
liftIO (TIO.hPutStrLn hdl s)
liftIO (hFlush hdl)
return x
[$p|(x: Object) display|] =::: [$e|current-output-port _? display: x|]
[$p|(p: Port) display: x|] =: do
x <- here "x"
hdl <- getHandle [$e|p handle|]
String s <- eval [$e|x as: String|] >>= findString
liftIO (TIO.hPutStr hdl s)
liftIO (hFlush hdl)
return x
[$p|read|] =::: [$e|current-input-port _? read|]
[$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 = EPMSingle _ }) = True
isPrimitive (EParticle { eParticle = EPMKeyword _ 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|read-line|] =::: [$e|current-input-port _? read-line|]
[$p|(p: Port) read-line|] =: do
getHandle [$e|p handle|] >>= liftIO . TIO.hGetLine
>>= return . String
[$p|contents|] =::: [$e|current-input-port _? contents|]
[$p|(p: Port) contents|] =:
getHandle [$e|p handle|] >>= liftIO . TIO.hGetContents
>>= return . String
[$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|] >>= liftIO . hIsOpen
>>= bool
[$p|(p: Port) closed?|] =:
getHandle [$e|p handle|] >>= liftIO . hIsClosed
>>= bool
[$p|(p: Port) readable?|] =:
getHandle [$e|p handle|] >>= liftIO . hIsReadable
>>= bool
[$p|(p: Port) writable?|] =:
getHandle [$e|p handle|] >>= liftIO . hIsWritable
>>= bool
[$p|(p: Port) seekable?|] =:
getHandle [$e|p handle|] >>= liftIO . hIsSeekable
>>= bool
[$p|ready?|] =::: [$e|current-input-port _? ready?|]
[$p|(p: Port) ready?|] =:
getHandle [$e|p handle|] >>= liftIO . hReady
>>= bool
[$p|eof?|] =::: [$e|current-input-port _? eof?|]
[$p|(p: Port) eof?|] =:
getHandle [$e|p handle|] >>= liftIO . hIsEOF
>>= bool
[$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|]
fmap string $ liftIO (canonicalizePath fn)
[$p|File make-relative: (fn: String)|] =: do
fn <- getString [$e|fn|]
fmap string $ liftIO (makeRelativeToCurrentDirectory fn)
[$p|File exists?: (fn: String)|] =: do
fn <- getString [$e|fn|]
liftIO (doesFileExist fn) >>= bool
[$p|File find-executable: (name: String)|] =: do
name <- getString [$e|name|]
find <- liftIO (findExecutable name)
case find of
Nothing -> return (particle "none")
Just fn -> return (keyParticle ["ok"] [Nothing, Just (string fn)])
[$p|File readable?: (fn: String)|] =:
getString [$e|fn|]
>>= fmap readable . liftIO . getPermissions
>>= bool
[$p|File writable?: (fn: String)|] =:
getString [$e|fn|]
>>= fmap writable . liftIO . getPermissions
>>= bool
[$p|File executable?: (fn: String)|] =:
getString [$e|fn|]
>>= fmap executable . liftIO . getPermissions
>>= bool
[$p|File searchable?: (fn: String)|] =:
getString [$e|fn|]
>>= fmap searchable . liftIO . getPermissions
>>= bool
[$p|File set-readable: (fn: String) to: (b: Bool)|] =: do
t <- bool True
b <- here "b"
fn <- getString [$e|fn|]
ps <- liftIO (getPermissions fn)
liftIO (setPermissions fn (ps { readable = b == t }))
return (particle "ok")
[$p|File set-writable: (fn: String) to: (b: Bool)|] =: do
t <- bool True
b <- here "b"
fn <- getString [$e|fn|]
ps <- liftIO (getPermissions fn)
liftIO (setPermissions fn (ps { writable = b == t }))
return (particle "ok")
[$p|File set-executable: (fn: String) to: (b: Bool)|] =: do
t <- bool True
b <- here "b"
fn <- getString [$e|fn|]
ps <- liftIO (getPermissions fn)
liftIO (setPermissions fn (ps { executable = b == t }))
return (particle "ok")
[$p|File set-searchable: (fn: String) to: (b: Bool)|] =: do
t <- bool True
b <- here "b"
fn <- getString [$e|fn|]
ps <- liftIO (getPermissions fn)
liftIO (setPermissions fn (ps { searchable = b == t }))
return (particle "ok")
[$p|Directory create: (path: String)|] =: do
path <- getString [$e|path|]
liftIO (createDirectory path)
return (particle "ok")
[$p|Directory create-if-missing: (path: String)|] =: do
path <- getString [$e|path|]
liftIO (createDirectoryIfMissing False path)
return (particle "ok")
[$p|Directory create-tree-if-missing: (path: String)|] =: do
path <- getString [$e|path|]
liftIO (createDirectoryIfMissing True path)
return (particle "ok")
[$p|Directory remove: (path: String)|] =: do
path <- getString [$e|path|]
liftIO (removeDirectory path)
return (particle "ok")
[$p|Directory remove-recursive: (path: String)|] =: do
path <- getString [$e|path|]
liftIO (removeDirectoryRecursive path)
return (particle "ok")
[$p|Directory move: (from: String) to: (to: String)|] =:::
[$e|Directory rename: from to: to|]
[$p|Directory rename: (from: String) to: (to: String)|] =: do
from <- getString [$e|from|]
to <- getString [$e|to|]
liftIO (renameDirectory from to)
return (particle "ok")
[$p|Directory copy: (from: String) to: (to: String)|] =::: [$e|{
Directory create-tree-if-missing: to
Directory (contents: from) map: { c |
f = from / c
t = to / c
if: Directory (exists?: f)
then: { Directory copy: f to: t }
else: { File copy: f to: t }
}
@ok
} call|]
[$p|Directory contents: (path: String)|] =:
getString [$e|path|]
>>= liftIO . getDirectoryContents
>>= return . filter (not . (`elem` [".", ".."]))
>>= list . map string
[$p|Directory current|] =:
fmap string $ liftIO getCurrentDirectory
[$p|Directory current: (path: String)|] =: do
path <- getString [$e|path|]
liftIO (setCurrentDirectory path)
return (particle "ok")
[$p|Directory home|] =:
fmap string $ liftIO getHomeDirectory
[$p|Directory user-data-for: (app: String)|] =: do
app <- getString [$e|app|]
fmap string $ liftIO (getAppUserDataDirectory app)
[$p|Directory user-documents|] =:
fmap string $ liftIO getUserDocumentsDirectory
[$p|Directory temporary|] =:
fmap string $ liftIO getTemporaryDirectory
[$p|Directory exists?: (path: String)|] =: do
path <- getString [$e|path|]
liftIO (doesDirectoryExist path) >>= bool
[$p|(a: String) </> (b: String)|] =: do
a <- getString [$e|a|]
b <- getString [$e|b|]
return (string (a </> b))
[$p|(a: String) <.> (b: String)|] =: do
a <- getString [$e|a|]
b <- getString [$e|b|]
return (string (a <.> b))
prelude
where
portObj hdl = newScope $ do
port <- eval [$e|Port clone|]
[$p|p|] =:: port
[$p|p handle|] =:: Haskell (toDyn hdl)
here "p"
getHandle ex = do
Haskell hdl <- eval ex
return (fromDyn hdl (error "handle invalid"))
hGetSegment :: Handle -> IO String
hGetSegment h = dropSpaces >> hGetSegment'
where
dropSpaces = do
c <- hLookAhead h
if isSpace c
then hGetChar h >> dropSpaces
else return ()
hGetSegment' = do
end <- hIsEOF h
if end
then return ""
else do
c <- hGetChar h
case c of
'"' -> hGetUntil h '"' >>= return . (c:)
'\'' -> hGetUntil h '\'' >>= return . (c:)
'(' -> hGetUntil h ')' >>= return . (c:)
'{' -> hGetUntil h '}' >>= return . (c:)
'[' -> hGetUntil h ']' >>= return . (c:)
s | isSpace s -> return [c]
_ -> do
cs <- hGetSegment'
return (c:cs)
hGetUntil :: Handle -> Char -> IO String
hGetUntil h x = do
c <- hGetChar h
if c == x
then return [c]
else do
cs <- hGetUntil h x
return (c:cs)
prelude :: VM ()
prelude = mapM_ eval [$es|
with-output-to: (fn: String) do: b :=
Port (new: fn) ensuring: @close do: { file |
with-output-to: file do: b
}
with-output-to: (p: Port) do: b :=
with: current-output-port as: p do: b
with-input-from: (fn: String) do: (b: Block) :=
Port (new: fn) ensuring: @close do: { file |
with-input-from: file do: b
}
with-input-from: (p: Port) do: (b: Block) :=
with: current-input-port as: p do: b
with-all-output-to: (fn: String) do: b :=
Port (new: fn) ensuring: @close do: { file |
with-all-output-to: file do: b
}
with-all-output-to: (p: Port) do: b :=
with-default: current-output-port as: p do: b
with-all-input-from: (fn: String) do: (b: Block) :=
Port (new: fn) ensuring: @close do: { file |
with-all-input-from: file do: b
}
with-all-input-from: (p: Port) do: (b: Block) :=
with-default: current-input-port as: p do: b
|]