Shellac-0.9.5.1/0000755000175000017500000000000011255747363013466 5ustar rdockinsrdockinsShellac-0.9.5.1/Shellac.cabal0000644000175000017500000000364211255747363016032 0ustar rdockinsrdockinsName: Shellac Cabal-Version: >= 1.2.3 Build-Type: Simple Version: 0.9.5.1 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 Homepage: http://www.cs.princeton.edu/~rdockins/shellac/home/ 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. flag base4 Library Hs-Source-Dirs: src Build-Depends: base < 5, mtl, directory if flag(base4) Build-Depends: base >= 4 CPP-Options: -DBASE4 else Build-Depends: base < 4 if impl(ghc >= 6.8) && impl(ghc < 6.10) Extensions: PatternSignatures if os(windows) CPP-Options: -DBUILD_WINDOWS else Build-Depends: unix Extensions: MultiParamTypeClasses FunctionalDependencies ExistentialQuantification CPP UndecidableInstances GeneralizedNewtypeDeriving FlexibleInstances ScopedTypeVariables 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 Shellac-0.9.5.1/LICENSE0000644000175000017500000000244511255747363014500 0ustar rdockinsrdockinsCopyright 2005-2008, Robert Dockins. PPrint library: Copyright 2000, Dan Leijen. 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. Shellac-0.9.5.1/src/0000755000175000017500000000000011255747363014255 5ustar rdockinsrdockinsShellac-0.9.5.1/src/System/0000755000175000017500000000000011255747363015541 5ustar rdockinsrdockinsShellac-0.9.5.1/src/System/Console/0000755000175000017500000000000011255747363017143 5ustar rdockinsrdockinsShellac-0.9.5.1/src/System/Console/Shell/0000755000175000017500000000000011255747363020212 5ustar rdockinsrdockinsShellac-0.9.5.1/src/System/Console/Shell/PPrint.hs0000644000175000017500000003100411255747363021760 0ustar rdockinsrdockins----------------------------------------------------------- -- 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 System.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 Shellac-0.9.5.1/src/System/Console/Shell/RunShell.hs0000644000175000017500000003272511255747363022313 0ustar rdockinsrdockins{- - - Copyright 2005-2008, Robert Dockins. - -} module System.Console.Shell.RunShell ( runShell , defaultExceptionHandler , simpleSubshell ) where import Data.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::ShellacException) -> (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::ShellacException) -> (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 -> (outputString backend bst) (RegularOutput "\n") >> 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) #ifdef BASE4 defaultExceptionHandler :: ShellacException -> Sh st () defaultExceptionHandler ex = case Ex.fromException ex of Just Ex.ThreadKilled -> return () _ -> shellPutErrLn $ concat ["The following exception occurred:\n ",show ex] #else defaultExceptionHandler :: ShellacException -> Sh st () defaultExceptionHandler (Ex.AsyncException Ex.ThreadKilled) = return () defaultExceptionHandler ex = do shellPutErrLn $ concat ["The following exception occurred:\n ",show ex] #endif ---------------------------------------------------------------------------- -- | 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' Shellac-0.9.5.1/src/System/Console/Shell/Backend.hs0000644000175000017500000001766211255747363022111 0ustar rdockinsrdockins{- - - 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!). -- -- This module is intended for use by backend implementers. It is not intended to -- be used by regular clients of the library. The Shellac package provides a -- basic backend ("System.Console.Shell.Backend.Basic"). More advanced backends -- are available in separate packages. 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 common -- 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 and 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 initialization -- 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) -- ^ Retrieve a single character from the user without waiting for carriage return. , getInput :: bst -> String -> IO (Maybe String) -- ^ Print the prompt and retrieve 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 canceled -- 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 configurable -- word break characters, then '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 () } Shellac-0.9.5.1/src/System/Console/Shell/Regex.hs0000644000175000017500000001756311255747363021634 0ustar rdockinsrdockins{- - - 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 "" ) ) Shellac-0.9.5.1/src/System/Console/Shell/ConsoleHandler.hs0000644000175000017500000000166011255747363023451 0ustar rdockinsrdockins{- - - Copyright 2005-2007, Robert Dockins. - -} module System.Console.Shell.ConsoleHandler ( withControlCHandler ) where import qualified Control.Exception as Ex #ifdef BUILD_WINDOWS -- Windows build, use the GHC console -- handler module 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) #else -- not Windows, assume POSIX 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) #endif Shellac-0.9.5.1/src/System/Console/Shell/ShellMonad.hs0000644000175000017500000000667511255747363022612 0ustar rdockinsrdockins{- - - 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 -- * Extracting and using the shell context , ShellContext , extractContext, runWithContext, updateCommandResult ) 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 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 -- | The total context held by the shell, with @'CommandResult' st@ -- being mutable and 'OutputCommand' immutable type ShellContext st = (CommandResult st, OutputCommand) -- | Extract the current shell context for future use, see 'runWithContext' extractContext :: Sh st (ShellContext st) extractContext = (Sh . StateT) $ \s -> do imC <- ask return ((s, imC), s) -- | Run a shell with the supplied context, useful if you need to -- invoke a shell within a new IO context, for example when using -- 'System.Timeout.timeout' runWithContext :: ShellContext st -> Sh st a -> IO (a, CommandResult st) runWithContext (mC, imC) = (flip runReaderT) imC . (flip runStateT) mC . unSh -- | Update the mutable context of this shell updateCommandResult :: CommandResult st -> Sh st () updateCommandResult s = (Sh . StateT) $ \_ -> return (() , s) Shellac-0.9.5.1/src/System/Console/Shell/Types.hs0000644000175000017500000001331411255747363021654 0ustar rdockinsrdockins{- - - Copyright 2005-2008, 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; -- input is only passed to the evaluation fuction if it cannot be -- parsed as a command. | CharPrefixCommands Char -- ^ Indicates that commands are prefixed with a particular character. -- Colon \':\' is the default character (a la GHCi). | SingleCharCommands -- ^ Commands consist of a single character. data CommandCompleter st = FilenameCompleter | UsernameCompleter | OtherCompleter (st -> String -> IO [String]) #ifdef BASE4 -- | Compatability layer. For base-3, this is -- \'Exception\'. For base-4, this is -- \'SomeException\'. type ShellacException = Ex.SomeException #else type ShellacException = Ex.Exception #endif -- | 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 state monad layered over @IO@. -- The type parameter @st@ allows the monad to carry around a package of -- user-defined state. newtype Sh st a = Sh { unSh :: StateT (CommandResult st) (ReaderT OutputCommand IO) a } deriving (Monad, MonadIO, MonadFix, Functor) ------------------------------------------------------------------------ -- 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 :: ShellacException -> Sh st () -- ^ A set of handlers to call 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 initial 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 Shellac-0.9.5.1/src/System/Console/Shell/Commands.hs0000644000175000017500000002372711255747363022322 0ustar rdockinsrdockins{- - - 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 ) :: (Completable compl -> r) -> CommandParser st commandSyntax (f:: (Completable compl -> r)) = 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)) Shellac-0.9.5.1/src/System/Console/Shell/Backend/0000755000175000017500000000000011255747363021541 5ustar rdockinsrdockinsShellac-0.9.5.1/src/System/Console/Shell/Backend/Basic.hs0000644000175000017500000000466411255747363023130 0ustar rdockinsrdockins{- - - Copyright 2005-2007, Robert Dockins. - -} -- | This module implements a simple Shellac backend that uses only -- the primitives 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 Shellac-0.9.5.1/src/System/Console/Shell.hs0000644000175000017500000000515611255747363020555 0ustar rdockinsrdockins{- - - 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 pluggable 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') -- -- -- Shell commands and the evaluation function are written in a custom -- monad. See "System.Console.Shell.ShellMonad" for details on using this monad. 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 -- * Auxiliary Types , CommandStyle (..) , ShellSpecial (..) , OutputCommand , CommandResult , ShellacException ) 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 commands and -- an evaluation function. mkShellDescription :: [ShellCommand st] -> (String -> Sh st ()) -> ShellDescription st mkShellDescription cmds func = initialShellDescription { shellCommands = cmds , evaluateFunc = func } Shellac-0.9.5.1/Setup.hs0000644000175000017500000000011011255747363015112 0ustar rdockinsrdockins#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain