diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2005-2006, Robert Dockins. +PPrint library: Copyright 2000, Dan Leijen. +Shell History module: Copyright (C) 2000,2006 Michael Weber + +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistribution of source code must retain the above copyright notice, +this list of conditions and the following disclamer. + +- Redistribution in binary form must reproduce the above copyright notice, +this list of conditions and the following disclamer in the documentation +and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,81 @@ + + Shellac +-========================- + + +== What is it? + +Shellac is a framework for building read-eval-print style shells. +Shells are created by declaratively defining a set of shell commands +and an evaluation function. Shellac supports multiple shell backends, +including a 'basic' backend which uses only Haskell IO primitives and +a full featured 'readline' backend based on the the Haskell readline +bindings found in the standard libraries. + +This library attempts to allow users to write shells at a high level +and still enjoy the advanced features that may be available from a +powerful line editing package like readline. + + +== Why do I care? + +Shellac takes care of much the muckety-muck of writing robust, +feature-full shells so you don't have to. + + +== How is it licensed? + +Shellac is available under a BSD3 license. See the LICENSE file for +details. + +Be aware, however, that the GNU readline library itself is +licensed under the GPL. If you wish to use the readline bindings, +your project will need to be GPL compatible. + +Go here (http://directory.fsf.org/GNU/readline.html) for more information +about the readline library. + + +== What about portability? + +Currently, Shellac is GHC only. The 0.5 release made significant +efforts toward portability by eliminating dependencies on the GHC +specific features GADTs and STM. However, it still requires +existential types, multi-parameter type classes, functional +dependencies, preemptive concurrency support and the FFI. Currently no +Haskell implementation other than GHC supports all these features. + +== How do I build it? + +Shellac uses a Cabal build system. The following commands +assume you have a Haskell interpreter in your system +path named 'runhaskell'. All commands are run from +this directory. + +To install for the whole system: + +runhaskell Setup.hs configure +runhaskell Setup.hs build +runhaskell Setup.hs install + +To install for a single user: + +runhaskell Setup.hs configure --prefix=/home/ +runhaskell Setup.hs build +runhaskell Setup.hs install --user + +To build the API docs: + +runhaskell Setup.hs haddock + + +== Why 'Shellac'? + +I had to call it something. And it starts with 'shell'. + + +== Who is responsible for this mess? + +You can send bug reports, rants and comments to: + + Robert Dockins diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/Shellac.cabal b/Shellac.cabal new file mode 100644 --- /dev/null +++ b/Shellac.cabal @@ -0,0 +1,43 @@ +Name: Shellac +Version: 0.9 +License: BSD3 +License-File: LICENSE +Author: Robert Dockins +Maintainer: robdockins AT fastmail DOT fm +Category: User Interfaces +Stability: Beta +Synopsis: A framework for creating shell envinronments +Description: + Shellac is a framework for building read-eval-print style shells. + Shells are created by declaratively defining a set of shell commands + and an evaluation function. Shellac supports multiple shell backends, + including a 'basic' backend which uses only Haskell IO primitives and + a full featured 'readline' backend based on the the Haskell readline + bindings found in the standard libraries. + This library attempts to allow users to write shells at a high level + and still enjoy the advanced features that may be available from a + powerful line editing package like readline. +Hs-Source-Dirs: + src +Build-Depends: + base >= 1.0, + haskell98 >= 1.0, + mtl >= 1.0 +Extensions: + MultiParamTypeClasses + FunctionalDependencies + ExistentialQuantification + CPP + UndecidableInstances +Exposed-modules: + System.Console.Shell + System.Console.Shell.Backend + System.Console.Shell.Backend.Basic + System.Console.Shell.ShellMonad +Other-modules: + System.Console.Shell.Regex + System.Console.Shell.PPrint + System.Console.Shell.Types + System.Console.Shell.RunShell + System.Console.Shell.Commands + System.Console.Shell.ConsoleHandler diff --git a/src/System/Console/Shell.hs b/src/System/Console/Shell.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell.hs @@ -0,0 +1,107 @@ +{- + - + - Copyright 2005-2007, Robert Dockins. + - + -} + +{- | This module implements a framework for creating read-eval-print style + command shells. Shells are created by declaratively defining evaluation + functions and \"shell commands\". Input is read using a plugable backend. + The shell framework handles command history and word completion if the + backend supports it. + + The basic idea is for creating a shell is: + + (1) Create a list of shell commands and an evaluation function + + (2) Create a shell description (using 'mkShellDescription') + + (3) Set up the initial shell state + + (4) Run the shell (using 'runShell') +-} + + +module System.Console.Shell ( + +-- * Shell Descriptions + ShellDescription (..) +, initialShellDescription +, mkShellDescription +, defaultExceptionHandler + +-- * Executing Shells +, runShell + +-- * Creating Shell Commands +, exitCommand +, helpCommand +, toggle +, cmd +, CommandFunction +, File (..) +, Username (..) +, Completable (..) +, Completion (..) +, ShellCommand + +-- * Subshells +, Subshell +, simpleSubshell + +-- * Printing Help Messages +, showShellHelp +, showCmdHelp + +-- * Generating text output +, shellPutStr +, shellPutStrLn +, shellPutInfo +, shellPutInfoLn +, shellPutErr +, shellPutErrLn + +-- * Auxiliary Types +, CommandStyle (..) +, ShellSpecial (..) +, OutputCommand +, CommandResult +) where + +import System.Console.Shell.Types +import System.Console.Shell.ShellMonad +import System.Console.Shell.Commands +import System.Console.Shell.RunShell +import System.Console.Shell.Backend + +-- | A basic shell description with sane initial values +initialShellDescription :: ShellDescription st +initialShellDescription = + ShDesc + { shellCommands = [] + , commandStyle = CharPrefixCommands ':' + , evaluateFunc = \_ -> return () + , greetingText = Nothing + , wordBreakChars = defaultWordBreakChars + , beforePrompt = return () + , prompt = \_ -> return "> " + , secondaryPrompt = Nothing + , exceptionHandler = defaultExceptionHandler + , defaultCompletions = Just (\_ _ -> return []) + , historyFile = Nothing + , maxHistoryEntries = 100 + , historyEnabled = True + } + + +-- | Creates a simple shell description from a list of shell commmands and +-- an evalation function. +mkShellDescription :: [ShellCommand st] + -> (String -> Sh st ()) + -> ShellDescription st + +mkShellDescription cmds func = + initialShellDescription + { shellCommands = cmds + , evaluateFunc = func + } diff --git a/src/System/Console/Shell/Backend.hs b/src/System/Console/Shell/Backend.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell/Backend.hs @@ -0,0 +1,161 @@ +{- + - + - Copyright 2005-2007, Robert Dockins. + - + -} + +{- | This module defines the Shellac interface for shell backends. A shell backend + is required to provide sensible implementations for 'outputString', 'flushOutput', + 'getSingleChar', 'getInput', and 'getWordBreakChars'. All other operations may + be noops (however, they must not denote bottom!). +-} + +module System.Console.Shell.Backend +( CompletionFunction +, BackendOutput (..) +, ShellBackend (..) +, defaultWordBreakChars +, templateBackend +) where + + +-- | The type of completion functions. The argument is a triple +-- consisting of (before,word,after), where \'word\' is a string +-- of non-word-break characters which contains the cursor position. +-- \'before\' is all characters on the line before \'word\' and \'after\' +-- is all characters on the line after word. The return value should +-- be \'Nothing\' if no completions can be generated, or +-- \'Just (newWord,completions)\' if completions can be generated. \'newWord\' +-- is a new string to replace \'word\' on the command line and \'completions\' +-- is a list of all possible completions of \'word\'. To achieve the standard +-- \"complete-as-far-as-possible\" behavior, \'newWord\' should be the longest possible +-- prefix of all words in \'completions\'. + +type CompletionFunction = (String,String,String) + -> IO (Maybe (String, [String])) + +-- | A datatype representing ouput to be printed. The different categories of +-- output are distinguished to that shell backends can, for example, apply +-- different colors or send output to different places (stderr versus stdout). + +data BackendOutput + = RegularOutput String -- ^ The most regular way to produce output + | InfoOutput String -- ^ An informative output string, such as command help + | ErrorOutput String -- ^ An string generated by an error + + +-- | This record type contains all the functions that Shellac allows the pluggable +-- backend to provide. Most of these operations are optional andn relate to +-- advanced features like command completion and history. However, a shell backend +-- is required to provide sensible implementations for 'outputString', 'flushOutput', +-- 'getSingleChar', 'getInput', and 'getWordBreakChars'. + +data ShellBackend bst + = ShBackend + { initBackend :: IO bst + -- ^ Provides the backend a way to perform any necessary initilization + -- before the shell starts. This function is called once for each + -- shell instance. The generated value will be passed back in to each call of the + -- other methods in this record. + + , shutdownBackend :: bst -> IO () + -- ^ Called when the shell exits to allow the backend to perform any necessary + -- cleanup actions. + + , outputString :: bst -> BackendOutput -> IO () + -- ^ Causes the string to be sent to the underlying console device. + + , flushOutput :: bst -> IO () + -- ^ Perform any operations necessary to clear any output buffers. After this + -- operation, the user should be able to view any output sent to this backend. + + , getSingleChar :: bst -> String -> IO (Maybe Char) + -- ^ Retrive a single character from the user without waiting for carriage return. + + , getInput :: bst -> String -> IO (Maybe String) + -- ^ Print the prompt and retrive a line of input from the user. + + , addHistory :: bst -> String -> IO () + -- ^ Add a string to the history list. + + , setWordBreakChars :: bst -> String -> IO () + -- ^ Set the characters which define word boundaries. This is mostly used + -- for defining where completions occur. + + , getWordBreakChars :: bst -> IO String + -- ^ Get the current set of word break characters. + + , onCancel :: bst -> IO () + -- ^ A callback to run whenever evaluation or a command is cancled + -- by the keyboard signal + + , setAttemptedCompletionFunction :: bst -> CompletionFunction -> IO () + -- ^ A completion function that is tried first. + + , setDefaultCompletionFunction :: bst -> Maybe (String -> IO [String]) -> IO () + -- ^ An alternate function to generate completions. The function given takes the + -- word as an argument and generates all possible completions. This function is called + -- (if set) after the attemptedCompletionFunction if it returns \'Nothing\'. + + , completeFilename :: bst -> String -> IO [String] + -- ^ A backend-provided method to complete filenames. + + , completeUsername :: bst -> String -> IO [String] + -- ^ A backend-provided method to complete usernames. + + , clearHistoryState :: bst -> IO () + -- ^ An operation to clear the history buffer. + + , setMaxHistoryEntries :: bst -> Int -> IO () + -- ^ Sets the maximum number of entries managed by the history buffer. + + , getMaxHistoryEntries :: bst -> IO Int + -- ^ Gets the maximum number of entries managed by the history buffer. + + , readHistory :: bst -> FilePath -> IO () + -- ^ Read the history buffer from a file. The file should be formatted + -- as plain-text, with each line in the file representing a single command + -- entered, most recent commands at the bottom. (This format is what readline + -- produces) + + , writeHistory :: bst -> FilePath -> IO () + -- ^ Write the history buffer to a file. The file should be formatted in the + -- same way as in the description for 'readHistory'. + } + +-- | Provides a sane default set of characters to use when breaking +-- lines into \'words\'. If a backend does not have configuratble +-- word break characters, the 'getWordBreakCharacters' can just +-- return this default set. +defaultWordBreakChars :: [Char] +defaultWordBreakChars = " \t\n\r\v`~!@#$%^&*()=[]{};\\\'\",<>" + +-- | This backend template is useful for defining custom backends. +-- The idea is that you will use 'templateBackend' to generate a +-- bare-bones backend implemenation and only fill in the methods +-- that you wish to define using the record update syntax. +-- The parameter to 'templateBackend' +-- becomes the backend state associated with the backend and is +-- passed into to each of the operation methods. +templateBackend :: a -> ShellBackend a +templateBackend bst = ShBackend + { initBackend = return bst + , shutdownBackend = \_ -> return () + , outputString = \_ _ -> return () + , flushOutput = \_ -> return () + , getSingleChar = \_ _ -> return Nothing + , getInput = \_ _ -> return Nothing + , addHistory = \_ _ -> return () + , setWordBreakChars = \_ _ -> return () + , getWordBreakChars = \_ -> return defaultWordBreakChars + , onCancel = \_ -> return () + , setAttemptedCompletionFunction = \_ _ -> return () + , setDefaultCompletionFunction = \_ _ -> return () + , completeFilename = \_ _ -> return [] + , completeUsername = \_ _ -> return [] + , clearHistoryState = \_ -> return () + , setMaxHistoryEntries = \_ _ -> return () + , getMaxHistoryEntries = \_ -> return 0 + , readHistory = \_ _ -> return () + , writeHistory = \_ _ -> return () + } diff --git a/src/System/Console/Shell/Backend/Basic.hs b/src/System/Console/Shell/Backend/Basic.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell/Backend/Basic.hs @@ -0,0 +1,69 @@ +{- + - + - Copyright 2005-2007, Robert Dockins. + - + -} + + +{- | This module implements a simple Shellac backend that uses only + the primitaves from "System.IO". It provides no history or + command completion capabilities. You get whatever line editing + capabilities 'hGetLine' has and that's it. +-} + +module System.Console.Shell.Backend.Basic +( basicBackend +) where + +import System.IO ( stdout, stderr, stdin, hFlush, hPutStr, hPutStrLn + , hGetLine, hGetChar, hGetBuffering, hSetBuffering + , BufferMode(..) + ) +import qualified Control.Exception as Ex + +import System.Console.Shell.Backend + +basicBackend :: ShellBackend () +basicBackend = ShBackend + { initBackend = return () + , shutdownBackend = \_ -> return () + , outputString = \_ -> basicOutput + , flushOutput = \_ -> hFlush stdout + , getSingleChar = \_ -> basicGetSingleChar + , getInput = \_ -> basicGetInput + , addHistory = \_ _ -> return () + , setWordBreakChars = \_ _ -> return () + , getWordBreakChars = \_ -> return defaultWordBreakChars + , onCancel = \_ -> hPutStrLn stdout "canceled...\n" + , setAttemptedCompletionFunction = \_ _ -> return () + , setDefaultCompletionFunction = \_ _ -> return () + , completeFilename = \_ _ -> return [] + , completeUsername = \_ _ -> return [] + , clearHistoryState = \_ -> return () + , getMaxHistoryEntries = \_ -> return 0 + , setMaxHistoryEntries = \_ _ -> return () + , readHistory = \_ _ -> return () + , writeHistory = \_ _ -> return () + } + +basicGetSingleChar :: String -> IO (Maybe Char) +basicGetSingleChar prompt = do + hPutStr stdout prompt + hFlush stdout + Ex.bracket (hGetBuffering stdin) (hSetBuffering stdin) $ \_ -> do + hSetBuffering stdin NoBuffering + c <- hGetChar stdin + hPutStrLn stdout "" + return (Just c) + +basicGetInput :: String -> IO (Maybe String) +basicGetInput prompt = do + hPutStr stdout prompt + hFlush stdout + x <- hGetLine stdin + return (Just x) + +basicOutput :: BackendOutput -> IO () +basicOutput (RegularOutput out) = hPutStr stdout out +basicOutput (InfoOutput out) = hPutStr stdout out +basicOutput (ErrorOutput out) = hPutStr stderr out diff --git a/src/System/Console/Shell/Commands.hs b/src/System/Console/Shell/Commands.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell/Commands.hs @@ -0,0 +1,279 @@ +{- + - + - Copyright 2005-2007, Robert Dockins. + - + -} + +module System.Console.Shell.Commands +( File (..) +, Username (..) +, Completable (..) +, Completion (..) +, showShellHelp +, showCmdHelp +, helpCommand +, exitCommand +, toggle +, cmd +, CommandFunction +, maybePrefix +, getShellCommands +, commandsRegex +) where + +import System.Console.Shell.Types +import System.Console.Shell.PPrint +import System.Console.Shell.Regex +import System.Console.Shell.ShellMonad + +maybePrefix :: ShellDescription st -> String +maybePrefix desc = case commandStyle desc of CharPrefixCommands x -> [x]; _ -> "" + +getShellCommands :: ShellDescription st -> [(String,CommandParser st,Doc,Doc)] +getShellCommands desc = map ($ desc) (shellCommands desc) + +-- | Represents a command argument which is a filename +newtype File = File String + +-- | Represents a command argument which is a username +newtype Username = Username String + + +-- | Represents a command argument which is an arbitrary +-- completable item. The type argument determines the +-- instance of 'Completion' which is used to create +-- completions for this command argument. +newtype Completable compl = Completable String + + +------------------------------------------------------------------ +-- | A typeclass representing user definable completion functions. + + +class Completion compl st | compl -> st where + -- | Actually generates the list of possible completions, given the + -- current shell state and a string representing the beginning of the word. + complete :: compl -> (st -> String -> IO [String]) + + -- | generates a label for the argument for use in the help displays. + completableLabel :: compl -> String + + + +----------------------------------------------------------------------- +-- | Prints the help message for this shell, which lists all avaliable +-- commands with their syntax and a short informative message about each. + +showShellHelp :: ShellDescription st -> String + +showShellHelp desc = show (commandHelpDoc desc (getShellCommands desc)) ++ "\n" + + +------------------------------------------------------------------------- +-- | Print the help message for a particular shell command + +showCmdHelp :: ShellDescription st -> String -> String + +showCmdHelp desc cmd = + case cmds of + [_] -> show (commandHelpDoc desc cmds) ++ "\n" + _ -> show (text "bad command name: " <> squotes (text cmd)) ++ "\n" + + where cmds = filter (\ (n,_,_,_) -> n == cmd) (getShellCommands desc) + + +commandHelpDoc :: ShellDescription st -> [(String,CommandParser st,Doc,Doc)] -> Doc + +commandHelpDoc desc cmds = + + vcat [ (fillBreak 20 syn) <+> msg | (_,_,syn,msg) <- cmds ] + + +------------------------------------------------------------------------------ +-- | Creates a shell command which will exit the shell. +exitCommand :: String -- ^ the name of the command + -> ShellCommand st +exitCommand name desc = ( name + , \_ -> [CompleteParse (shellSpecial ShellExit)] + , text (maybePrefix desc) <> text name + , text "Exit the shell" + ) + + +-------------------------------------------------------------------------- +-- | Creates a command which will print the shell help message. +helpCommand :: String -- ^ the name of the command + -> ShellCommand st +helpCommand name desc = ( name + , \_ -> [CompleteParse (shellSpecial (ShellHelp Nothing))] + , text (maybePrefix desc) <> text name + , text "Display the shell command help" + ) + + +--------------------------------------------------------- +-- | Creates a command to toggle a boolean value +toggle :: String -- ^ command name + -> String -- ^ help message + -> (st -> Bool) -- ^ getter + -> (Bool -> st -> st) -- ^ setter + -> ShellCommand st + +toggle name helpMsg getter setter desc = + ( name + , \_ -> [CompleteParse doToggle] + , text (maybePrefix desc) <> text name + , text helpMsg + ) + + where doToggle = do + st <- getShellSt + if getter st + then shellPutInfoLn (name++" off") >> putShellSt (setter False st) + else shellPutInfoLn (name++" on") >> putShellSt (setter True st) + +------------------------------------------------------------------- +-- | Creates a user defined shell commmand. This relies on the +-- typeclass machenery defined by 'CommandFunction'. +cmd :: CommandFunction f st + => String -- ^ the name of the command + -> f -- ^ the command function. See 'CommandFunction' for restrictions + -- on the type of this function. + -> String -- ^ the help string for this command + -> ShellCommand st + + +cmd name f helpMsg desc = + ( name + , parseCommand (wordBreakChars desc) f + , text (maybePrefix desc) <> text name <+> hsep (commandSyntax f) + , text helpMsg + ) + + +------------------------------------------------------------------------------ +-- | This class is used in the 'cmd' function to automaticly generate +-- the command parsers and command syntax strings for user defined +-- commands. The type of \'f\' is restricted to have a restricted set of +-- monomorphic arguments ('Int', 'Integer', 'Float', 'Double', 'String', +-- 'File', 'Username', and 'Completable') and the head type must be @Sh st ()@ +-- +-- > f :: Int -> File -> Sh MyShellState () +-- > g :: Double -> Sh st () +-- > h :: Sh SomeShellState () +-- +-- are all legal types, whereas: +-- +-- > bad1 :: a -> Sh (MyShellState a) () +-- > bad2 :: [Int] -> Sh MyShellState () +-- > bad3 :: Bool -> MyShellState +-- +-- are not. + +class CommandFunction f st | f -> st where + parseCommand :: String -> f -> CommandParser st + commandSyntax :: f -> [Doc] + + +------------------------------------------------------------- +-- Instances for the base case + +instance CommandFunction (Sh st ()) st where + parseCommand wbc m str = + do (x,[]) <- runRegex (maybeSpaceBefore (Epsilon (CompleteParse m))) str + return x + + commandSyntax _ = [] + +-------------------------------------------------------------- +-- Instances for the supported command argument types + +instance CommandFunction r st + => CommandFunction (Int -> r) st where + parseCommand = doParseCommand Nothing intRegex id + commandSyntax f = text (show intRegex) : commandSyntax (f undefined) + +instance CommandFunction r st + => CommandFunction (Integer -> r) st where + parseCommand = doParseCommand Nothing intRegex id + commandSyntax f = text (show intRegex) : commandSyntax (f undefined) + +instance CommandFunction r st + => CommandFunction (Float -> r) st where + parseCommand = doParseCommand Nothing floatRegex id + commandSyntax f = text (show floatRegex) : commandSyntax (f undefined) + +instance CommandFunction r st + => CommandFunction (Double -> r) st where + parseCommand = doParseCommand Nothing floatRegex id + commandSyntax f = text (show floatRegex) : commandSyntax (f undefined) + +instance CommandFunction r st + => CommandFunction (String -> r) st where + parseCommand wbc = doParseCommand Nothing (wordRegex wbc) id wbc + commandSyntax f = text (show (wordRegex "")) : commandSyntax (f undefined) + +instance CommandFunction r st + => CommandFunction (File -> r) st where + parseCommand wbc = doParseCommand + (Just FilenameCompleter) + (wordRegex wbc) + File + wbc + commandSyntax f = text "" : commandSyntax (f undefined) + +instance CommandFunction r st + => CommandFunction (Username -> r) st where + parseCommand wbc = doParseCommand + (Just UsernameCompleter) + (wordRegex wbc) + Username + wbc + commandSyntax f = text "" : commandSyntax (f undefined) + +instance (CommandFunction r st,Completion compl st) + => CommandFunction (Completable compl -> r) st where + parseCommand wbc = doParseCommand + (Just (OtherCompleter (complete (undefined::compl)))) + (wordRegex wbc) + Completable + wbc + commandSyntax f = text (completableLabel (undefined::compl)) : commandSyntax (f undefined) + + +---------------------------------------------------------------- +-- Helper functions used in the above instance declarations +-- These make use of the hackish regex library. + +doParseCommand compl re proj wbc f [] = return (IncompleteParse compl) +doParseCommand compl re proj wbc f str = + let xs = runRegex (maybeSpaceBefore (maybeSpaceAfter re)) str + in case xs of + [] -> return (IncompleteParse compl) + _ -> do (x,str') <- xs; parseCommand wbc (f (proj x)) str' + +commandsRegex :: ShellDescription st -> Regex Char (String,CommandParser st,Doc,Doc) +commandsRegex desc = + case commandStyle desc of + CharPrefixCommands ch -> prefixCommandsRegex ch (getShellCommands desc) + OnlyCommands -> onlyCommandsRegex (getShellCommands desc) + SingleCharCommands -> singleCharCommandRegex (getShellCommands desc) + +onlyCommandsRegex :: [(String,CommandParser st,Doc,Doc)] -> Regex Char (String,CommandParser st,Doc,Doc) +onlyCommandsRegex xs = + Concat (\_ x -> x) maybeSpaceRegex $ + Concat (\x _ -> x) (anyOfRegex (map (\ (x,y,z,w) -> (x,(x,y,z,w))) xs)) $ + spaceRegex + +prefixCommandsRegex :: Char -> [(String,CommandParser st,Doc,Doc)] -> Regex Char (String,CommandParser st,Doc,Doc) +prefixCommandsRegex ch xs = + Concat (\_ x -> x) maybeSpaceRegex $ + Concat (\_ x -> x) (strTerminal ch) $ + Concat (\x _ -> x) (anyOfRegex (map (\ (x,y,z,w) -> (x,(x,y,z,w))) xs)) $ + spaceRegex + +singleCharCommandRegex :: [(String,CommandParser st,Doc,Doc)] -> Regex Char (String,CommandParser st,Doc,Doc) +singleCharCommandRegex xs = + altProj + (anyOfRegex (map (\ (x,y,z,w) -> ([head x],(x,y,z,w))) xs)) + (Epsilon ("",\_ -> [CompleteParse (shellSpecial ShellNothing)],empty,empty)) diff --git a/src/System/Console/Shell/ConsoleHandler.hs b/src/System/Console/Shell/ConsoleHandler.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell/ConsoleHandler.hs @@ -0,0 +1,44 @@ +{- + - + - Copyright 2005-2007, Robert Dockins. + - + -} + +module System.Console.Shell.ConsoleHandler +( withControlCHandler +) where + +import qualified Control.Exception as Ex + +#ifndef mingw32_HOST_OS + +import qualified System.Posix.Signals as PS + +withControlCHandler :: IO () -> IO a -> IO a +withControlCHandler hdl m = + Ex.bracket + (PS.installHandler PS.keyboardSignal (PS.Catch hdl) Nothing) + (\oldh -> PS.installHandler PS.keyboardSignal oldh Nothing) + (\_ -> m) + +#else + +import qualified GHC.ConsoleHandler as CH + + +handleCtrlC :: IO () -> CH.Handler +handleCtrlC hdl = CH.Catch $ \ev -> + case ev of + CH.ControlC -> hdl + _ -> return () + + +withControlCHandler :: IO () -> IO a -> IO a +withControlCHandler hdl m = + Ex.bracket + (CH.installHandler (handleCtrlC hdl)) + (\oldh -> CH.installHandler oldh) + (\_ -> m) + + +#endif diff --git a/src/System/Console/Shell/PPrint.hs b/src/System/Console/Shell/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell/PPrint.hs @@ -0,0 +1,407 @@ +----------------------------------------------------------- +-- Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan +-- +-- Pretty print module based on Philip Wadlers "prettier printer" +-- "A prettier printer" +-- Draft paper, April 1997, revised March 1998. +-- http://cm.bell-labs.com/cm/cs/who/wadler/papers/prettier/prettier.ps +-- +-- Haskell98 compatible +----------------------------------------------------------- +module System.Console.Shell.PPrint + ( Doc + , Pretty, pretty + + , show, putDoc, hPutDoc + + , (<>) + , (<+>) + , (), () + , (<$>), (<$$>) + + , sep, fillSep, hsep, vsep + , cat, fillCat, hcat, vcat + , punctuate + + , align, hang, indent + , fill, fillBreak + + , list, tupled, semiBraces, encloseSep + , angles, langle, rangle + , parens, lparen, rparen + , braces, lbrace, rbrace + , brackets, lbracket, rbracket + , dquotes, dquote, squotes, squote + + , comma, space, dot, backslash + , semi, colon, equals + + , string, bool, int, integer, float, double, rational + + , softline, softbreak + , empty, char, text, line, linebreak, nest, group + , column, nesting, width + + , SimpleDoc(..) + , renderPretty, renderCompact + , displayS, displayIO + ) where + +import IO (Handle,hPutStr,hPutChar,stdout) + +infixr 5 ,,<$>,<$$> +infixr 6 <>,<+> + + +----------------------------------------------------------- +-- list, tupled and semiBraces pretty print a list of +-- documents either horizontally or vertically aligned. +----------------------------------------------------------- +list = encloseSep lbracket rbracket comma +tupled = encloseSep lparen rparen comma +semiBraces = encloseSep lbrace rbrace semi + +encloseSep left right sep ds + = case ds of + [] -> left <> right + [d] -> left <> d <> right + _ -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right) + + +----------------------------------------------------------- +-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn] +----------------------------------------------------------- +punctuate p [] = [] +punctuate p [d] = [d] +punctuate p (d:ds) = (d <> p) : punctuate p ds + + +----------------------------------------------------------- +-- high-level combinators +----------------------------------------------------------- +sep = group . vsep +fillSep = fold () +hsep = fold (<+>) +vsep = fold (<$>) + +cat = group . vcat +fillCat = fold () +hcat = fold (<>) +vcat = fold (<$$>) + +fold f [] = empty +fold f ds = foldr1 f ds + +x <> y = x `beside` y +x <+> y = x <> space <> y +x y = x <> softline <> y +x y = x <> softbreak <> y +x <$> y = x <> line <> y +x <$$> y = x <> linebreak <> y + +softline = group line +softbreak = group linebreak + +squotes = enclose squote squote +dquotes = enclose dquote dquote +braces = enclose lbrace rbrace +parens = enclose lparen rparen +angles = enclose langle rangle +brackets = enclose lbracket rbracket +enclose l r x = l <> x <> r + +lparen = char '(' +rparen = char ')' +langle = char '<' +rangle = char '>' +lbrace = char '{' +rbrace = char '}' +lbracket = char '[' +rbracket = char ']' + +squote = char '\'' +dquote = char '"' +semi = char ';' +colon = char ':' +comma = char ',' +space = char ' ' +dot = char '.' +backslash = char '\\' +equals = char '=' + + +----------------------------------------------------------- +-- Combinators for prelude types +----------------------------------------------------------- + +-- string is like "text" but replaces '\n' by "line" +string "" = empty +string ('\n':s) = line <> string s +string s = case (span (/='\n') s) of + (xs,ys) -> text xs <> string ys + +bool :: Bool -> Doc +bool b = text (show b) + +int :: Int -> Doc +int i = text (show i) + +integer :: Integer -> Doc +integer i = text (show i) + +float :: Float -> Doc +float f = text (show f) + +double :: Double -> Doc +double d = text (show d) + +rational :: Rational -> Doc +rational r = text (show r) + + +----------------------------------------------------------- +-- overloading "pretty" +----------------------------------------------------------- +class Pretty a where + pretty :: a -> Doc + prettyList :: [a] -> Doc + prettyList = list . map pretty + +instance Pretty a => Pretty [a] where + pretty = prettyList + +instance Pretty Doc where + pretty = id + +instance Pretty () where + pretty () = text "()" + +instance Pretty Bool where + pretty b = bool b + +instance Pretty Char where + pretty c = char c + prettyList s = string s + +instance Pretty Int where + pretty i = int i + +instance Pretty Integer where + pretty i = integer i + +instance Pretty Float where + pretty f = float f + +instance Pretty Double where + pretty d = double d + + +--instance Pretty Rational where +-- pretty r = rational r + +instance (Pretty a,Pretty b) => Pretty (a,b) where + pretty (x,y) = tupled [pretty x, pretty y] + +instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where + pretty (x,y,z)= tupled [pretty x, pretty y, pretty z] + +instance Pretty a => Pretty (Maybe a) where + pretty Nothing = empty + pretty (Just x) = pretty x + + + +----------------------------------------------------------- +-- semi primitive: fill and fillBreak +----------------------------------------------------------- +fillBreak f x = width x (\w -> + if (w > f) then nest f linebreak + else text (spaces (f - w))) + +fill f d = width d (\w -> + if (w >= f) then empty + else text (spaces (f - w))) + +width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1))) + + +----------------------------------------------------------- +-- semi primitive: Alignment and indentation +----------------------------------------------------------- +indent i d = hang i (text (spaces i) <> d) + +hang i d = align (nest i d) + +align d = column (\k -> + nesting (\i -> nest (k - i) d)) --nesting might be negative :-) + + + +----------------------------------------------------------- +-- Primitives +----------------------------------------------------------- +data Doc = Empty + | Char Char -- invariant: char is not '\n' + | Text !Int String -- invariant: text doesn't contain '\n' + | Line !Bool -- True <=> when undone by group, do not insert a space + | Cat Doc Doc + | Nest !Int Doc + | Union Doc Doc -- invariant: first lines of first doc longer than the first lines of the second doc + | Column (Int -> Doc) + | Nesting (Int -> Doc) + +data SimpleDoc = SEmpty + | SChar Char SimpleDoc + | SText !Int String SimpleDoc + | SLine !Int SimpleDoc + + +empty = Empty + +char '\n' = line +char c = Char c + +text "" = Empty +text s = Text (length s) s + +line = Line False +linebreak = Line True + +beside x y = Cat x y +nest i x = Nest i x +column f = Column f +nesting f = Nesting f +group x = Union (flatten x) x + +flatten :: Doc -> Doc +flatten (Cat x y) = Cat (flatten x) (flatten y) +flatten (Nest i x) = Nest i (flatten x) +flatten (Line break) = if break then Empty else Text 1 " " +flatten (Union x y) = flatten x +flatten (Column f) = Column (flatten . f) +flatten (Nesting f) = Nesting (flatten . f) +flatten other = other --Empty,Char,Text + + + +----------------------------------------------------------- +-- Renderers +----------------------------------------------------------- + +----------------------------------------------------------- +-- renderPretty: the default pretty printing algorithm +----------------------------------------------------------- + +-- list of indentation/document pairs; saves an indirection over [(Int,Doc)] +data Docs = Nil + | Cons !Int Doc Docs + +renderPretty :: Float -> Int -> Doc -> SimpleDoc +renderPretty rfrac w x + = best 0 0 (Cons 0 x Nil) + where + -- r :: the ribbon width in characters + r = max 0 (min w (round (fromIntegral w * rfrac))) + + -- best :: n = indentation of current line + -- k = current column + -- (ie. (k >= n) && (k - n == count of inserted characters) + best n k Nil = SEmpty + best n k (Cons i d ds) + = case d of + Empty -> best n k ds + Char c -> let k' = k+1 in seq k' (SChar c (best n k' ds)) + Text l s -> let k' = k+l in seq k' (SText l s (best n k' ds)) + Line _ -> SLine i (best i i ds) + Cat x y -> best n k (Cons i x (Cons i y ds)) + Nest j x -> let i' = i+j in seq i' (best n k (Cons i' x ds)) + Union x y -> nicest n k (best n k (Cons i x ds)) + (best n k (Cons i y ds)) + + Column f -> best n k (Cons i (f k) ds) + Nesting f -> best n k (Cons i (f i) ds) + + --nicest :: r = ribbon width, w = page width, + -- n = indentation of current line, k = current column + -- x and y, the (simple) documents to chose from. + -- precondition: first lines of x are longer than the first lines of y. + nicest n k x y | fits width x = x + | otherwise = y + where + width = min (w - k) (r - k + n) + + +fits w x | w < 0 = False +fits w SEmpty = True +fits w (SChar c x) = fits (w - 1) x +fits w (SText l s x) = fits (w - l) x +fits w (SLine i x) = True + + +----------------------------------------------------------- +-- renderCompact: renders documents without indentation +-- fast and fewer characters output, good for machines +----------------------------------------------------------- +renderCompact :: Doc -> SimpleDoc +renderCompact x + = scan 0 [x] + where + scan k [] = SEmpty + scan k (d:ds) = case d of + Empty -> scan k ds + Char c -> let k' = k+1 in seq k' (SChar c (scan k' ds)) + Text l s -> let k' = k+l in seq k' (SText l s (scan k' ds)) + Line _ -> SLine 0 (scan 0 ds) + Cat x y -> scan k (x:y:ds) + Nest j x -> scan k (x:ds) + Union x y -> scan k (y:ds) + Column f -> scan k (f k:ds) + Nesting f -> scan k (f 0:ds) + + + +----------------------------------------------------------- +-- Displayers: displayS and displayIO +----------------------------------------------------------- +displayS :: SimpleDoc -> ShowS +displayS SEmpty = id +displayS (SChar c x) = showChar c . displayS x +displayS (SText l s x) = showString s . displayS x +displayS (SLine i x) = showString ('\n':indentation i) . displayS x + +displayIO :: Handle -> SimpleDoc -> IO () +displayIO handle simpleDoc + = display simpleDoc + where + display SEmpty = return () + display (SChar c x) = do{ hPutChar handle c; display x} + display (SText l s x) = do{ hPutStr handle s; display x} + display (SLine i x) = do{ hPutStr handle ('\n':indentation i); display x} + + +----------------------------------------------------------- +-- default pretty printers: show, putDoc and hPutDoc +----------------------------------------------------------- +instance Show Doc where + showsPrec d doc = displayS (renderPretty 0.4 80 doc) + +putDoc :: Doc -> IO () +putDoc doc = hPutDoc stdout doc + +hPutDoc :: Handle -> Doc -> IO () +hPutDoc handle doc = displayIO handle (renderPretty 0.4 80 doc) + + + +----------------------------------------------------------- +-- insert spaces +-- "indentation" used to insert tabs but tabs seem to cause +-- more trouble than they solve :-) +----------------------------------------------------------- +spaces n | n <= 0 = "" + | otherwise = replicate n ' ' + +indentation n = spaces n + +--indentation n | n >= 8 = '\t' : indentation (n-8) +-- | otherwise = spaces n diff --git a/src/System/Console/Shell/Regex.hs b/src/System/Console/Shell/Regex.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell/Regex.hs @@ -0,0 +1,246 @@ +{- + - + - Copyright 2005-2007, Robert Dockins. + - + -} + +{- This module implements a pretty hokey version of regular expressions. + - They are used to parse the arguments to shell commands and to give + - information about the type of the argument at a position in the + - string to allow positional word completion. The REs are directly + - interpreted in the list monad, so effeciency isn't so great, but + - for most shell command lines that won't matter too much. + -} + +module System.Console.Shell.Regex where + +import Numeric ( readDec, readFloat, readHex ) +import Control.Monad ( MonadPlus(..) ) + + +{- The type of regular expressions. Regular expressions evaluation + calculates a result value as well as recognizing strings in a language. + The Regex data type was originally coded as a GADT. However, only exestentials + are required, so it is reformulated here using existential quantification. +-} + +data Regex a x + = Empty + | Epsilon x + | Label String (Regex a x) + | Terminal (a -> Bool) (a -> x) String + | External ([a] -> [(x,[a])]) String + | forall p q. Concat (p -> q -> x) (Regex a p) (Regex a q) + | forall p q. Alt (Either p q -> x) (Regex a p) (Regex a q) + | forall p . Star ([p] -> x) (Regex a p) + + +{- Auxiliary type used to help remove unnecessary parenthesis when printing REs -} +data RegexContext + = TopContext + | AltContext + | ConcatContext + | StarContext + deriving Eq + +{- Print a string representation of a regular expression. + Really only useful for debugging becuase there is no + inverse (parser). +-} +showRegex :: RegexContext -> Regex a x -> String +showRegex cxt (Label l _) = l +showRegex cxt Empty = "%empty" +showRegex cxt (Epsilon _) = "" +showRegex cxt (Terminal _ _ l) = l +showRegex cxt (External _ l) = l +showRegex cxt (Alt _ p q) = parenIf (cxt == StarContext || cxt == ConcatContext) $ + concat [showRegex AltContext p,"|",showRegex AltContext q] +showRegex cxt (Concat _ p q) = parenIf (cxt == StarContext) $ + concat [showRegex ConcatContext p,showRegex ConcatContext q] +showRegex cxt (Star _ x) = concat [showRegex StarContext x,"*"] + +parenIf :: Bool -> String -> String +parenIf False str = str +parenIf True str = "("++str++")" + +instance Show (Regex a x) where + show = showRegex TopContext + + +{- Returns true if the regular expressions matches the + input list -} +matchesRegex :: Regex a x -> [a] -> Bool +matchesRegex re ts = not (null (matchRegex re ts)) + +{- Generates a list of all calculated values from + matches on the RE. Returns the empty list if + there are no matches +-} +matchRegex :: Regex a x -> [a] -> [x] +matchRegex re ts = [ x | (x,[]) <- runRegex re ts ] + +{- Generates a list corresponding to all + partial matches of the regular expression. + The first component is the calculated value and + the second component is the remaining unmatched input +-} +runRegex :: Regex a x -> [a] -> [(x,[a])] + +runRegex Empty ts = mzero + +runRegex (Epsilon x) ts = return (x,ts) + +runRegex (Terminal cond f _) (t:ts) + | cond t = return (f t,ts) + | otherwise = mzero + +runRegex (Label _ re) ts = runRegex re ts + +runRegex (Concat f p q) ts = + do (a,ts') <- runRegex p ts + (b,ts'') <- runRegex q ts' + return (f a b,ts'') + +runRegex (Alt f p q) ts = + (runRegex p ts >>= \(a,ts') -> return (f (Left a),ts')) `mplus` + (runRegex q ts >>= \(a,ts') -> return (f (Right a),ts')) + +runRegex (Star f p) ts = match [] ts + where match as ts = + (runRegex p ts >>= \(a,ts') -> match (a:as) ts') `mplus` + (return (f (reverse as),ts)) + +runRegex (External f _) ts = f ts + +runRegex _ _ = mzero + + +strEpsilon :: Regex Char String +strEpsilon = Epsilon [] +strTerminal ch = Terminal (==ch) (:[]) [ch] +strConcat = Concat (++) +strAlt = altProj +strStar = Star concat +strSpace = Terminal (`elem` " \v\t\n\r\f") id "" +strAny = Terminal (const True) (:[]) "" + +altProj = Alt (\x -> case x of Left a -> a; Right a -> a) + +starRegex :: Regex a x -> Regex a [x] +starRegex re = Star id re + +plusRegex :: Regex a x -> Regex a [x] +plusRegex re = Label (concat [showRegex TopContext re,"+"]) $ + Concat (:) re (Star id re) + +optRegex :: Regex a x -> Regex a (Maybe x) +optRegex re = Label (concat ["[",showRegex TopContext re,"]"]) $ + Alt (\x -> case x of Left a -> Just a; Right () -> Nothing) + re + (Epsilon ()) + +manyRegex :: Regex a x -> Regex a y -> Regex a [x] +manyRegex re sep = Label (concat ["{",showRegex TopContext re,"}"]) $ + (Concat (:) re (Star id (Concat (\_ x -> x) sep re))) + `altProj` (Epsilon [] ) + +stringRegex :: String -> x -> Regex Char x +stringRegex str v = foldr (\c -> Concat (\_ x -> x) (strTerminal c)) (Epsilon v) str + +anyOfRegex :: [(String,x)] -> Regex Char x +anyOfRegex [] = Empty +anyOfRegex xs = foldr1 altProj (map (uncurry stringRegex) xs) + +spaceRegex :: Regex Char String +spaceRegex = Label " " (plusRegex strSpace) + +maybeSpaceRegex :: Regex Char String +maybeSpaceRegex = Label "" (starRegex strSpace) + +maybeSpaceBefore :: Regex Char x -> Regex Char x +maybeSpaceBefore re = Concat (\_ x -> x) maybeSpaceRegex re + +spaceAfter :: Regex Char x -> Regex Char x +spaceAfter re = Concat (\x _ -> x) re spaceRegex + +maybeSpaceAfter :: Regex Char x -> Regex Char x +maybeSpaceAfter re = Concat (\x _ -> x) re maybeSpaceRegex + +signRegex :: Num a => Regex Char (a -> a) +signRegex = + (Epsilon id) `altProj` + (Terminal (== '+') (const id) "+") `altProj` + (Terminal (== '-') (const negate) "-") + +intRegex :: Integral a => Regex Char a +intRegex = Label "" $ + Concat (\sign int -> sign int) signRegex (External readDec "") + +floatRegex :: RealFloat a => Regex Char a +floatRegex = Label "" $ + Concat (\sign float -> sign float) signRegex (External readFloat "") + +boolRegex :: Regex Char Bool +boolRegex = Label "" $ + stringRegex "true" True `altProj` + stringRegex "false" False `altProj` + stringRegex "yes" True `altProj` + stringRegex "no" False `altProj` + stringRegex "t" True `altProj` + stringRegex "f" False `altProj` + stringRegex "y" True `altProj` + stringRegex "n" False `altProj` + stringRegex "1" True `altProj` + stringRegex "0" False + +wordsRegex :: String -> Regex Char [String] +wordsRegex wbc = manyRegex (wordRegex wbc) spaceRegex + +wordRegex :: String -> Regex Char String +wordRegex wbc = Label "" $ + plusRegex wordChar `altProj` + singleQuotes `altProj` + doubleQuotes + + where + wordChar = Terminal (not . (`elem` wbc)) id "" + + singleQuotes = + Concat (\_ x -> x) (strTerminal '\'') $ + Concat (\x _ -> x) (Star id (Terminal (/= '\'') id "")) $ + (strTerminal '\'') + + doubleQuotes = + Concat (\_ x -> x) (strTerminal '\"') $ + Concat (\x _ -> x) (Star id insideDQuotes) $ + (strTerminal '\"') + + insideDQuotes = + (Terminal (not . (`elem` "\\\"")) id "") `altProj` + (Concat (\_ x -> x) + (strTerminal '\\') + escapes + ) + + escapes = + Alt (\x -> case x of Left a -> a; Right i -> toEnum i) + ( (Terminal (== 'a') (const '\a') "") `altProj` + (Terminal (== 'b') (const '\b') "") `altProj` + (Terminal (== 'f') (const '\f') "") `altProj` + (Terminal (== 'n') (const '\n') "") `altProj` + (Terminal (== 'r') (const '\r') "") `altProj` + (Terminal (== 't') (const '\t') "") `altProj` + (Terminal (== 'v') (const '\v') "") `altProj` + (Terminal (== '\\') (const '\\') "") `altProj` + (Terminal (== '\'') (const '\'') "") + ) + ( ( Concat (\_ x -> x) (strTerminal '0') $ + Concat (\_ x -> x) (strTerminal 'x') $ + External readHex "" + ) `altProj` + ( Concat (\_ x -> x) (strTerminal 'x') $ + External readHex "" + ) `altProj` + ( External readDec "" + ) + ) diff --git a/src/System/Console/Shell/RunShell.hs b/src/System/Console/Shell/RunShell.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell/RunShell.hs @@ -0,0 +1,375 @@ +{- + - + - Copyright 2005-2007, Robert Dockins. + - + -} + +module System.Console.Shell.RunShell ( + runShell +, defaultExceptionHandler +, simpleSubshell +) where + +import Maybe ( isJust ) +import Data.Char ( isSpace ) +import Data.List ( isPrefixOf, find ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Control.Monad ( when, MonadPlus(..) ) +import Control.Monad.Error () +import Control.Concurrent ( ThreadId, threadDelay, killThread, forkIO ) +import Control.Concurrent.MVar ( MVar, newEmptyMVar, tryTakeMVar, tryPutMVar, withMVar, takeMVar, putMVar ) +import System.Directory ( doesFileExist ) +import qualified Control.Exception as Ex + +import System.Console.Shell.Backend +import System.Console.Shell.ShellMonad +import System.Console.Shell.Types +import System.Console.Shell.Commands +import System.Console.Shell.PPrint +import System.Console.Shell.Regex (runRegex) +import System.Console.Shell.ConsoleHandler + +------------------------------------------------------------------- +-- A record to hold some of the internal muckety-muck needed +-- to make the shell go. This is mostly concurrency variables +-- needed to handle keyboard interrupts. + +data InternalShellState st bst + = InternalShellState + { evalVar :: MVar (Maybe (st,Maybe (ShellSpecial st))) + , evalThreadVar :: MVar ThreadId + , cancelHandler :: IO () + , backendState :: bst + , continuedInput :: MVar String + } + + +------------------------------------------------------------------- +-- Main entry point for the shell. Sets up all the internal state +-- needed to run shell commands and evaluation in a separate thread and +-- initializes the backend. + + +-- | Run a shell. Given a shell description, a shell backend to use +-- and an initial state this function runs the shell until it exits, +-- and then returns the final state. + +runShell :: ShellDescription st + -> ShellBackend bst + -> st + -> IO st +runShell desc backend init = Ex.bracket setupShell exitShell (\iss -> executeShell desc backend iss init) + where + setupShell = do + evVar <- newEmptyMVar + thVar <- newEmptyMVar + ci <- newEmptyMVar + bst <- initBackend backend + + return InternalShellState + { evalVar = evVar + , evalThreadVar = thVar + , cancelHandler = handleINT evVar thVar + , backendState = bst + , continuedInput = ci + } + + exitShell iss = do + shutdownBackend backend (backendState iss) + + +executeShell + :: ShellDescription st + -> ShellBackend bst + -> InternalShellState st bst + -> st + -> IO st +executeShell desc backend iss init = do + when (historyEnabled desc) (do + setMaxHistoryEntries backend (backendState iss) (maxHistoryEntries desc) + loadHistory desc backend (backendState iss)) + + maybe (return ()) + (outputString backend (backendState iss) . InfoOutput) + (greetingText desc) + + final <- shellLoop desc backend iss init + + when (historyEnabled desc) (do + saveHistory desc backend (backendState iss) + clearHistoryState backend (backendState iss)) + + flushOutput backend (backendState iss) + + return final + + + + +-- helper function that triggers when an INT signal is caught +handleINT :: MVar (Maybe (st,Maybe (ShellSpecial st))) -> MVar ThreadId -> IO () +handleINT evVar thVar = do + x <- tryPutMVar evVar Nothing + when x (withMVar thVar killThread) + +------------------------------------------------------------------------- +-- This function is installed as the attempted completion function. +-- It attempts to match the prefix of the input buffer against a +-- command. If it matches, it supplies the completions appropriate +-- for that point in the command. Otherwise it returns Nothing; in +-- that case, the backend will fall back on the default completion function +-- set in the shell description. + +completionFunction :: ShellDescription st + -> ShellBackend bst + -> bst + -> st + -> (String,String,String) + -> IO (Maybe (String,[String])) + +completionFunction desc backend bst st line@(before,word,after) = do + if all isSpace before + then completeCommands desc line + else case runRegex (commandsRegex desc) before of + [((_,cmdParser,_,_),before')] -> do + let completers = [ z | IncompleteParse (Just z) <- cmdParser before' ] + strings <- case completers of + FilenameCompleter:_ -> completeFilename backend bst word >>= return . Just + UsernameCompleter:_ -> completeUsername backend bst word >>= return . Just + (OtherCompleter f):_ -> f st word >>= return . Just + _ -> return Nothing + case strings of + Nothing -> return Nothing + Just [] -> return Nothing + Just xs -> return (Just (maximalPrefix xs,xs)) + + _ -> return Nothing + + + +completeCommands :: ShellDescription st + -> (String,String,String) + -> IO (Maybe (String,[String])) + +completeCommands desc (before,word,after) = + case matchingNames of + [] -> return $ Nothing + xs -> return $ Just (maximalPrefix xs,xs) + + where matchingNames = filter (word `isPrefixOf`) cmdNames + cmdNames = map (\ (n,_,_,_) -> (maybePrefix desc)++n) (getShellCommands desc) + +maximalPrefix :: [String] -> String +maximalPrefix [] = [] +maximalPrefix (x:xs) = f x xs + where f p [] = p + f p (x:xs) = f (fst $ unzip $ takeWhile (\x -> fst x == snd x) $ zip p x) xs + + + +----------------------------------------------------------- +-- Deal with reading and writing history files. + +loadHistory :: ShellDescription st + -> ShellBackend bst + -> bst + -> IO () + +loadHistory desc backend bst = + case historyFile desc of + Nothing -> return () + Just path -> do + fexists <- doesFileExist path + when fexists $ + Ex.handle + (\ex -> (outputString backend bst) (ErrorOutput $ + concat ["could not read history file '",path,"'\n ",show ex])) + (readHistory backend bst path) + +saveHistory :: ShellDescription st + -> ShellBackend bst + -> bst + -> IO () + +saveHistory desc backend bst = + case historyFile desc of + Nothing -> return () + Just path -> + Ex.handle + (\ex -> (outputString backend bst) (ErrorOutput $ + concat ["could not write history file '",path,"'\n ",show ex])) + (writeHistory backend bst path) + + +----------------------------------------------------------- +-- The real meat. We setup backend stuff, call the backend +-- to get the input string, and then handle the input. + + +shellLoop :: ShellDescription st + -> ShellBackend bst + -> InternalShellState st bst + -> st + -> IO st + +shellLoop desc backend iss = loop + where + bst = backendState iss + + loop st = do + flushOutput backend bst + + runSh st (outputString backend bst) (beforePrompt desc) + setAttemptedCompletionFunction backend bst + (completionFunction desc backend bst st) + + case defaultCompletions desc of + Nothing -> setDefaultCompletionFunction backend bst $ Nothing + Just f -> setDefaultCompletionFunction backend bst $ Just (f st) + + setWordBreakChars backend bst (wordBreakChars desc) + + ci <- tryTakeMVar (continuedInput iss) + + pr <- getPrompt (isJust ci) st + + inp <- doGetInput ci pr + + case inp of + Nothing -> return st + Just inp' -> if not (isJust ci) + then handleInput inp' st + else evaluateInput inp' st + + + doGetInput :: Maybe String -> String -> IO (Maybe String) + doGetInput ci pr = + case commandStyle desc of + SingleCharCommands -> do + c <- getSingleChar backend bst pr + return (fmap (:[]) c) + + _ -> do + str <- getInput backend bst pr + return (fmap (\x -> maybe x (++ '\n':x) ci) str) + + + getPrompt False st = prompt desc st + getPrompt True st = case secondaryPrompt desc of + Nothing -> prompt desc st + Just f -> f st + + + handleInput inp st = do + when (historyEnabled desc && (isJust (find (not . isSpace) inp))) + (addHistory backend bst inp) + + let inp' = inp++" " -- hack, makes commands unambiguous + + case runRegex (commandsRegex desc) inp' of + (x,inp''):_ -> executeCommand x inp'' st + [] -> evaluateInput inp st + + + executeCommand (cmdName,cmdParser,_,_) inp st = + let parses = cmdParser inp + parses' = concatMap (\x -> case x of CompleteParse z -> [z]; _ -> []) parses + in case parses' of + f:_ -> do + r <- handleExceptions desc (\x -> runSh x (outputString backend bst) f) st + case r of + (st',Just spec) -> handleSpecial st' spec + (st',Nothing) -> loop st' + + _ -> (outputString backend bst) (InfoOutput $ showCmdHelp desc cmdName) >> loop st + + + handleSpecial st ShellExit = return st + handleSpecial st ShellNothing = loop st + handleSpecial st (ShellHelp Nothing) = (outputString backend bst) (InfoOutput $ showShellHelp desc) >> loop st + handleSpecial st (ShellHelp (Just cmd)) = (outputString backend bst) (InfoOutput $ showCmdHelp desc cmd) >> loop st + handleSpecial st (ShellContinueLine str) = putMVar (continuedInput iss) str >> loop st + handleSpecial st (ExecSubshell subshell) = runSubshell desc subshell backend bst st >>= loop + + + handleExceptions desc f st = Ex.catch (f st) $ \ex -> + runSh st (outputString backend bst) (exceptionHandler desc ex) + + + runThread eval inp iss st = do + val <- handleExceptions desc (\x -> runSh x (outputString backend bst) (eval inp)) st + tryPutMVar (evalVar iss) (Just val) + return () + + evaluateInput inp st = + let eVar = evalVar iss + tVar = evalThreadVar iss + in do tryTakeMVar eVar + tryTakeMVar tVar + tid <- forkIO (runThread (evaluateFunc desc) inp iss st) + putMVar tVar tid + result <- withControlCHandler (cancelHandler iss) (takeMVar eVar) + case result of + Nothing -> onCancel backend bst >> loop st + Just (st',Just spec) -> handleSpecial st' spec + Just (st',Nothing) -> loop st' + + + +------------------------------------------------------------------------- +-- | The default shell exception handler. It simply prints the exception +-- and returns the shell state unchanged. (However, it specificaly +-- ignores the thread killed exception, because that is used to +-- implement execution canceling) + +defaultExceptionHandler :: Ex.Exception -> Sh st () + +defaultExceptionHandler (Ex.AsyncException Ex.ThreadKilled) = return () +defaultExceptionHandler ex = do + shellPutErrLn $ concat ["The following exception occurred:\n ",show ex] + +---------------------------------------------------------------------------- +-- | Creates a simple subshell from a state mapping function +-- and a shell description. +simpleSubshell :: (st -> IO st') -- ^ A function to generate the initial subshell + -- state from the outer shell state + -> ShellDescription st' -- ^ A shell description for the subshell + -> IO (Subshell st st') + +simpleSubshell toSubSt desc = do + ref <- newIORef undefined + let toSubSt' st = writeIORef ref st >> toSubSt st + let fromSubSt subSt = readIORef ref + let mkDesc _ = return desc + return (toSubSt',fromSubSt,mkDesc) + + +---------------------------------------------------------------------------- +-- | Execute a subshell, suspending the outer shell until the subshell exits. +runSubshell :: ShellDescription desc -- ^ the description of the outer shell + -> Subshell st st' -- ^ the subshell to execute + -> ShellBackend bst -- ^ the shell backend to use + -> bst -- ^ the backendstate + -> st -- ^ the current state + -> IO st -- ^ the modified state + + +runSubshell desc (toSubSt, fromSubSt, mkSubDesc) backend bst st = do + subSt <- toSubSt st + subDesc <- mkSubDesc subSt + + evVar <- newEmptyMVar + thVar <- newEmptyMVar + ci <- newEmptyMVar + + let iss = InternalShellState + { evalVar = evVar + , evalThreadVar = thVar + , cancelHandler = handleINT evVar thVar + , backendState = bst + , continuedInput = ci + } + + subSt' <- executeShell subDesc backend iss subSt + st' <- fromSubSt subSt' + return st' diff --git a/src/System/Console/Shell/ShellMonad.hs b/src/System/Console/Shell/ShellMonad.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell/ShellMonad.hs @@ -0,0 +1,89 @@ +{- + - + - Copyright 2005-2007, Robert Dockins. + - + -} + +-- | This module implements a monad for use in shell commands and in +-- evaluation functions. It is a state moand layered over @IO@. +-- @liftIO@ may be used to execute arbitrary I\/O actions. However, +-- the @shellPut@* commands are the preferred way to output text. + +module System.Console.Shell.ShellMonad ( +-- * The Shell monad + Sh +, runSh + +-- * Output functions +, shellPut +, shellPutStr, shellPutStrLn +, shellPutInfo, shellPutInfoLn +, shellPutErr, shellPutErrLn + +-- * Shell state accessors +, getShellSt, putShellSt +, modifyShellSt + +-- * Special actions +, shellSpecial +) where + +import Control.Monad.Reader +import Control.Monad.State + +import System.Console.Shell.Backend +import System.Console.Shell.Types + +-- | Execute a shell action +runSh :: st -> OutputCommand -> Sh st () -> IO (CommandResult st) +runSh st info = (flip runReaderT) info . (flip execStateT) (st,Nothing) . unSh + +-- | Output a tagged string to the console +shellPut :: BackendOutput -> Sh st () +shellPut out = Sh (lift ask >>= \f -> liftIO (f out)) + +-- | Prints a regular output string with a line terminator +shellPutStr :: String -> Sh st () +shellPutStr = shellPut . RegularOutput + +-- | Prints an informational output string +shellPutInfo :: String -> Sh st () +shellPutInfo = shellPut . InfoOutput + +-- | Prints an error output string +shellPutErr :: String -> Sh st () +shellPutErr = shellPut . ErrorOutput + +-- | Prints regular output with a line terminator +shellPutStrLn :: String -> Sh st () +shellPutStrLn = shellPutStr . (++"\n") + +-- | Prints an informational output string with a line terminator +shellPutInfoLn :: String -> Sh st () +shellPutInfoLn = shellPutInfo . (++"\n") + +-- | Prints and error output string with a line terminator +shellPutErrLn :: String -> Sh st () +shellPutErrLn = shellPutErr . (++"\n") + +-- | Get the current shell state +getShellSt :: Sh st st +getShellSt = Sh (get >>= return . fst) + +-- | Set the shell state +putShellSt :: st -> Sh st () +putShellSt st = Sh (get >>= \ (_,spec) -> put (st,spec)) + +-- | Apply the given funtion to the shell state +modifyShellSt :: (st -> st) -> Sh st () +modifyShellSt f = getShellSt >>= putShellSt . f + +-- | Schedule a shell \"special\" action. Only the last call to +-- this function will affect the shell's behavior! It modifies +-- a bit of state that is overwritten on each call. +shellSpecial :: ShellSpecial st -> Sh st () +shellSpecial spec = Sh (get >>= \ (st,_) -> put (st,Just spec)) + +instance MonadState st (Sh st) where + get = getShellSt + put = putShellSt diff --git a/src/System/Console/Shell/Types.hs b/src/System/Console/Shell/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Shell/Types.hs @@ -0,0 +1,134 @@ +{- + - + - Copyright 2005-2007, Robert Dockins. + - + -} + +module System.Console.Shell.Types where + +import qualified Control.Exception as Ex + +import Control.Monad.Reader +import Control.Monad.State + +import System.Console.Shell.PPrint +import System.Console.Shell.Backend + + +-- | Datatype describing the style of shell commands. This +-- determines how shell input is parsed. +data CommandStyle + = OnlyCommands -- ^ Indicates that all input is to be interpreted as shell commands; no + -- input will be passed to the evaluation function. + | CharPrefixCommands Char -- ^ Indicates that commands are prefixed with a particular character + -- Colon \':\' is the default charcter (a la GHCi). + | SingleCharCommands -- ^ Commands consisit of a single character + + +-- | The type of an evaluation function for a shell. The function +-- takes three arguments: +-- +-- (1) An output function command. Pass this command into 'shellPutStr' +-- and friends rather than using 'putStr'. +-- +-- (2) The input string +-- +-- (3) The current shell state +-- +-- Evaluation functions should return the new shell state and +-- possibly a shell special action to execute. + +data CommandCompleter st + = FilenameCompleter + | UsernameCompleter + | OtherCompleter (st -> String -> IO [String]) + + +-- | The result of parsing a command. +data CommandParseResult st + + = CompleteParse (Sh st ()) + -- ^ A complete parse. A command function is returned. + + | IncompleteParse (Maybe (CommandCompleter st)) + -- ^ An incomplete parse. A word completion function may be returned. + + +-- | The type of a command parser. +type CommandParser st = String -> [CommandParseResult st] + + +-- | The type of a shell command. The shell description is passed in, and the +-- tuple consists of +-- (command name,command parser,command syntax document,help message document) +type ShellCommand st = ShellDescription st -> (String,CommandParser st,Doc,Doc) + + +-- | The type of results from shell commands. They are a modified +-- shell state and possibly a shell \"special\" action to execute. +type CommandResult st = (st,Maybe (ShellSpecial st)) + + +-- | The type of commands which produce output on the shell console. +type OutputCommand = BackendOutput -> IO () + + +-- | The type of shell commands. This monad is a stae monad layerd over @IO@. It is +-- also a member of 'MonadException' which allows safe exception handling. +newtype Sh st a = Sh { unSh :: StateT (CommandResult st) (ReaderT OutputCommand IO) a } + deriving (Monad, MonadIO) + +------------------------------------------------------------------------ +-- The shell description and utility functions + + +-- | A record type which describes the attributes of a shell. +data ShellDescription st + = ShDesc + { shellCommands :: [ShellCommand st] -- ^ Commands for this shell + , commandStyle :: CommandStyle -- ^ The style of shell commands + , evaluateFunc :: String -> Sh st () -- ^ The evaluation function for this shell + + , greetingText :: Maybe String -- ^ Text to print when the shell starts + , wordBreakChars :: [Char] -- ^ The characters upon which the backend will break words + , beforePrompt :: Sh st () -- ^ A shell action to run before each prompt is printed + , prompt :: st -> IO String -- ^ A command to generate the prompt to print + , secondaryPrompt :: Maybe (st -> IO String) -- ^ A command to generate the secondary prompt. The secondary + -- prompt is used for multi-line input. If not set, the + -- regular prompt is used instead. + , exceptionHandler :: Ex.Exception -> + Sh st () -- ^ A function called when an exception occurs + , defaultCompletions :: Maybe (st -> String + -> IO [String]) -- ^ If set, this function provides completions when NOT + -- in the context of a shell command + , historyFile :: Maybe FilePath -- ^ If set, this provides the path to a file to contain a + -- history of entered shell commands + , maxHistoryEntries :: Int -- ^ The maximum number of history entries to maintain + , historyEnabled :: Bool -- ^ If true, the history mechanism of the backend (if any) + -- will be used; false will disable history features. + } + +-- | The type of subshells. The tuple consists of: +-- +-- (1) A function to generate the initial subshell state from the outer shell state +-- +-- (2) A function to generate the outer shell state from the final subshell state +-- +-- (3) A function to generate the shell description from the inital subshell state + +type Subshell st st' = (st -> IO st', st' -> IO st, st' -> IO (ShellDescription st') ) + + +-- | Special commands for the shell framework. +data ShellSpecial st + = ShellExit -- ^ Causes the shell to exit + | ShellHelp (Maybe String) -- ^ Causes the shell to print an informative message. + -- If a command name is specified, only information about + -- that command will be displayed + | ShellNothing -- ^ Instructs the shell to do nothing; redisplay the prompt and continue + | ShellContinueLine String -- ^ Ask the shell to continue accepting input on another line, which should + -- be appended to the given string + | forall st'. ExecSubshell + (Subshell st st') -- ^ Causes the shell to execute a subshell + +