Shellac 0.9.1 → 0.9.5

raw patch · 6 files changed

+125/−100 lines, 6 filesdep −haskell98dep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: haskell98

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Shellac.cabal +22/−17
• src/System/Console/Shell.hs +4/−3
• src/System/Console/Shell/PPrint.hs +67/−67
• src/System/Console/Shell/RunShell.hs +19/−9
• src/System/Console/Shell/Types.hs +12/−3

@@ -1,4 +1,4 @@-Copyright 2005-2006, Robert Dockins.+Copyright 2005-2008, Robert Dockins. PPrint library: Copyright 2000, Dan Leijen.  All Rights Reserved.

@@ -1,7 +1,7 @@ Name:           Shellac Cabal-Version:  >= 1.2-Build-Type:	Simple-Version:        0.9.1+Build-Type:     Simple+Version:        0.9.5 License:        BSD3 License-File:   LICENSE Author:         Robert Dockins@@ -11,7 +11,7 @@ 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.  +  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@@ -21,11 +21,26 @@   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, haskell98, mtl+  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@@ -35,16 +50,6 @@      GeneralizedNewtypeDeriving      FlexibleInstances      ScopedTypeVariables--  if os(windows)-     GHC-Options: -DBUILD_WINDOWS-  else-     if impl( ghc >= 6.8 )-        Build-Depends: unix--  if impl( ghc >= 6.8 )-     Build-Depends: directory-     GHC-Options: -XPatternSignatures    Exposed-modules:      System.Console.Shell

@@ -60,6 +60,7 @@ , ShellSpecial (..) , OutputCommand , CommandResult+, ShellacException ) where  import System.Console.Shell.Types@@ -68,7 +69,7 @@ import System.Console.Shell.RunShell import System.Console.Shell.Backend --- | A basic shell description with sane initial values+-- | A basic shell description with sane initial values. initialShellDescription :: ShellDescription st initialShellDescription =    ShDesc@@ -88,8 +89,8 @@        }  --- | Creates a simple shell description from a list of shell commmands and---   an evalation function.+-- | Creates a simple shell description from a list of shell commands and+--   an evaluation function. mkShellDescription :: [ShellCommand st]                    -> (String -> Sh st ())                    -> ShellDescription st

@@ -3,51 +3,51 @@ -- -- Pretty print module based on Philip Wadlers "prettier printer" --      "A prettier printer"---      Draft paper, April 1997, revised March 1998. +--      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 +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        -        +        , empty, char, text, line, linebreak, nest, group+        , column, nesting, width+         , SimpleDoc(..)         , renderPretty, renderCompact-        , displayS, displayIO                +        , displayS, displayIO         ) where -import IO      (Handle,hPutStr,hPutChar,stdout)+import System.IO      (Handle,hPutStr,hPutChar,stdout)  infixr 5 </>,<//>,<$>,<$$> infixr 6 <>,<+>@@ -65,7 +65,7 @@     = case ds of         []  -> left <> right         [d] -> left <> d <> right-        _   -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right) +        _   -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right)   -----------------------------------------------------------@@ -75,19 +75,19 @@ 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 (<$>) +vsep            = fold (<$>)  cat             = group . vcat fillCat         = fold (<//>) hcat            = fold (<>)-vcat            = fold (<$$>) +vcat            = fold (<$$>)  fold f []       = empty fold f ds       = foldr1 f ds@@ -95,7 +95,7 @@ x <> y          = x `beside` y x <+> y         = x <> space <> y x </> y         = x <> softline <> y-x <//> y        = x <> softbreak <> y   +x <//> y        = x <> softbreak <> y x <$> y         = x <> line <> y x <$$> y        = x <> linebreak <> y @@ -139,11 +139,11 @@ 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 :: Int -> Doc int i           = text (show i)  integer :: Integer -> Doc@@ -157,35 +157,35 @@  rational :: Rational -> Doc rational r      = text (show r)-                  -                                                     ++ ----------------------------------------------------------- -- overloading "pretty" ----------------------------------------------------------- class Pretty a where-  pretty        :: a -> Doc +  pretty        :: a -> Doc   prettyList    :: [a] -> Doc   prettyList    = list . map pretty  instance Pretty a => Pretty [a] where   pretty        = prettyList-  + instance Pretty Doc where-  pretty        = id  -  +  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 @@ -194,10 +194,10 @@  instance Pretty Double where   pretty d      = double d-   + --instance Pretty Rational where---  pretty r      = rational r  +--  pretty r      = rational r  instance (Pretty a,Pretty b) => Pretty (a,b) where   pretty (x,y)  = tupled [pretty x, pretty y]@@ -208,23 +208,23 @@ instance Pretty a => Pretty (Maybe a) where   pretty Nothing        = empty   pretty (Just x)       = pretty x-    + -------------------------------------------------------------- semi primitive: fill and fillBreak +-- semi primitive: fill and fillBreak ----------------------------------------------------------- fillBreak f x   = width x (\w ->-                  if (w > f) then nest f linebreak +                  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)))        -         +width d f       = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))++ ----------------------------------------------------------- -- semi primitive: Alignment and indentation -----------------------------------------------------------@@ -243,19 +243,19 @@ 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 +                | 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@@ -270,7 +270,7 @@ beside x y      = Cat x y nest i x        = Nest i x column f        = Column f-nesting f       = Nesting f     +nesting f       = Nesting f group x         = Union (flatten x) x  flatten :: Doc -> Doc@@ -281,9 +281,9 @@ flatten (Column f)      = Column (flatten . f) flatten (Nesting f)     = Nesting (flatten . f) flatten other           = other                     --Empty,Char,Text-  -   ++ ----------------------------------------------------------- -- Renderers -----------------------------------------------------------@@ -297,43 +297,43 @@             | Cons !Int Doc Docs  renderPretty :: Float -> Int -> Doc -> SimpleDoc-renderPretty rfrac w x      -    = best 0 0 (Cons 0 x Nil)                +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  +      --         k = current column       --        (ie. (k >= n) && (k - n == count of inserted characters)       best n k Nil      = SEmpty-      best n k (Cons i d ds)  +      best n k (Cons i d ds)         = case d of-            Empty       -> best n k ds                +            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))                +            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))                +            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)                            +            Nesting f   -> best n k (Cons i (f i) ds) -      --nicest :: r = ribbon width, w = page width, +      --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.                                      +      --          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 (SChar c x)              = fits (w - 1) x fits w (SText l s x)            = fits (w - l) x fits w (SLine i x)              = True @@ -343,7 +343,7 @@ --  fast and fewer characters output, good for machines ----------------------------------------------------------- renderCompact :: Doc -> SimpleDoc-renderCompact x   +renderCompact x     = scan 0 [x]     where       scan k []     = SEmpty@@ -351,7 +351,7 @@                         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)    +                        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)@@ -374,7 +374,7 @@     = display simpleDoc     where       display SEmpty        = return ()-      display (SChar c x)   = do{ hPutChar handle c; display x}  +      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} @@ -396,7 +396,7 @@ ----------------------------------------------------------- -- insert spaces -- "indentation" used to insert tabs but tabs seem to cause--- more trouble than they solve :-) +-- more trouble than they solve :-) ----------------------------------------------------------- spaces n        | n <= 0    = ""                 | otherwise = replicate n ' '

@@ -1,6 +1,6 @@ {-  -- -  Copyright 2005-2007, Robert Dockins.+ -  Copyright 2005-2008, Robert Dockins.  -  -} @@ -10,7 +10,7 @@ , simpleSubshell ) where -import Maybe                       ( isJust )+import Data.Maybe                  ( isJust ) import Data.Char                   ( isSpace ) import Data.List                   ( isPrefixOf, find ) import Data.IORef                  ( IORef, newIORef, readIORef, writeIORef )@@ -46,7 +46,7 @@  ------------------------------------------------------------------- -- Main entry point for the shell.  Sets up all the internal state--- needed to run shell commands and evaluation in a separate thread and +-- needed to run shell commands and evaluation in a separate thread and -- initializes the backend.  @@ -182,7 +182,7 @@         fexists <- doesFileExist path         when fexists $            Ex.handle-             (\ex -> (outputString backend bst) (ErrorOutput $+             (\(ex::ShellacException) -> (outputString backend bst) (ErrorOutput $                  concat ["could not read history file '",path,"'\n   ",show ex]))              (readHistory backend bst path) @@ -195,8 +195,8 @@   case historyFile desc of     Nothing   -> return ()     Just path ->-       Ex.handle -          (\ex -> (outputString backend bst) (ErrorOutput $+       Ex.handle+          (\(ex::ShellacException) -> (outputString backend bst) (ErrorOutput $                  concat ["could not write history file '",path,"'\n    ",show ex]))           (writeHistory backend bst path) @@ -236,7 +236,7 @@         inp <- doGetInput ci pr          case inp of-           Nothing   -> return st+           Nothing   -> (outputString backend bst) (RegularOutput "\n") >> return st            Just inp' -> if not (isJust ci)                            then handleInput   inp' st                            else evaluateInput inp' st@@ -295,7 +295,6 @@    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)@@ -322,11 +321,22 @@ --   ignores the thread killed exception, because that is used to --   implement execution canceling) -defaultExceptionHandler :: Ex.Exception -> Sh st ()+#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

@@ -1,6 +1,6 @@ {-  -- -  Copyright 2005-2007, Robert Dockins.+ -  Copyright 2005-2008, Robert Dockins.  -  -} @@ -31,6 +31,15 @@   | 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 @@ -84,8 +93,8 @@    , 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+   , 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