diff options
Diffstat (limited to 'ghc/misc/examples/hsh/Hsh.hs')
| -rw-r--r-- | ghc/misc/examples/hsh/Hsh.hs | 288 |
1 files changed, 0 insertions, 288 deletions
diff --git a/ghc/misc/examples/hsh/Hsh.hs b/ghc/misc/examples/hsh/Hsh.hs deleted file mode 100644 index 2102f7d08c..0000000000 --- a/ghc/misc/examples/hsh/Hsh.hs +++ /dev/null @@ -1,288 +0,0 @@ -module Main (main) where - -import IO -import Posix - -import Directory (setCurrentDirectory) -import System ( getEnv, exitWith, ExitCode(..) ) -import Char (isSpace) - -main :: IO () -main = - do - initialize - commandLoop - -{- - Standard shell practice: move std descriptors out of the way so - it's more convenient to set them up for children. Also set up an - interrupt handler which will put us back in the main loop. --} - -initialize :: IO () -initialize = - dupTo stdInput myStdin >> - dupTo stdOutput myStdout >> - dupTo stdError myStderr >> - fdClose stdInput >> - fdClose stdOutput >> --- fdClose stdError >> - installHandler sigINT (Catch intr) Nothing >> - return () - --- some random fd numbers... -myStdin = intToFd 16 -myStdout = intToFd 17 -myStderr = intToFd 18 - --- For user interrupts - -intr :: IO () -intr = - fdWrite myStdout "\n" >> - commandLoop - -{- - Simple command loop: print a prompt, read a command, process the command. - Repeat as necessary. --} - -commandLoop :: IO () -commandLoop = - fdWrite myStdout "$ " >> - try (readCommand myStdin) >>= - either - (\ err -> - if isEOFError err then - return () - else - dieHorribly) - (\ cmd -> - try (processCommand cmd) >>= either (\ err -> commandLoop) (\ succ -> commandLoop)) - where - dieHorribly :: IO () - dieHorribly = - 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 :: Fd -> IO String -readCommand fd = - accumString "" >>= \ cmd -> - return cmd - where - accumString :: String -> IO String - accumString s = - myGetChar fd >>= \ c -> - case c of - '\\' -> - myGetChar fd >>= \ c' -> - accumString (c':c:s) - '\n' -> return (reverse s) - ch -> accumString (ch:s) - -myGetChar :: Fd -> IO Char -myGetChar chan = - do - (s,len) <- fdRead chan 1 - case len of - 0 -> myGetChar chan - 1 -> return (head s) - -{- - To process a command, first parse it into words, then do the necessary - redirections, and finally perform the desired command. Built-ins are - checked first, and if none match, we execute an external command. --} - -processCommand :: String -> IO () -processCommand "" = return () -processCommand s = - 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 - 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 -> dupTo myStdin stdInput - Just x -> - try (openFd x ReadOnly Nothing defaultFileFlags) - >>= - either - (\ err -> - errMsg ("Can't redirect input from " ++ x) >> - fail (userError "redirect")) - (\ succ -> return ())) >> - (case outFile of - Nothing -> - dupTo myStdout stdOutput - Just x -> - try (createFile x stdFileMode) >>= - either - (\ err -> - do - errMsg ("Can't redirect output to " ++ x) - fdClose stdInput - fail (userError "redirect")) - (\ succ -> return ())) - -{- - We parse a command line into words according to the following rules: - 1) Anything inside pairs of "" or '' is parsed literally. - 2) Anything (outside of quotes) escaped by \ is taken literally. - 3) '<' and '>' are words all by themselves, unless escaped or quoted. - 4) Whitespace separates words --} - -parseCommand :: String -> IO [String] -parseCommand = getTokens [] - where - getTokens :: [String] -> String -> IO [String] - getTokens ts "" = return (reverse ts) - getTokens ts (c:cs) | isSpace c = getTokens ts cs - getTokens ts s = - getToken s >>= \ (t, s') -> - getTokens (t:ts) s' - - getToken :: String -> IO (String, String) - getToken (c:cs) - | c == '<' || c == '>' = return ([c], cs) - | c == '"' || c == '\'' = accumQuote c "" cs - | otherwise = accumToken [c] cs - - accumToken :: [Char] -> String -> IO (String, String) - accumToken cs "" = return (reverse cs, "") - accumToken cs ('\\':c:s) = accumToken (c:cs) s - accumToken cs x@(c:s) - | isSpace c || c == '<' || c == '>' = return (reverse cs, x) - | c == '"' || c == '\'' = accumQuote c cs s - | otherwise = accumToken (c:cs) s - - accumQuote :: Char -> [Char] -> String -> IO (String, String) - accumQuote q cs "" = - errMsg ("Unmatched " ++ [q]) >> - fail (userError "unmatched quote") - accumQuote q cs (c:s) - | c == q = accumToken cs s - | otherwise = accumQuote q (c:cs) s - -{- - Here we look for "<" and ">". When we find one, we remove it and the - following word from the word list. The arguments following the redirection - symbols and the remaining words are returned to our caller. However, it's - an error to end a word list with a redirection or for the same redirection - to appear twice. --} - -parseRedirection :: [String] -> IO (Maybe String, Maybe String, [String]) -parseRedirection = redirect Nothing Nothing [] - where - redirect inFile outFile args [] = - return (inFile, outFile, reverse args) - redirect inFile outFile args [arg] - | arg == "<" || arg == ">" = - errMsg "Missing name for redirect" >> - fail (userError "parse redirect") - | otherwise = - return (inFile, outFile, reverse (arg:args)) - redirect inFile outFile args ("<":name:more) - | inFile == Nothing = - redirect (Just name) outFile args more - | otherwise = - errMsg "Ambiguous input redirect" >> - fail (userError "parse redirect") - redirect inFile outFile args (">":name:more) - | outFile == Nothing = - redirect inFile (Just name) args more - | otherwise = - errMsg "Ambiguous output redirect" >> - fail (userError "parse redirect") - redirect inFile outFile args (arg:more) = - redirect inFile outFile (arg:args) more - -{- - Executing an external command is pretty simple, but what if it fails? - Fortunately, we don't have any way to redirect stdError just yet, - so we let it complain and then exit. --} - -exec :: String -> [String] -> IO () -exec cmd args = - forkProcess >>= \ maybe_pid -> - case maybe_pid of - Nothing -> - 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 -> - do - fdClose stdInput - fdClose stdOutput --- fdClose stdError - getProcessStatus True False pid - return () - -{- - Builtins: - cd [arg] -> change directory (default to HOME) - exit ... -> exit successfully - - Builtins must provide their own error messages, since the main command - loop ignores any errors. --} - -builtin :: String -> Maybe ([String] -> IO ()) -builtin "cd" = Just chdir -builtin "exit" = Just exit -builtin _ = Nothing - -chdir :: [String] -> IO () -chdir [] = - do - home <- getEnv "HOME" - setCurrentDirectory home `catch` \ err -> errMsg "cd: can't go home" - -chdir [dir] = - do - setCurrentDirectory dir `catch` \ err -> errMsg ("cd: can't chdir to " ++ dir) -chdir _ = errMsg "cd: too many arguments" - -exit :: [String] -> IO () -exit _ = exitWith ExitSuccess - --- Print an error message to my std error. - -errMsg :: String -> IO () -errMsg msg = - fdWrite myStderr ("hsh: " ++ msg ++ ".\n") >> - return () |