{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module System.IO.Dialogue
(
Dialogue
,
Request (..)
,
Bin
, nullBin
, appendBin
, isNullBin
,
Name
,
stdin
, stdout
, stderr
, stdecho
,
Response (..)
, IOError (..)
,
runDialogue
) where
import Control.Concurrent (newChan, readChan, writeChan)
import Control.Monad
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Function ((&))
import GHC.IO
import Prelude hiding (IOError)
import System.Directory
import System.Environment (getArgs, getProgName, lookupEnv, setEnv)
import System.IO hiding (stderr, stdin, stdout)
import qualified System.IO as Handle
type Dialogue = [Response] -> [Request]
data Request
=
ReadFile Name
|
WriteFile Name String
|
AppendFile Name String
|
ReadBinFile Name
|
WriteBinFile Name Bin
|
AppendBinFile Name Bin
|
DeleteFile Name
|
StatusFile Name
|
ReadChan Name
|
AppendChan Name String
|
ReadBinChan Name
|
AppendBinChan Name Bin
|
StatusChan Name
|
Echo Bool
|
GetArgs
|
GetProgName
|
GetEnv Name
|
SetEnv Name String
deriving (ReadPrec [Request]
ReadPrec Request
Int -> ReadS Request
ReadS [Request]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Request]
$creadListPrec :: ReadPrec [Request]
readPrec :: ReadPrec Request
$creadPrec :: ReadPrec Request
readList :: ReadS [Request]
$creadList :: ReadS [Request]
readsPrec :: Int -> ReadS Request
$creadsPrec :: Int -> ReadS Request
Read, Int -> Request -> ShowS
[Request] -> ShowS
Request -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [Request] -> ShowS
$cshowList :: [Request] -> ShowS
show :: Request -> Name
$cshow :: Request -> Name
showsPrec :: Int -> Request -> ShowS
$cshowsPrec :: Int -> Request -> ShowS
Show, Request -> Request -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c== :: Request -> Request -> Bool
Eq, Eq Request
Request -> Request -> Bool
Request -> Request -> Ordering
Request -> Request -> Request
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Request -> Request -> Request
$cmin :: Request -> Request -> Request
max :: Request -> Request -> Request
$cmax :: Request -> Request -> Request
>= :: Request -> Request -> Bool
$c>= :: Request -> Request -> Bool
> :: Request -> Request -> Bool
$c> :: Request -> Request -> Bool
<= :: Request -> Request -> Bool
$c<= :: Request -> Request -> Bool
< :: Request -> Request -> Bool
$c< :: Request -> Request -> Bool
compare :: Request -> Request -> Ordering
$ccompare :: Request -> Request -> Ordering
Ord)
type Bin = ByteString
nullBin :: Bin
nullBin :: Bin
nullBin = Bin
LBS.empty
appendBin :: Bin -> Bin -> Bin
appendBin :: Bin -> Bin -> Bin
appendBin = Bin -> Bin -> Bin
LBS.append
isNullBin :: Bin -> Bool
isNullBin :: Bin -> Bool
isNullBin = Bin -> Bool
LBS.null
type Name = String
stdin :: Name
stdin :: Name
stdin = Name
"stdin"
stdout :: Name
stdout :: Name
stdout = Name
"stdout"
stderr :: Name
stderr :: Name
stderr = Name
"stderr"
stdecho :: Name
stdecho :: Name
stdecho = Name
"stdecho"
data ChanMode = R | A deriving ChanMode -> ChanMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChanMode -> ChanMode -> Bool
$c/= :: ChanMode -> ChanMode -> Bool
== :: ChanMode -> ChanMode -> Bool
$c== :: ChanMode -> ChanMode -> Bool
Eq
mapChan :: Name -> Maybe (Handle, ChanMode)
mapChan :: Name -> Maybe (Handle, ChanMode)
mapChan = \case
Name
"stdin" -> forall a. a -> Maybe a
Just (Handle
Handle.stdin, ChanMode
R)
Name
"stdout" -> forall a. a -> Maybe a
Just (Handle
Handle.stdout, ChanMode
A)
Name
"stderr" -> forall a. a -> Maybe a
Just (Handle
Handle.stderr, ChanMode
A)
Name
"stdecho" -> forall a. a -> Maybe a
Just (Handle
Handle.stdout, ChanMode
A)
Name
_ -> forall a. Maybe a
Nothing
data Response
= Success
| Str String
| StrList [String]
| Bn Bin
| Failure IOError
deriving (ReadPrec [Response]
ReadPrec Response
Int -> ReadS Response
ReadS [Response]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Response]
$creadListPrec :: ReadPrec [Response]
readPrec :: ReadPrec Response
$creadPrec :: ReadPrec Response
readList :: ReadS [Response]
$creadList :: ReadS [Response]
readsPrec :: Int -> ReadS Response
$creadsPrec :: Int -> ReadS Response
Read, Int -> Response -> ShowS
[Response] -> ShowS
Response -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> Name
$cshow :: Response -> Name
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show, Response -> Response -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c== :: Response -> Response -> Bool
Eq, Eq Response
Response -> Response -> Bool
Response -> Response -> Ordering
Response -> Response -> Response
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Response -> Response -> Response
$cmin :: Response -> Response -> Response
max :: Response -> Response -> Response
$cmax :: Response -> Response -> Response
>= :: Response -> Response -> Bool
$c>= :: Response -> Response -> Bool
> :: Response -> Response -> Bool
$c> :: Response -> Response -> Bool
<= :: Response -> Response -> Bool
$c<= :: Response -> Response -> Bool
< :: Response -> Response -> Bool
$c< :: Response -> Response -> Bool
compare :: Response -> Response -> Ordering
$ccompare :: Response -> Response -> Ordering
Ord)
data IOError
= WriteError String
| ReadError String
| SearchError String
|
FormatError String
| OtherError String
deriving (ReadPrec [IOError]
ReadPrec IOError
Int -> ReadS IOError
ReadS [IOError]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IOError]
$creadListPrec :: ReadPrec [IOError]
readPrec :: ReadPrec IOError
$creadPrec :: ReadPrec IOError
readList :: ReadS [IOError]
$creadList :: ReadS [IOError]
readsPrec :: Int -> ReadS IOError
$creadsPrec :: Int -> ReadS IOError
Read, Int -> IOError -> ShowS
[IOError] -> ShowS
IOError -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [IOError] -> ShowS
$cshowList :: [IOError] -> ShowS
show :: IOError -> Name
$cshow :: IOError -> Name
showsPrec :: Int -> IOError -> ShowS
$cshowsPrec :: Int -> IOError -> ShowS
Show, IOError -> IOError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IOError -> IOError -> Bool
$c/= :: IOError -> IOError -> Bool
== :: IOError -> IOError -> Bool
$c== :: IOError -> IOError -> Bool
Eq, Eq IOError
IOError -> IOError -> Bool
IOError -> IOError -> Ordering
IOError -> IOError -> IOError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IOError -> IOError -> IOError
$cmin :: IOError -> IOError -> IOError
max :: IOError -> IOError -> IOError
$cmax :: IOError -> IOError -> IOError
>= :: IOError -> IOError -> Bool
$c>= :: IOError -> IOError -> Bool
> :: IOError -> IOError -> Bool
$c> :: IOError -> IOError -> Bool
<= :: IOError -> IOError -> Bool
$c<= :: IOError -> IOError -> Bool
< :: IOError -> IOError -> Bool
$c< :: IOError -> IOError -> Bool
compare :: IOError -> IOError -> Ordering
$ccompare :: IOError -> IOError -> Ordering
Ord)
failWith :: Applicative f => IOError -> f Response
failWith :: forall (f :: * -> *). Applicative f => IOError -> f Response
failWith = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Response
Failure
fileNotFound, chanCantRead, chanCantAppend, chanNotExist, varNotExist :: IOError
fileNotFound :: IOError
fileNotFound = Name -> IOError
SearchError Name
"File not found."
chanCantRead :: IOError
chanCantRead = Name -> IOError
ReadError Name
"Can't read from channel."
chanCantAppend :: IOError
chanCantAppend = Name -> IOError
WriteError Name
"Can't append to channel."
chanNotExist :: IOError
chanNotExist = Name -> IOError
SearchError Name
"Channel doesn't exist."
varNotExist :: IOError
varNotExist = Name -> IOError
SearchError Name
"Environment variable doesn't exist."
ensureFileExist :: FilePath -> IO Response -> IO Response
ensureFileExist :: Name -> IO Response -> IO Response
ensureFileExist Name
name IO Response
io =
Name -> IO Bool
doesFileExist Name
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
fileNotFound
Bool
True -> IO Response
io
withMode :: Applicative f => Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode :: forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
mode Handle -> f Response
f = case Name -> Maybe (Handle, ChanMode)
mapChan Name
name of
Maybe (Handle, ChanMode)
Nothing -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
chanNotExist
Just (Handle
h, ChanMode
m)
| ChanMode
m forall a. Eq a => a -> a -> Bool
== ChanMode
mode -> Handle -> f Response
f Handle
h
| ChanMode
mode forall a. Eq a => a -> a -> Bool
== ChanMode
R -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
chanCantRead
| Bool
otherwise -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
chanCantAppend
interpret :: Request -> IO Response
interpret :: Request -> IO Response
interpret Request
req = case Request -> (IO Response, Name -> IOError)
interpret' Request
req of
(IO Response
io, Name -> IOError
err) -> forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
catchAny IO Response
io (forall (f :: * -> *). Applicative f => IOError -> f Response
failWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IOError
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Name
show)
where
interpret' :: Request -> (IO Response, Name -> IOError)
interpret' (ReadFile Name
name) = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Name -> Response
Str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IO Name
readFile Name
name, Name -> IOError
ReadError)
interpret' (WriteFile Name
name Name
str) = (Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Name -> IO ()
writeFile Name
name Name
str, Name -> IOError
WriteError)
interpret' (AppendFile Name
name Name
str) = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Name -> IO ()
appendFile Name
name Name
str, Name -> IOError
WriteError)
interpret' (ReadBinFile Name
name) = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Bin -> Response
Bn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IO Bin
LBS.readFile Name
name, Name -> IOError
ReadError)
interpret' (WriteBinFile Name
name Bin
bin) = (Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Bin -> IO ()
LBS.writeFile Name
name Bin
bin, Name -> IOError
WriteError)
interpret' (AppendBinFile Name
name Bin
bin) = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Bin -> IO ()
LBS.appendFile Name
name Bin
bin, Name -> IOError
WriteError)
interpret' (DeleteFile Name
name) = (Name -> IO Response -> IO Response
ensureFileExist Name
name forall a b. (a -> b) -> a -> b
$ Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> IO ()
removeFile Name
name, Name -> IOError
WriteError)
interpret' (StatusFile Name
name) = (, Name -> IOError
OtherError) forall a b. (a -> b) -> a -> b
$ do
[Bool
p, Bool
f, Bool
d] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. IO a -> IO a
unsafeInterleaveIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ Name
name)) [Name -> IO Bool
doesPathExist, Name -> IO Bool
doesFileExist, Name -> IO Bool
doesDirectoryExist]
let ty :: Maybe Char
ty = case (Bool
p, Bool
f, Bool
d) of
(Bool
False, Bool
_, Bool
_) -> forall a. Maybe a
Nothing
(Bool
_, Bool
True, Bool
_) -> forall a. a -> Maybe a
Just Char
'f'
(Bool
_, Bool
_, Bool
True) -> forall a. a -> Maybe a
Just Char
'd'
(Bool, Bool, Bool)
_ -> forall a. a -> Maybe a
Just Char
'u'
case Maybe Char
ty of
Maybe Char
Nothing -> forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
fileNotFound
Just Char
c -> do
Permissions
s <- Name -> IO Permissions
getPermissions Name
name
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Response
Str
[ Char
c
, if Permissions -> Bool
readable Permissions
s then Char
'r' else Char
'-'
, if Permissions -> Bool
writable Permissions
s then Char
'w' else Char
'-'
, if Permissions -> Bool
executable Permissions
s then Char
'x' else Char
'-'
]
interpret' (ReadChan Name
name) = (forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
R (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Response
Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Name
hGetContents), Name -> IOError
ReadError)
interpret' (AppendChan Name
name Name
str) = (forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
A (\Handle
h -> Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Handle -> Name -> IO ()
hPutStr Handle
h Name
str forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h)), Name -> IOError
WriteError)
interpret' (ReadBinChan Name
name) = (forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
R (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bin -> Response
Bn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Bin
LBS.hGetContents), Name -> IOError
ReadError)
interpret' (AppendBinChan Name
name Bin
str) = (forall (f :: * -> *).
Applicative f =>
Name -> ChanMode -> (Handle -> f Response) -> f Response
withMode Name
name ChanMode
A (\Handle
h -> Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Handle -> Bin -> IO ()
LBS.hPutStr Handle
h Bin
str forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h)), Name -> IOError
WriteError)
interpret' (StatusChan Name
name) = (Name -> Maybe (Handle, ChanMode)
mapChan Name
name forall a b. a -> (a -> b) -> b
& forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
chanNotExist) (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Response
Str Name
"0 0"))), Name -> IOError
OtherError)
interpret' (Echo Bool
b) = (Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Handle -> Bool -> IO ()
hSetEcho Handle
Handle.stdin Bool
b, Name -> IOError
OtherError)
interpret' Request
GetArgs = ([Name] -> Response
StrList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Name]
getArgs, Name -> IOError
OtherError)
interpret' Request
GetProgName = (Name -> Response
Str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Name
getProgName, Name -> IOError
OtherError)
interpret' (GetEnv Name
name) = (Name -> IO (Maybe Name)
lookupEnv Name
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *). Applicative f => IOError -> f Response
failWith IOError
varNotExist) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Response
Str), Name -> IOError
OtherError)
interpret' (SetEnv Name
name Name
str) = (Response
Success forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Name -> IO ()
setEnv Name
name Name
str, Name -> IOError
OtherError)
runDialogue :: Dialogue -> IO ()
runDialogue :: Dialogue -> IO ()
runDialogue Dialogue
prog = do
Chan Response
resChan <- forall a. IO (Chan a)
newChan
let reading :: IO [Response]
reading = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Chan a -> IO a
readChan Chan Response
resChan forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO [Response]
reading
[Response]
input <- IO [Response]
reading
let output :: [Request]
output = Dialogue
prog [Response]
input
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Request]
output forall a b. (a -> b) -> a -> b
$ Request -> IO Response
interpret forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a. Chan a -> a -> IO ()
writeChan Chan Response
resChan