[project @ 1997-06-05 23:28:37 by sof]

Updated for 2.04

ghc/misc/examples/hsh/Hsh.hs

-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 ()