packages feed

Shellac (empty) → 0.9

raw patch · 14 files changed

+2064/−0 lines, 14 filesdep +basedep +haskell98dep +mtlbuild-type:Customsetup-changed

Dependencies added: base, haskell98, mtl

Files

+ LICENSE view
@@ -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.
+ README view
@@ -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/<username>+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 <robdockins AT fastmail.fm>
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ Shellac.cabal view
@@ -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
+ src/System/Console/Shell.hs view
@@ -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+      }
+ src/System/Console/Shell/Backend.hs view
@@ -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 ()+     }
+ src/System/Console/Shell/Backend/Basic.hs view
@@ -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
+ src/System/Console/Shell/Commands.hs view
@@ -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 "<file>" : commandSyntax (f undefined)++instance CommandFunction r st+      => CommandFunction (Username -> r) st where+  parseCommand wbc = doParseCommand+                        (Just UsernameCompleter)+                        (wordRegex wbc)+                        Username+                        wbc+  commandSyntax f = text "<username>" : 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))
+ src/System/Console/Shell/ConsoleHandler.hs view
@@ -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
+ src/System/Console/Shell/PPrint.hs view
@@ -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
+ src/System/Console/Shell/Regex.hs view
@@ -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 "<integer>" $+    Concat (\sign int -> sign int) signRegex (External readDec "")++floatRegex :: RealFloat a => Regex Char a+floatRegex = Label "<float>" $+    Concat (\sign float -> sign float) signRegex (External readFloat "")++boolRegex :: Regex Char Bool+boolRegex = Label "<boolean>" $+   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 "<word>" $+     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 ""+          )+        )
+ src/System/Console/Shell/RunShell.hs view
@@ -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'
+ src/System/Console/Shell/ShellMonad.hs view
@@ -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
+ src/System/Console/Shell/Types.hs view
@@ -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++