diff --git a/ghc/misc/examples/hsh/Hsh.hs b/ghc/misc/examples/hsh/Hsh.hs
index 141d974cecf0cd9d739edf92d129f3fc6266ba8b..2102f7d08ca68722717d4ebd6177cd8323f77fd1 100644
--- a/ghc/misc/examples/hsh/Hsh.hs
+++ b/ghc/misc/examples/hsh/Hsh.hs
@@ -1,12 +1,16 @@
-module Main (main)
-where
+module Main (main) where
-import LibPosix
-import LibSystem
+import IO
+import Posix
+import Directory (setCurrentDirectory)
+import System ( getEnv, exitWith, ExitCode(..) )
+import Char (isSpace)
+main :: IO ()
main =
- initialize >>
+ do
+ initialize
commandLoop
{-
@@ -17,24 +21,25 @@ main =
initialize :: IO ()
initialize =
- dupChannelTo stdInput myStdin >>
- dupChannelTo stdOutput myStdout >>
- dupChannelTo stdError myStderr >>
- closeChannel stdInput >>
- closeChannel stdOutput >>
--- closeChannel stdError >>
- installHandler sigINT (Catch intr) Nothing >>
+ dupTo stdInput myStdin >>
+ dupTo stdOutput myStdout >>
+ dupTo stdError myStderr >>
+ fdClose stdInput >>
+ fdClose stdOutput >>
+-- fdClose stdError >>
+ installHandler sigINT (Catch intr) Nothing >>
return ()
-myStdin = 16 :: Channel
-myStdout = 17 :: Channel
-myStderr = 18 :: Channel
+-- some random fd numbers...
+myStdin = intToFd 16
+myStdout = intToFd 17
+myStderr = intToFd 18
-- For user interrupts
intr :: IO ()
intr =
- writeChannel myStdout "\n" >>
+ fdWrite myStdout "\n" >>
commandLoop
{-
@@ -44,46 +49,47 @@ intr =
commandLoop :: IO ()
commandLoop =
- writeChannel myStdout "$ " >>
- try (readCommand myStdin) >>=
+ fdWrite myStdout "$ " >>
+ try (readCommand myStdin) >>=
either
- (\ err -> case err of
- EOF -> return ()
- _ -> dieHorribly)
+ (\ err ->
+ if isEOFError err then
+ return ()
+ else
+ dieHorribly)
(\ cmd ->
- try (processCommand cmd) >>=
- either
- (\ err -> commandLoop)
- (\ succ -> commandLoop))
+ try (processCommand cmd) >>= either (\ err -> commandLoop) (\ succ -> commandLoop))
where
dieHorribly :: IO ()
dieHorribly =
- errMsg "read failed" >>
- exitWith (ExitFailure 1)
+ do
+ errMsg "read failed"
+ exitWith (ExitFailure 1)
{-
Read a command a character at a time (to allow for fancy processing later).
On newline, you're done, unless the newline was escaped by a backslash.
-}
-readCommand :: Channel -> IO String
-readCommand chan =
+readCommand :: Fd -> IO String
+readCommand fd =
accumString "" >>= \ cmd ->
return cmd
where
accumString :: String -> IO String
accumString s =
- myGetChar chan >>= \ c ->
+ myGetChar fd >>= \ c ->
case c of
'\\' ->
- myGetChar chan >>= \ c' ->
+ myGetChar fd >>= \ c' ->
accumString (c':c:s)
'\n' -> return (reverse s)
ch -> accumString (ch:s)
-myGetChar :: Channel -> IO Char
+myGetChar :: Fd -> IO Char
myGetChar chan =
- readChannel chan 1 >>= \ (s, len) ->
+ do
+ (s,len) <- fdRead chan 1
case len of
0 -> myGetChar chan
1 -> return (head s)
@@ -97,53 +103,50 @@ myGetChar chan =
processCommand :: String -> IO ()
processCommand "" = return ()
processCommand s =
- parseCommand s >>= \ words ->
- parseRedirection words >>= \ (inFile, outFile, words) ->
- performRedirections inFile outFile >>
- let
- cmd = head words
- args = tail words
- in
- case builtin cmd of
- Just f ->
- f args >>
- closeChannel stdInput >>
- closeChannel stdOutput
- Nothing ->
- exec cmd args
+ do
+ words <- parseCommand s
+ (inFile, outFile, words) <- parseRedirection words
+ performRedirections inFile outFile
+ let
+ cmd = head words
+ args = tail words
+ case builtin cmd of
+ Just f ->
+ do
+ f args
+ fdClose stdInput
+ fdClose stdOutput
+ Nothing -> exec cmd args
{-
Redirections are a bit of a pain, really. If none are specified, we
- dupChannel our own file descriptors. Otherwise, we try to open the files
+ dup our own file descriptors. Otherwise, we try to open the files
as requested.
-}
performRedirections :: Maybe String -> Maybe String -> IO ()
performRedirections inFile outFile =
(case inFile of
- Nothing ->
- dupChannelTo myStdin stdInput
- Just x ->
- try (openChannel x ReadOnly Nothing False False False False False)
+ Nothing -> dupTo myStdin stdInput
+ Just x ->
+ try (openFd x ReadOnly Nothing defaultFileFlags)
>>=
either
(\ err ->
- errMsg ("Can't redirect input from " ++ x)
- >>
- failWith (UserError "redirect"))
+ errMsg ("Can't redirect input from " ++ x) >>
+ fail (userError "redirect"))
(\ succ -> return ())) >>
(case outFile of
Nothing ->
- dupChannelTo myStdout stdOutput
+ dupTo myStdout stdOutput
Just x ->
- try (createFile x stdFileMode)
- >>=
+ try (createFile x stdFileMode) >>=
either
(\ err ->
- errMsg ("Can't redirect output to " ++ x)
- >>
- closeChannel stdInput >>
- failWith (UserError "redirect"))
+ do
+ errMsg ("Can't redirect output to " ++ x)
+ fdClose stdInput
+ fail (userError "redirect"))
(\ succ -> return ()))
{-
@@ -181,7 +184,7 @@ parseCommand = getTokens []
accumQuote :: Char -> [Char] -> String -> IO (String, String)
accumQuote q cs "" =
errMsg ("Unmatched " ++ [q]) >>
- failWith (UserError "unmatched quote")
+ fail (userError "unmatched quote")
accumQuote q cs (c:s)
| c == q = accumToken cs s
| otherwise = accumQuote q (c:cs) s
@@ -202,7 +205,7 @@ parseRedirection = redirect Nothing Nothing []
redirect inFile outFile args [arg]
| arg == "<" || arg == ">" =
errMsg "Missing name for redirect" >>
- failWith (UserError "parse redirect")
+ fail (userError "parse redirect")
| otherwise =
return (inFile, outFile, reverse (arg:args))
redirect inFile outFile args ("<":name:more)
@@ -210,13 +213,13 @@ parseRedirection = redirect Nothing Nothing []
redirect (Just name) outFile args more
| otherwise =
errMsg "Ambiguous input redirect" >>
- failWith (UserError "parse redirect")
+ fail (userError "parse redirect")
redirect inFile outFile args (">":name:more)
| outFile == Nothing =
redirect inFile (Just name) args more
| otherwise =
errMsg "Ambiguous output redirect" >>
- failWith (UserError "parse redirect")
+ fail (userError "parse redirect")
redirect inFile outFile args (arg:more) =
redirect inFile outFile (arg:args) more
@@ -231,20 +234,22 @@ exec cmd args =
forkProcess >>= \ maybe_pid ->
case maybe_pid of
Nothing ->
- dupChannelTo myStderr stdError >>
- closeChannel myStdin >>
- closeChannel myStdout >>
- closeChannel myStderr >>
- executeFile cmd True args Nothing `handle`
- \ err ->
- writeChannel stdError ("command not found: " ++ cmd ++ ".\n")
- >>
- exitImmediately (ExitFailure 1)
+ do
+ dupTo myStderr stdError
+ fdClose myStdin
+ fdClose myStdout
+ fdClose myStderr
+ executeFile cmd True args Nothing
+ `catch`
+ (\ err ->
+ fdWrite stdError ("command not found: " ++ cmd ++ ".\n") >>
+ exitImmediately (ExitFailure 1))
Just pid ->
- closeChannel stdInput >>
- closeChannel stdOutput >>
--- closeChannel stdError >>
- getProcessStatus True False pid >>
+ do
+ fdClose stdInput
+ fdClose stdOutput
+-- fdClose stdError
+ getProcessStatus True False pid
return ()
{-
@@ -257,21 +262,20 @@ exec cmd args =
-}
builtin :: String -> Maybe ([String] -> IO ())
-builtin "cd" = Just chdir
+builtin "cd" = Just chdir
builtin "exit" = Just exit
-builtin _ = Nothing
+builtin _ = Nothing
chdir :: [String] -> IO ()
chdir [] =
- getEnvVar "HOME" >>= \ home ->
- changeWorkingDirectory home `handle`
- \ err -> errMsg "cd: can't go home"
+ do
+ home <- getEnv "HOME"
+ setCurrentDirectory home `catch` \ err -> errMsg "cd: can't go home"
chdir [dir] =
- changeWorkingDirectory dir `handle`
- \ err -> errMsg ("cd: can't chdir to " ++ dir)
-chdir _ =
- errMsg "cd: too many arguments"
+ do
+ setCurrentDirectory dir `catch` \ err -> errMsg ("cd: can't chdir to " ++ dir)
+chdir _ = errMsg "cd: too many arguments"
exit :: [String] -> IO ()
exit _ = exitWith ExitSuccess
@@ -280,5 +284,5 @@ exit _ = exitWith ExitSuccess
errMsg :: String -> IO ()
errMsg msg =
- writeChannel myStderr ("hsh: " ++ msg ++ ".\n") >>
+ fdWrite myStderr ("hsh: " ++ msg ++ ".\n") >>
return ()