diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION = 3.4.1 +VERSION = 3.4.2 default :: lib diff --git a/hsshellscript.cabal b/hsshellscript.cabal --- a/hsshellscript.cabal +++ b/hsshellscript.cabal @@ -1,5 +1,5 @@ Name: hsshellscript -Version: 3.4.1 +Version: 3.4.2 Synopsis: Haskell for Unix shell scripting tasks Description: A Haskell-library for tasks which are usually done in shell scripts. This includes parsing command line diff --git a/src/HsShellScript.hs b/src/HsShellScript.hs --- a/src/HsShellScript.hs +++ b/src/HsShellScript.hs @@ -69,6 +69,8 @@ -- * Output to the standard stream, colorful logging and error reporting outm, outm_, logm, logm_, errm, errm_, isatty, + terminal_width, terminal_width_ioe, + -- * Miscellaneous zeros, chomp, lazy_contents, contents, glob, glob_quote, diff --git a/src/HsShellScript/Args.chs b/src/HsShellScript/Args.chs --- a/src/HsShellScript/Args.chs +++ b/src/HsShellScript/Args.chs @@ -12,25 +12,36 @@ -- of HsShellScript.Args looks something like this: -- -- >import HsShellScript +-- >import Control.Exception +-- >import Control.Monad +-- >import System.Environment +-- >import System.Exit +-- >import System.IO -- > --- >main = --- > do let a_onevalue = argdesc [ desc_at_most_once, ... ] --- > a_values = argdesc [ desc_direct, ... ] --- > a_switch = argdesc [ ... ] --- > ... --- > header = "mclapep - My Command Line Argument Parser Example Program, version 1.0.0" +-- >header = "mclapep - My Command Line Argument Parser Example Program, version 1.0.0\n\n" +-- >descs = [d_onevalue, d_values, d_switch {-...-}] -- > --- > args <- getargs header [a_onevalue, a_values, a_switch, ...] +-- >d_onevalue = argdesc [ desc_short 'o', desc_at_most_once, desc_argname "a", desc_value_required {-...-}] +-- >d_values = argdesc [ desc_direct, desc_any_times {-...-} ] +-- >d_switch = argdesc [ desc_at_most_once, desc_short 's', desc_argname "sw", desc_value_required {-...-} ] +-- >-- ... -- > --- > val <- optarg_req a_onevalue args -- val :: Maybe String --- > vals <- args_req a_values args -- vals :: [String] --- > doit <- arg_switch a_switch args -- doit :: Bool --- > ... --- > `catch` --- > (\argerror -> do --- > hPutStrLn stderr $ (argerror_message argerror) ++ "\n\n" ++ (argerror_usageinfo argerror) --- > exitFailure --- > ) +-- >args = unsafe_getargs header descs +-- >val = optarg_req args d_onevalue -- val :: Maybe String +-- >vals = args_req args d_values -- vals :: [String] +-- >doit = arg_switch args d_switch -- doit :: Bool +-- >-- ... +-- > +-- >main = mainwrapper $ do +-- > args0 <- getArgs +-- > when (null args0) $ do +-- > -- No command line arguments - print usage information +-- > print_usage_info stdout header descs +-- > exitWith ExitSuccess +-- > -- trigger argument errors +-- > seq args (return ()) +-- > +-- > -- Do something with the arguments -- -- Errors in the argument descriptions are regarded as bugs, and handled -- by aborting the program with a message which is meaningful to the @@ -43,7 +54,7 @@ -- value, or thrown as an exception. module HsShellScript.Args ( -- ** Argument Properties - ArgumentProperty + ArgumentProperty (..) , ArgumentDescription (..) , ArgumentValueSpec (..) , Argtester @@ -99,15 +110,15 @@ , print_usage_info , argname , argname_a + , argname_short + , argname_long , wrap - , terminal_width - , terminal_width_ioe ) where -- We use a fixed copy of GHC's GetOpt implementation. This is to work around a bug. -- import System.Console.GetOpt import HsShellScript.GetOpt -import {-# SOURCE #-} HsShellScript.ProcErr +import {-# SOURCE #-} HsShellScript.ProcErr (terminal_width, terminal_width_ioe) import Foreign.C import System.Environment @@ -123,7 +134,8 @@ import Data.Char import Debug.Trace import Data.Typeable - +import Control.Concurrent.MVar +import GHC.IO.Handle.Internals -- withHandle', do_operation @@ -149,20 +161,20 @@ -- | Description of one command line argument. These are generated by -- @argdesc@ from a list of argument properties, and subsequently used by one of the --- @getargs@... functions. This type is abstract. +-- @getargs@... functions. data ArgumentDescription = ArgumentDescription { argdesc_short_args :: [Char], -- ^ Short option names argdesc_long_args :: [String], -- ^ Long option names argdesc_argarg :: ArgumentValueSpec, -- ^ What about a possible value of the argument? argdesc_times :: Maybe (Int,Int), -- ^ Minimum and maximum of number of occurences allowed argdesc_argargname :: Maybe String, -- ^ Name for argument's value, for message generation - argdesc_argarg_description :: Maybe String, -- ^ Descrition of the argument, for message generation + argdesc_description :: Maybe String, -- ^ Descrition of the argument, for message generation argdesc_argarg_tester :: Maybe Argtester -- ^ Argument value tester } -- excluding tester ad_tup ad = - (argdesc_short_args ad, argdesc_long_args ad, argdesc_argarg ad, argdesc_times ad, argdesc_argargname ad, argdesc_argarg_description ad) + (argdesc_short_args ad, argdesc_long_args ad, argdesc_argarg ad, argdesc_times ad, argdesc_argargname ad, argdesc_description ad) instance Eq ArgumentDescription where d == e = ad_tup d == ad_tup e @@ -205,7 +217,7 @@ argdesc_argarg = ArgumentValue_none, argdesc_times = Nothing, -- default = (0,1) argdesc_argargname = Nothing, - argdesc_argarg_description = Nothing, + argdesc_description = Nothing, argdesc_argarg_tester = Nothing } @@ -240,11 +252,11 @@ -- -- The usage information is generated by the deprecated function usage_info. Better ignore this, and use the newer @make_usage_info@ or @print_usage_info@. -- --- See 'usage_info', 'make_usage_info', 'print_usage_info'. +-- See 'make_usage_info', 'print_usage_info', 'usage_info'. data ArgError = ArgError { -- | Error message argerror_message :: String, - -- | Usage information, as generated by the now deprecated function usage_info. + -- | Deprecated. Usage information, as generated by the now deprecated function 'usage_info'. argerror_usageinfo :: String } deriving (Typeable) @@ -419,16 +431,15 @@ ) -- | --- Specify a short description of what the argument does. Used for the --- generation of the usage message. This is to fit on one line, after the --- short and long argument names. It should be 40 characters long or so. +-- Specify a description of what the argument does. Used for usage message +-- generation. This can be arbitratily long, long lines are wrapped. desc_description :: String -- ^ Short description of the argument. - -> ArgumentProperty -- ^ The corresponding argument property. + -> ArgumentProperty -- ^ The corresponding argument property. desc_description expl = ArgumentProperty (\desc -> - if argdesc_argarg_description desc == Nothing - then desc { argdesc_argarg_description = Just expl } - else abort "Bug in HsShellScript argument description: Multiple explanations specified" desc + if argdesc_description desc == Nothing + then desc { argdesc_description = Just expl } + else abort "Bug in HsShellScript argument description: Multiple argument descriptions specified" desc ) -- | Specify a tester for this argument. The tester is a function which tests the argument value for format errors. Typically, it tests whether the @@ -521,6 +532,78 @@ else if (argdesc_short_args desc, argdesc_long_args desc) == ([],[]) then "yet unnamed argument" else "argument " ++ concat (intersperse "/" ( map (\s -> "-"++[s]) (argdesc_short_args desc) ++ map ("--" ++) (argdesc_long_args desc) )) + + +{- | Create a string, which lists the short forms of one command line argument. If +it has an subargument, it's name is listed as well. For arguments without short +form, the result is the empty string. + +For the illegal command line argument, with neither short nor long forms, and +not being the direct argument either, the result is @"yet unnamed argument"@. +Such argument descriptions are incomplete, and will be rejected by @getargs@ and +@unsafe_getargs@. + +This is meant for refering to an argument, such as in error messages or usage +information. + +Examples: + +>argname_short (argdesc [ desc_short 'a' +> , desc_short 'b' +> , desc_value_required +> , desc_argname "Name" +> ]) +> == "-a/-b Name" + +See 'argdesc', 'desc_direct'. 'argname_long'. +-} +argname_short :: ArgumentDescription -- ^ Argument description, as returned by @argdesc@ + -> String -- ^ Printable name for the argument +argname_short desc = + if (argdesc_short_args desc, argdesc_long_args desc) == ([],[""]) then "" + else if (argdesc_short_args desc, argdesc_long_args desc) == ([],[]) then "yet unnamed argument" + else concat (intersperse "/" (map (\s -> "-" ++ [s]) (argdesc_short_args desc))) + ++ case argdesc_argargname desc of + Just name -> " " ++ name + Nothing -> "" + + +{- | Create a string, which lists the long forms of one command line argument. If +it has an subargument, it's name is listed as well. For arguments without long +form, the result is the empty string. + +For the illegal command line argument, with neither short nor long forms, and +not being the direct argument either, the result is @"yet unnamed argument"@. +Such argument descriptions are incomplete, and will be rejected by @getargs@ and +@unsafe_getargs@. + +This is meant for refering to an argument, such as in error messages or usage +information. + +Examples: + +>argname_long (argdesc [ desc_long "foo" +> , desc_long "bar" +> , desc_value_required +> , desc_argname "Name" +> ]) +> == "--foo/--bar Name" + +See 'argdesc', 'desc_direct'. 'argname_long'. +-} + +argname_long :: ArgumentDescription -- ^ Argument description, as returned by @argdesc@ + -> String -- ^ Printable name for the argument +argname_long desc = + if (argdesc_short_args desc, argdesc_long_args desc) == ([],[""]) then "" + else if (argdesc_short_args desc, argdesc_long_args desc) == ([],[]) then "yet unnamed argument" + else concat (intersperse "/" (map (\s -> "--" ++ s) (argdesc_long_args desc))) + ++ case argdesc_argargname desc of + Just name -> " " ++ name + Nothing -> "" + + + up1 "" = "" up1 (x:xs) = toUpper x : xs @@ -536,7 +619,7 @@ else () ) $ desc { argdesc_times = Just (fromMaybe times_default (argdesc_times desc)) - , argdesc_argarg_description = Just (fromMaybe "" (argdesc_argarg_description desc)) + , argdesc_description = Just (fromMaybe "" (argdesc_description desc)) } ) @@ -588,7 +671,7 @@ ArgumentValue_optional -> OptArg (\arg -> (desc, arg)) (fromJust (argdesc_argargname desc)) ) - (fromJust (argdesc_argarg_description desc)) + (fromJust (argdesc_description desc)) -- Postprocessing after successful call to getOpt getopt_post :: [ArgOcc] -> [String] -> Either ArgError Arguments @@ -1000,11 +1083,11 @@ -- -- Descriptions can be several lines long. Lines get wrapped at column 80. -- --- See 'make_usage_info', 'print_usage_info', 'wrap', 'terminal_width', 'terminal_width_ioe'. +-- See 'make_usage_info', 'print_usage_info', 'wrap'. usage_info :: Arguments -> String usage_info (Arguments (l, header)) = unlines (wrap 80 header) ++ - concat (intersperse "\n" (make_usage_info (map fst l) 0 20 80)) + concat (intersperse "\n" (make_usage_info (map fst l) 0 10 30 80)) @@ -1063,6 +1146,12 @@ +make_usage_info1 :: [ArgumentDescription] -> String +make_usage_info1 argdescs = + concat (intersperse "\n" (make_usage_info argdescs 0 10 30 80)) + + + -- | -- Generate pretty-printed information about the command line arguments. This -- function gives you much control on how the usage information is generated. @@ -1075,86 +1164,209 @@ -- The direct argument, in case there is one, is omitted. You should detail the -- direct command line arguments separatly, such as in some header. -- +-- The specified maximum breadths must fit in the specified width, or an error +-- is raised. This happens, when @colsleft + colsshort + 2 + colslong + 2 + 2 > +-- width@. +-- -- See 'print_usage_info', 'getargs', 'usage_info', 'ArgumentDescription', --- 'desc_description', 'argdesc', 'terminal_width', 'terminal_width_ioe". +-- 'desc_description', 'argdesc', 'terminal_width', 'terminal_width_ioe'. make_usage_info :: [ArgumentDescription] -- ^ List of argument descriptions, as created by a @argdesc@ -> Int -- ^ The output is indented this many columns. Probably zero. - -> Int -- ^ How much columns to reserve for the argument name and name - -- of the value of the argument (if any). Somthing like 10 or 15. + -> Int -- ^ Maximum width of the column of the short form of each argument. When this many aren't + -- needed, less are used. + -> Int -- ^ Maximum width of the column of the long form of each argument. When this many aren't + -- needed, less are used. -> Int -- ^ Wrap everything at this column. Should probably be the terminal width. - -> [String] -- ^ pretty printed usage information -make_usage_info argdescs colsleft colsarg width = + -> [String] -- ^ Pretty printed usage information, in paragraphs, which contain one or several lines. +make_usage_info descs colsleft colsshort colslong width = - if width < colsleft + colsarg + 2 - then error ("Bug in make_usage_info: geometry doesn't match: " - ++ show width ++ " < " ++ show colsleft ++ " + " ++ show colsarg ++ " + 2") - else + if colsleft + colsshort + 2 + colslong + 2 + 2 > width + then error $ "make_usage_info: colsleft, colsshort, and colslong arguments \ + \are too large for the specified width argument.\n\ + \colsleft = " ++ show colsleft ++ " \n\ + \colsshort = " ++ show colsshort ++ " \n\ + \colslong = " ++ show colslong ++ " \n\ + \width = " ++ show width + else + map unlines (verbinden (zll' (filter (\d -> not (is_direct d)) + descs) + )) + + where + -- Die Argumentbeschreibung, auf die richtige Breite umgebrochen + beschr :: ArgumentDescription -> [String] + beschr desc = wrap (width - colsleft - gesamtbr_kurz - 2 - gesamtbr_lang - 2) + (fromMaybe "" (argdesc_description desc)) + + -- Eine ArgumentDescription rendern. Die fertigen Zeilen sind alle gleich viele (mit "" aufgefüllt). + auff1 :: ArgumentDescription + -> ([String], [String], [String]) + auff1 desc = auff (kurzname desc) + (langname desc) + (beschr desc) + + -- Wir haben für eine Argumentbeschreibung die Listen von Zeilen, aus denen der kurze, und lange Argumentname besteht, sowie die Zeilen, aus + -- denen die Argumentbeschreibung besteht. + zus :: ([String], [String], [String]) -> [(String, String, String)] + zus (as, bs, cs) = zip3 as bs cs + + -- Die für die Kurzform einses Arguments benötigte Zahl von Spalten + kurzbr :: ArgumentDescription -> Int + kurzbr desc = + foldr max 0 (map length (kurzname desc)) + + -- Die für die Langform einses Arguments benötigte Zahl von Spalten + langbr :: ArgumentDescription -> Int + langbr desc = + foldr max 0 (map length (langname desc)) + + -- Breite der Kurzform, über alle Argumente hinweg + gesamtbr_kurz = + foldr max 0 (map (\desc -> kurzbr desc) descs) + + -- Breite der Langform, über alle Argumente hinweg + gesamtbr_lang = + foldr max 0 (map (\desc -> langbr desc) descs) + + -- Breite der Beschreibungen + breite_descr :: Int + breite_descr = width - colsleft - gesamtbr_kurz - 2 - gesamtbr_lang - 2 - map (\desc -> make_usage_info1 colsleft colsarg width desc) - (filter (\desc -> not (is_direct desc)) argdescs) + -- Für jedes Kommandozeilenargument die Liste der Zeilen + zll :: [ArgumentDescription] + -> [[(String, String, String)]] + zll descs = + map (zus . auff1) descs + + -- Für jedes Kommandozeilenargument die Liste der Zeilen, aufgefüllt auf einheitliche Breite + zll' :: [ArgumentDescription] + -> [[(String, String, String)]] + zll' [] = + [] + zll' descs = + map (\l -> map (\(a,b,c) -> (fuell gesamtbr_kurz a, + fuell gesamtbr_lang b, + c)) + l) + (zll descs) + + -- Die Tripel + verbinden :: [[(String, String, String)]] + -> [[String]] + verbinden l = + map (\l' -> map (\(a,b,c) -> take colsleft (repeat ' ') + ++ a ++ " " ++ b ++ " " ++ c) l') + l + + -- Die Kurzform des angegebenen Arguments. In Zeilen heruntergebrochen, + -- wenn die Breite colsshort überschritten wird. + kurzname :: ArgumentDescription -> [String] + kurzname desc = + wrap colsshort (argname_short desc) + + -- Die Langform des angegebenen Arguments. In Zeilen heruntergebrochen, + -- wenn die Breite colslong überschritten wird + langname :: ArgumentDescription -> [String] + langname desc = + wrap colslong (argname_long desc) + + -- Den gegebenen String um so viele Leerzeichen ergänzen, daß daraus ein String der gegebenen Länge wird. Ist er dafür zu lang, denn den + -- unveränderten String zurückgeben. + fuell :: Int -> String -> String + fuell br txt = + txt ++ take (br - length txt) (repeat ' ') + - where - -- Make the usage info for one argument description - make_usage_info1 :: Int -> Int -> Int -> ArgumentDescription -> String - make_usage_info1 colsleft colsarg width desc = - unlines $ einruecken1 colsleft $ + -- Complete three lists of Strings. All three strings are made to be made up + -- of the same number of entries. Missing entries at the end are filled up with + -- empty strings. + auff :: [String] -> [String] -> [String] -> ([String], [String], [String]) + auff a b c = + (reverse x, reverse y, reverse z) + + where + (x,y,z) = auff' a b c [] [] [] + + auff' :: [String] -> [String] -> [String] + -> [String] -> [String] -> [String] + -> ([String], [String], [String]) + + auff' [] [] [] a1 b1 c1 = + (a1, b1, c1) + + auff' a b c a1 b1 c1 = + auff' (if null a then [] else tail a) + (if null b then [] else tail b) + (if null c then [] else tail c) + ((if null a then "" else head a) : a1) + ((if null b then "" else head b) : b1) + ((if null c then "" else head c) : c1) + - case argdesc_argarg_description desc of - -- Das Argument hat eine Beschreibung - Just txt -> - if length (argname1 desc) >= colsarg - then - -- Der Parameter paßt nicht in die vorgegebene Breite. - -- Füge eine extra Zeile hinzu. - argname1 desc - : einruecken1 colsarg (wrap breite txt) - else - -- Der Parameter paßt in die vorgegebene Breite. Fange - -- in derselben Zeile mit der Beschreibung an. - -- Füge eine extra Zeile hinzu. - let (bzl1:bzlrest) = einruecken colsarg (wrap breite txt) - in - (auff colsarg (argname1 desc) ++ bzl1) - : bzlrest - - -- Das Argument hat keine Beschreibung. Gebe nur den Argumentname aus. - Nothing -> - [ argname1 desc ] - - -- Argumentname zusammen mit Argumentwert-Name - argname1 desc = - argname desc - ++ case argdesc_argargname desc of - Just name -> " " ++ name - Nothing -> "" - - breite = width - colsleft - colsarg - - lz n = take n (repeat ' ') - - auff :: Int -> String -> String - auff n str = if length str <= n then str ++ lz (n - length str) - else str - - - -- Einrücken, ab zweiter Zeile. Erste Zeile NICHT einrücken. - einruecken :: Int -> [String] -> [String] - einruecken _ [] = [""] - einruecken spalten (zl:zll) = - zl : map (\z -> lz spalten ++ z) zll +-- | +-- Print the usage information (about the command line arguments), for the +-- specified header and arguments to the specified handle. When the handle is +-- connected to a terminal, the terminal\'s width (in columns) is used to format +-- the output, such that it fits the terminal. Both the header and the argument +-- descriptions are adapted to the width of the terminal (by using @wrap@). +-- +-- When the handle does not connected to a terminal, 80 columns are used. This +-- may happen to @stdout@ or @stderr@, for instance, when the program is in a +-- pipe, or the output has been redirected to a file. +-- +-- When the terminal is too narrow for useful output, then instead of the usage +-- information, a short message (@"Terminal too narrow"@) is printed. This +-- applies to terminals with a width of less than 12. +-- +-- You should specify one long line for each paragraph in the header and the +-- argument descriptions, and let print_usage_info do the wrapping. When you +-- have several paragraphs, separate them by a double @\\n\\n@. This also applies +-- for an empty line, which should be printed after the actual header. +-- +-- The arguments are printed in the order, in which they occur in the argument +-- description list. +-- +-- This function is a front end to @terminal_width@ and @make_usage_info@. +-- +-- See 'argdesc', 'desc_description', 'terminal_width', 'make_usage_info', 'usage_info', 'wrap'. +print_usage_info :: Handle -- ^ To which handle to print the + -- usage info. + -> String -- ^ The header to print first. + -- Can be empty. + -> [ArgumentDescription] -- ^ The argument description of + -- the arguments, which should be documented. + -> IO () +print_usage_info h header descs = do - -- Alle Zeilen eirücken - einruecken1 :: Int -> [String] -> [String] - einruecken1 _ [] = [""] - einruecken1 spalten zll = - map (\z -> lz spalten ++ z) zll + -- Determine the width to use + mw <- terminal_width h + let w = case mw of + Just w -> w + Nothing -> 80 + {- + if w < 12 + then ioError (mkIOError userErrorType "The terminal width is too small (< 12) for printing \ + \of the usage information. See print_usage_info." (Just h) Nothing) + else + -} -make_usage_info1 argdescs = - concat (intersperse "\n" (make_usage_info argdescs 0 10 80)) + if w < 12 + then hPutStr h "Terminal too narrow" + else do -- Wrap and print the header + hPutStr h (unlines (wrap w header)) + + -- Print the argument descriptions. + mapM_ (hPutStr h) + (make_usage_info descs + 0 + (w `div` 5) + (w `div` 3) + w) + -- | -- Break down a text to lines, such that each one has the specified @@ -1165,7 +1377,7 @@ -- -- The text is wrapped at space characters. Words remain intact, except when -- they are too long for one line. -wrap :: Int -- ^ Width for the result text, in columns +wrap :: Int -- ^ Maximum width for the lines of the text, which is to be broken down -> String -- ^ Text to break down -> [String] -- ^ The broken down text in columns wrap breite [] = [] @@ -1177,6 +1389,10 @@ wrap' :: Int -> String -> [String] wrap' breite [] = [""] wrap' breite txt = + wrap'' breite (dropWhile isSpace txt) + + wrap'' :: Int -> String -> [String] + wrap'' breite txt = if length txt <= breite then [txt] else @@ -1205,46 +1421,3 @@ in (zl''', wort') - - --- | --- Print the usage information (about the command line arguments), for the --- specified header and arguments to the specified handle. When the handle is --- connected to a terminal, the terminal\'s width (in columns) is used to format --- the output, such that it fits the terminal. Both the header and the argument --- descriptions are adapted to the width of the terminal (by using @wrap@). --- --- When the handle does not connected to a terminal, 80 columns are used. This --- may happen to @stdout@ or @stderr@, for instance, when the program is in a --- pipe, or the output has been redirected to a file. --- --- You should specify one long line for each paragraph in the header and the --- argument descriptions, and let print_usage_info do the wrapping. When you --- have several paragraphs, separate them by a double @\\n\\n@. --- --- The arguments are printed in the order, in which they occur in the argument --- description list. --- --- This function is a front end to @terminal_width@ and @make_usage_info@. --- --- See 'argdesc', 'desc_description', 'terminal_width', 'make_usage_info', 'usage_info', 'wrap'. -print_usage_info :: Handle -- ^ To which handle to print the - -- usage info. - -> String -- ^ The header to print first. - -- Can be empty. - -> [ArgumentDescription] -- ^ The argument description of - -- the arguments, which should be documented. - -> IO () -print_usage_info h header descs = do - -- Determine the width to use - mw <- terminal_width h - let w = case mw of - Just w -> w - Nothing -> 80 - - -- Wrap and print the header - hPutStr h (unlines (wrap w header)) - - -- Print the argument descriptions - mapM_ (hPutStrLn h) - (make_usage_info descs 0 (w `div` 8 + 1) w) diff --git a/src/HsShellScript/Args.hs-boot b/src/HsShellScript/Args.hs-boot --- a/src/HsShellScript/Args.hs-boot +++ b/src/HsShellScript/Args.hs-boot @@ -1,5 +1,7 @@ module HsShellScript.Args where +import GHC.IO + data ArgError = ArgError { argerror_message :: String, argerror_usageinfo :: String @@ -7,3 +9,5 @@ deriving (Typeable) +terminal_width_ioe :: Handle -> IO Int +terminal_width :: Handle -> IO (Maybe Int) diff --git a/src/HsShellScript/ProcErr.chs b/src/HsShellScript/ProcErr.chs --- a/src/HsShellScript/ProcErr.chs +++ b/src/HsShellScript/ProcErr.chs @@ -54,6 +54,8 @@ + + {- | Improved version of @System.Posix.Files.setFileMode@, which sets the file name in the @IOError@ which is thrown in case of an error. The implementation in GHC 6.2.2 neglects to do this. @@ -2397,7 +2399,6 @@ instance Exception ProcessStatus - -- | Determine the terminal width in columns. -- -- This value can be used to format output to fit the terminal. @@ -2409,7 +2410,7 @@ -- See 'terminal_width', 'make_usage_info', 'print_usage_info', 'usage_info', 'wrap'. terminal_width_ioe :: Handle -- ^ Handle, which is connected to the terminal -> IO Int -- ^ The number of columns in the constrolling terminal. - -- Nothing, when the handle isn't connected to a terminal. + -- Throws an IOError when the handle isn't connected to a terminal. terminal_width_ioe h = do fd <- unsafeWithHandleFd h $ \fd -> do diff --git a/src/HsShellScript/ProcErr.hs-boot b/src/HsShellScript/ProcErr.hs-boot --- a/src/HsShellScript/ProcErr.hs-boot +++ b/src/HsShellScript/ProcErr.hs-boot @@ -1,9 +1,16 @@ module HsShellScript.ProcErr where import Data.Maybe -import System.IO +import System.IO (Handle) +import Control.Concurrent.MVar +import GHC.IO.Handle.Internals -- withHandle', do_operation -terminal_width :: Handle -> IO (Maybe Int) -terminal_width_ioe :: Handle -> IO Int throwErrno' :: String -> Maybe Handle -> Maybe FilePath -> IO a + +-- unsafeWithHandleFd :: Handle -> (Fd -> IO a) -> IO a +-- unsafeWithHandleFd' :: Handle -> MVar Handle__ -> (Fd -> IO a) -> IO a + + +terminal_width_ioe :: Handle -> IO Int +terminal_width :: Handle -> IO (Maybe Int) diff --git a/test/Makefile b/test/Makefile --- a/test/Makefile +++ b/test/Makefile @@ -8,10 +8,10 @@ % : %.o cteile.o - ghc -o $@ $^ -package unix -package directory -package random -package parsec -package hsshellscript + ghc -o $@ $^ -package unix -package directory -package random -package parsec -package hsshellscript -XScopedTypeVariables %.o : %.hs - ghc -c $(CFLAGS) $^ + ghc -c $(CFLAGS) $^ -XScopedTypeVariables # %.o : %.c diff --git a/test/args.chs b/test/args.chs --- a/test/args.chs +++ b/test/args.chs @@ -1,10 +1,9 @@ --- Fehler, wenn die Breiten nicht hinkommen in make_usage_info - module Main (main) where -import HsShellScript +import HsShellScript {-hiding (make_usage_info, print_usage_info, wrap)-} import Data.Maybe import Data.List +import Data.Char import Debug.Trace import Control.Monad import Control.Exception @@ -12,7 +11,7 @@ header = "Testprogramm für Kommandozeilenargumente\n\n" -descs = [ d_trenner, d_pfade, d_uml, d_komp, d_inhalt ] +descs = [ d_komp, d_trenner, d_pfade, d_uml, d_inhalt, d_bla ] args = unsafe_getargs header descs trenner_normal = " - " @@ -22,46 +21,329 @@ komp = optarg_req args d_komp -d_komp = +d_komp = argdesc [ desc_short 'k' + , desc_short 'l' + , desc_short 'm' , desc_long "komp" + , desc_long "komp1" + , desc_long "komp2" , desc_value_required , desc_argname "" , desc_description "Das ist eine lange Argumentbeschreibung, die umgebrochen werden muß, weil sie zu lang ist. Wirklich. Undhierkommteinganzlangeswortdasgetrenntwerdenmuß" ] -d_trenner = +d_trenner = argdesc [ desc_short 't' , desc_long "langer-param" , desc_at_most_once , desc_value_required , desc_argname "" - , desc_description ("Diese Beschreibung\nhat mehrere\n\nZeilen.") + , desc_description "Diese Beschreibung\nhat mehrere\nZeilen." ] -d_uml = +d_uml = argdesc [ desc_long "äöüß" , desc_at_most_once ] -d_pfade = +d_pfade = argdesc [ desc_direct , desc_any_times , desc_description ("Pfade, denen vorgesetzt werden soll; bzw, bla bla Verzeichnisse, die ihren Inhalten vorgesetzt werden sollen") ] -d_inhalt = +d_inhalt = argdesc [ desc_long "inhalt" , desc_description ("Nicht angegebenen Dateien vorsetzen, sondern dem Inhalt der angegebenen Verzeichnisse. Angegebene Nicht-Verzeichnisse \ \beiseitelassen.") ] +d_bla = + argdesc [ desc_long "foo" + , desc_short 'h' + , desc_value_required + , desc_argname "Name" + , desc_description "bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla \ + \bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla " + ] + main = mainwrapper $ do seq args (return ()) + + print_usage_info stdout "Header\n\n" descs + + + +{- +-- | +-- Generate pretty-printed information about the command line arguments. This +-- function gives you much control on how the usage information is generated. +-- @print_usage_info@ might be more like what you need. +-- +-- The specified argument descriptions (as taken by the @getargs@... functions) +-- are processed in the given order. Each one is formatted as a paragraph, +-- detailing the argument. This is done according to the specified geometry. +-- +-- The direct argument, in case there is one, is omitted. You should detail the +-- direct command line arguments separatly, such as in some header. +-- +-- The specified maximum breadths must fit in the specified width, or an error +-- is raised. This happens, when @colsleft + colsshort + 2 + colslong + 2 + 2 > +-- width@. +-- +-- See 'print_usage_info', 'getargs', 'usage_info', 'ArgumentDescription', +-- 'desc_description', 'argdesc', 'terminal_width', 'terminal_width_ioe'. +make_usage_info :: [ArgumentDescription] -- ^ List of argument descriptions, as created by a @argdesc@ + -> Int -- ^ The output is indented this many columns. Probably zero. + -> Int -- ^ Maximum width of the column of the short form of each argument. When this many aren't + -- needed, less are used. + -> Int -- ^ Maximum width of the column of the long form of each argument. When this many aren't + -- needed, less are used. + -> Int -- ^ Wrap everything at this column. Should probably be the terminal width. + -> [String] -- ^ Pretty printed usage information, in paragraphs, which contain one or several lines. +make_usage_info descs colsleft colsshort colslong width = + + if colsleft + colsshort + 2 + colslong + 2 + 2 > width + then error $ "make_usage_info: colsleft, colsshort, and colslong arguments \ + \are too large for the specified width argument.\n\ + \colsleft = " ++ show colsleft ++ " \n\ + \colsshort = " ++ show colsshort ++ " \n\ + \colslong = " ++ show colslong ++ " \n\ + \width = " ++ show width + else + map unlines (verbinden (zll' (filter (\d -> not (is_direct d)) + descs) + )) + + where + -- Die Argumentbeschreibung, auf die richtige Breite umgebrochen + beschr :: ArgumentDescription -> [String] + beschr desc = wrap (width - colsleft - gesamtbr_kurz - 2 - gesamtbr_lang - 2) + (fromMaybe "" (argdesc_description desc)) - print_usage_info stdout "Das ist ein langer Header... Das ist ein langer Header... Das ist ein langer Header... Das\ - \ist ein langer Header... Das ist ein langer Header... Das ist ein langer Header... Das ist \ - \ein langer Header... Das ist ein langer Header... Das ist ein langer Header... \n\n" - descs + -- Eine ArgumentDescription rendern. Die fertigen Zeilen sind alle gleich viele (mit "" aufgefüllt). + auff1 :: ArgumentDescription + -> ([String], [String], [String]) + auff1 desc = auff (kurzname desc) + (langname desc) + (beschr desc) + + -- Wir haben für eine Argumentbeschreibung die Listen von Zeilen, aus denen der kurze, und lange Argumentname besteht, sowie die Zeilen, aus + -- denen die Argumentbeschreibung besteht. + zus :: ([String], [String], [String]) -> [(String, String, String)] + zus (as, bs, cs) = zip3 as bs cs + + -- Die für die Kurzform einses Arguments benötigte Zahl von Spalten + kurzbr :: ArgumentDescription -> Int + kurzbr desc = + foldr max 0 (map length (kurzname desc)) + + -- Die für die Langform einses Arguments benötigte Zahl von Spalten + langbr :: ArgumentDescription -> Int + langbr desc = + foldr max 0 (map length (langname desc)) + + -- Breite der Kurzform, über alle Argumente hinweg + gesamtbr_kurz = + foldr max 0 (map (\desc -> kurzbr desc) descs) + + -- Breite der Langform, über alle Argumente hinweg + gesamtbr_lang = + foldr max 0 (map (\desc -> langbr desc) descs) + + -- Breite der Beschreibungen + breite_descr :: Int + breite_descr = width - colsleft - gesamtbr_kurz - 2 - gesamtbr_lang - 2 + -- Für jedes Kommandozeilenargument die Liste der Zeilen + zll :: [ArgumentDescription] + -> [[(String, String, String)]] + zll descs = + map (zus . auff1) descs + + -- Für jedes Kommandozeilenargument die Liste der Zeilen, aufgefüllt auf einheitliche Breite + zll' :: [ArgumentDescription] + -> [[(String, String, String)]] + zll' [] = + [] + zll' descs = + map (\l -> map (\(a,b,c) -> (fuell gesamtbr_kurz a, + fuell gesamtbr_lang b, + c)) + l) + (zll descs) + + -- Die Tripel + verbinden :: [[(String, String, String)]] + -> [[String]] + verbinden l = + map (\l' -> map (\(a,b,c) -> take colsleft (repeat ' ') + ++ a ++ " " ++ b ++ " " ++ c) l') + l + + -- Die Kurzform des angegebenen Arguments. In Zeilen heruntergebrochen, + -- wenn die Breite colsshort überschritten wird. + kurzname :: ArgumentDescription -> [String] + kurzname desc = + wrap colsshort (argname_short desc) + + -- Die Langform des angegebenen Arguments. In Zeilen heruntergebrochen, + -- wenn die Breite colslong überschritten wird + langname :: ArgumentDescription -> [String] + langname desc = + wrap colslong (argname_long desc) + + -- Den gegebenen String um so viele Leerzeichen ergänzen, daß daraus ein String der gegebenen Länge wird. Ist er dafür zu lang, denn den + -- unveränderten String zurückgeben. + fuell :: Int -> String -> String + fuell br txt = + txt ++ take (br - length txt) (repeat ' ') + + + -- Complete three lists of Strings. All three strings are made to be made up + -- of the same number of entries. Missing entries at the end are filled up with + -- empty strings. + auff :: [String] -> [String] -> [String] -> ([String], [String], [String]) + auff a b c = + (reverse x, reverse y, reverse z) + + where + (x,y,z) = auff' a b c [] [] [] + + auff' :: [String] -> [String] -> [String] + -> [String] -> [String] -> [String] + -> ([String], [String], [String]) + + auff' [] [] [] a1 b1 c1 = + (a1, b1, c1) + + auff' a b c a1 b1 c1 = + auff' (if null a then [] else tail a) + (if null b then [] else tail b) + (if null c then [] else tail c) + ((if null a then "" else head a) : a1) + ((if null b then "" else head b) : b1) + ((if null c then "" else head c) : c1) + + + + +-- | +-- Print the usage information (about the command line arguments), for the +-- specified header and arguments to the specified handle. When the handle is +-- connected to a terminal, the terminal\'s width (in columns) is used to format +-- the output, such that it fits the terminal. Both the header and the argument +-- descriptions are adapted to the width of the terminal (by using @wrap@). +-- +-- When the handle does not connected to a terminal, 80 columns are used. This +-- may happen to @stdout@ or @stderr@, for instance, when the program is in a +-- pipe, or the output has been redirected to a file. +-- +-- When the terminal is too narrow for useful output, then instead of the usage +-- information, a short message (@"Terminal too narrow"@) is printed. This +-- applies to terminals with a width of less than 12. +-- +-- You should specify one long line for each paragraph in the header and the +-- argument descriptions, and let print_usage_info do the wrapping. When you +-- have several paragraphs, separate them by a double @\\n\\n@. This also applies +-- for an empty line, which should be printed after the actual header. +-- +-- The arguments are printed in the order, in which they occur in the argument +-- description list. +-- +-- This function is a front end to @terminal_width@ and @make_usage_info@. +-- +-- See 'argdesc', 'desc_description', 'terminal_width', 'make_usage_info', 'usage_info', 'wrap'. +print_usage_info :: Handle -- ^ To which handle to print the + -- usage info. + -> String -- ^ The header to print first. + -- Can be empty. + -> [ArgumentDescription] -- ^ The argument description of + -- the arguments, which should be documented. + -> IO () +print_usage_info h header descs = do + + -- Determine the width to use + mw <- terminal_width h + let w = case mw of + Just w -> w + Nothing -> 80 + + {- + if w < 12 + then ioError (mkIOError userErrorType "The terminal width is too small (< 12) for printing \ + \of the usage information. See print_usage_info." (Just h) Nothing) + else + -} + + if w < 12 + then hPutStr h "Terminal too narrow" + + else do -- Wrap and print the header + hPutStr h (unlines (wrap w header)) + + -- Print the argument descriptions. + mapM_ (hPutStr h) + (make_usage_info descs + 0 + (w `div` 5) + (w `div` 3) + w) + + +-- | +-- Break down a text to lines, such that each one has the specified +-- maximum width. +-- +-- Newline characters in the input text are respected. They terminate the line, +-- without it being filled up to the width. +-- +-- The text is wrapped at space characters. Words remain intact, except when +-- they are too long for one line. +wrap :: Int -- ^ Maximum width for the lines of the text, which is to be broken down + -> String -- ^ Text to break down + -> [String] -- ^ The broken down text in columns +wrap breite [] = [] +wrap breite txt = + [ zl | txtzl <- lines txt, + zl <- wrap' breite txtzl + ] + where + wrap' :: Int -> String -> [String] + wrap' breite [] = [""] + wrap' breite txt = + wrap'' breite (dropWhile isSpace txt) + + wrap'' :: Int -> String -> [String] + wrap'' breite txt = + if length txt <= breite + then [txt] + else + if null txt_anf + then -- Zu breit für eine Zeile + txt_br : wrap' breite txt_rest + else txt_anf : wrap' breite rest + + where + (txt_br, txt_rest) = + splitAt breite txt + + (txt_anf, txt_anf_rest) = + letzter_teil txt_br + + rest = txt_anf_rest ++ txt_rest + + -- Letztes Wort von zl abspalten. Liefert + -- ( Anfang von zl, Letztes Wort ) + letzter_teil zl = + let zl' = reverse zl + (wort, zl'') = span (/= ' ') zl' + zl''1 = dropWhile (== ' ') zl'' + zl''' = reverse zl''1 + wort' = reverse wort + in (zl''', wort') + + +-} diff --git a/test/args.hs b/test/args.hs --- a/test/args.hs +++ b/test/args.hs @@ -3,15 +3,14 @@ {-# LINE 1 "args.chs" #-} --- Fehler, wenn die Breiten nicht hinkommen in make_usage_info - module Main (main) where -import HsShellScript +import HsShellScript {-hiding (make_usage_info, print_usage_info, wrap)-} import Data.Maybe import Data.List +import Data.Char import Debug.Trace import Control.Monad import Control.Exception @@ -19,7 +18,7 @@ header = "Testprogramm für Kommandozeilenargumente\n\n" -descs = [ d_trenner, d_pfade, d_uml, d_komp, d_inhalt ] +descs = [ d_komp, d_trenner, d_pfade, d_uml, d_inhalt, d_bla ] args = unsafe_getargs header descs trenner_normal = " - " @@ -29,46 +28,331 @@ komp = optarg_req args d_komp -d_komp = +d_komp = argdesc [ desc_short 'k' + , desc_short 'l' + , desc_short 'm' , desc_long "komp" + , desc_long "komp1" + , desc_long "komp2" , desc_value_required , desc_argname "" , desc_description "Das ist eine lange Argumentbeschreibung, die umgebrochen werden muß, weil sie zu lang ist. Wirklich. Undhierkommteinganzlangeswortdasgetrenntwerdenmuß" ] -d_trenner = +d_trenner = argdesc [ desc_short 't' , desc_long "langer-param" , desc_at_most_once , desc_value_required , desc_argname "" - , desc_description ("Diese Beschreibung\nhat mehrere\n\nZeilen.") + , desc_description "Diese Beschreibung\nhat mehrere\nZeilen." ] -d_uml = +d_uml = argdesc [ desc_long "äöüß" , desc_at_most_once ] -d_pfade = +d_pfade = argdesc [ desc_direct , desc_any_times , desc_description ("Pfade, denen vorgesetzt werden soll; bzw, bla bla Verzeichnisse, die ihren Inhalten vorgesetzt werden sollen") ] -d_inhalt = +d_inhalt = argdesc [ desc_long "inhalt" , desc_description ("Nicht angegebenen Dateien vorsetzen, sondern dem Inhalt der angegebenen Verzeichnisse. Angegebene Nicht-Verzeichnisse \ \beiseitelassen.") ] +d_bla = + argdesc [ desc_long "foo" + , desc_short 'h' + , desc_value_required + , desc_argname "Name" + , desc_description "bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla \ + \bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla " + ] + + + main = mainwrapper $ do seq args (return ()) + + print_usage_info stdout "Header\n\n" descs + + + +{- +-- | +-- Generate pretty-printed information about the command line arguments. This +-- function gives you much control on how the usage information is generated. +-- @print_usage_info@ might be more like what you need. +-- +-- The specified argument descriptions (as taken by the @getargs@... functions) +-- are processed in the given order. Each one is formatted as a paragraph, +-- detailing the argument. This is done according to the specified geometry. +-- +-- The direct argument, in case there is one, is omitted. You should detail the +-- direct command line arguments separatly, such as in some header. +-- +-- The specified maximum breadths must fit in the specified width, or an error +-- is raised. This happens, when @colsleft + colsshort + 2 + colslong + 2 + 2 > +-- width@. +-- +-- See 'print_usage_info', 'getargs', 'usage_info', 'ArgumentDescription', +-- 'desc_description', 'argdesc', 'terminal_width', 'terminal_width_ioe'. +make_usage_info :: [ArgumentDescription] -- ^ List of argument descriptions, as created by a @argdesc@ + -> Int -- ^ The output is indented this many columns. Probably zero. + -> Int -- ^ Maximum width of the column of the short form of each argument. When this many aren't + -- needed, less are used. + -> Int -- ^ Maximum width of the column of the long form of each argument. When this many aren't + -- needed, less are used. + -> Int -- ^ Wrap everything at this column. Should probably be the terminal width. + -> [String] -- ^ Pretty printed usage information, in paragraphs, which contain one or several lines. +make_usage_info descs colsleft colsshort colslong width = + + if colsleft + colsshort + 2 + colslong + 2 + 2 > width + then error $ "make_usage_info: colsleft, colsshort, and colslong arguments \ + \are too large for the specified width argument.\n\ + \colsleft = " ++ show colsleft ++ " \n\ + \colsshort = " ++ show colsshort ++ " \n\ + \colslong = " ++ show colslong ++ " \n\ + \width = " ++ show width + else + map unlines (verbinden (zll' (filter (\d -> not (is_direct d)) + descs) + )) + + where + -- Die Argumentbeschreibung, auf die richtige Breite umgebrochen + beschr :: ArgumentDescription -> [String] + beschr desc = wrap (width - colsleft - gesamtbr_kurz - 2 - gesamtbr_lang - 2) + (fromMaybe "" (argdesc_description desc)) - print_usage_info stdout "Das ist ein langer Header... Das ist ein langer Header... Das ist ein langer Header... Das\ - \ist ein langer Header... Das ist ein langer Header... Das ist ein langer Header... Das ist \ - \ein langer Header... Das ist ein langer Header... Das ist ein langer Header... \n\n" - descs + -- Eine ArgumentDescription rendern. Die fertigen Zeilen sind alle gleich viele (mit "" aufgefüllt). + auff1 :: ArgumentDescription + -> ([String], [String], [String]) + auff1 desc = auff (kurzname desc) + (langname desc) + (beschr desc) + + -- Wir haben für eine Argumentbeschreibung die Listen von Zeilen, aus denen der kurze, und lange Argumentname besteht, sowie die Zeilen, aus + -- denen die Argumentbeschreibung besteht. + zus :: ([String], [String], [String]) -> [(String, String, String)] + zus (as, bs, cs) = zip3 as bs cs + + -- Die für die Kurzform einses Arguments benötigte Zahl von Spalten + kurzbr :: ArgumentDescription -> Int + kurzbr desc = + foldr max 0 (map length (kurzname desc)) + + -- Die für die Langform einses Arguments benötigte Zahl von Spalten + langbr :: ArgumentDescription -> Int + langbr desc = + foldr max 0 (map length (langname desc)) + + -- Breite der Kurzform, über alle Argumente hinweg + gesamtbr_kurz = + foldr max 0 (map (\desc -> kurzbr desc) descs) + + -- Breite der Langform, über alle Argumente hinweg + gesamtbr_lang = + foldr max 0 (map (\desc -> langbr desc) descs) + + -- Breite der Beschreibungen + breite_descr :: Int + breite_descr = width - colsleft - gesamtbr_kurz - 2 - gesamtbr_lang - 2 + -- Für jedes Kommandozeilenargument die Liste der Zeilen + zll :: [ArgumentDescription] + -> [[(String, String, String)]] + zll descs = + map (zus . auff1) descs + + -- Für jedes Kommandozeilenargument die Liste der Zeilen, aufgefüllt auf einheitliche Breite + zll' :: [ArgumentDescription] + -> [[(String, String, String)]] + zll' [] = + [] + zll' descs = + map (\l -> map (\(a,b,c) -> (fuell gesamtbr_kurz a, + fuell gesamtbr_lang b, + c)) + l) + (zll descs) + + -- Die Tripel + verbinden :: [[(String, String, String)]] + -> [[String]] + verbinden l = + map (\l' -> map (\(a,b,c) -> take colsleft (repeat ' ') + ++ a ++ " " ++ b ++ " " ++ c) l') + l + + -- Die Kurzform des angegebenen Arguments. In Zeilen heruntergebrochen, + -- wenn die Breite colsshort überschritten wird. + kurzname :: ArgumentDescription -> [String] + kurzname desc = + wrap colsshort (argname_short desc) + + -- Die Langform des angegebenen Arguments. In Zeilen heruntergebrochen, + -- wenn die Breite colslong überschritten wird + langname :: ArgumentDescription -> [String] + langname desc = + wrap colslong (argname_long desc) + + -- Den gegebenen String um so viele Leerzeichen ergänzen, daß daraus ein String der gegebenen Länge wird. Ist er dafür zu lang, denn den + -- unveränderten String zurückgeben. + fuell :: Int -> String -> String + fuell br txt = + txt ++ take (br - length txt) (repeat ' ') + + + -- Complete three lists of Strings. All three strings are made to be made up + -- of the same number of entries. Missing entries at the end are filled up with + -- empty strings. + auff :: [String] -> [String] -> [String] -> ([String], [String], [String]) + auff a b c = + (reverse x, reverse y, reverse z) + + where + (x,y,z) = auff' a b c [] [] [] + + auff' :: [String] -> [String] -> [String] + -> [String] -> [String] -> [String] + -> ([String], [String], [String]) + + auff' [] [] [] a1 b1 c1 = + (a1, b1, c1) + + auff' a b c a1 b1 c1 = + auff' (if null a then [] else tail a) + (if null b then [] else tail b) + (if null c then [] else tail c) + ((if null a then "" else head a) : a1) + ((if null b then "" else head b) : b1) + ((if null c then "" else head c) : c1) + + + + +-- | +-- Print the usage information (about the command line arguments), for the +-- specified header and arguments to the specified handle. When the handle is +-- connected to a terminal, the terminal\'s width (in columns) is used to format +-- the output, such that it fits the terminal. Both the header and the argument +-- descriptions are adapted to the width of the terminal (by using @wrap@). +-- +-- When the handle does not connected to a terminal, 80 columns are used. This +-- may happen to @stdout@ or @stderr@, for instance, when the program is in a +-- pipe, or the output has been redirected to a file. +-- +-- When the terminal is too narrow for useful output, then instead of the usage +-- information, a short message (@"Terminal too narrow"@) is printed. This +-- applies to terminals with a width of less than 12. +-- +-- You should specify one long line for each paragraph in the header and the +-- argument descriptions, and let print_usage_info do the wrapping. When you +-- have several paragraphs, separate them by a double @\\n\\n@. This also applies +-- for an empty line, which should be printed after the actual header. +-- +-- The arguments are printed in the order, in which they occur in the argument +-- description list. +-- +-- This function is a front end to @terminal_width@ and @make_usage_info@. +-- +-- See 'argdesc', 'desc_description', 'terminal_width', 'make_usage_info', 'usage_info', 'wrap'. +print_usage_info :: Handle -- ^ To which handle to print the + -- usage info. + -> String -- ^ The header to print first. + -- Can be empty. + -> [ArgumentDescription] -- ^ The argument description of + -- the arguments, which should be documented. + -> IO () +print_usage_info h header descs = do + + -- Determine the width to use + mw <- terminal_width h + let w = case mw of + Just w -> w + Nothing -> 80 + + {- + if w < 12 + then ioError (mkIOError userErrorType "The terminal width is too small (< 12) for printing \ + \of the usage information. See print_usage_info." (Just h) Nothing) + else + -} + + if w < 12 + then hPutStr h "Terminal too narrow" + + else do -- Wrap and print the header + hPutStr h (unlines (wrap w header)) + + -- Print the argument descriptions. + mapM_ (hPutStr h) + (make_usage_info descs + 0 + (w `div` 5) + (w `div` 3) + w) + + +-- | +-- Break down a text to lines, such that each one has the specified +-- maximum width. +-- +-- Newline characters in the input text are respected. They terminate the line, +-- without it being filled up to the width. +-- +-- The text is wrapped at space characters. Words remain intact, except when +-- they are too long for one line. +wrap :: Int -- ^ Maximum width for the lines of the text, which is to be broken down + -> String -- ^ Text to break down + -> [String] -- ^ The broken down text in columns +wrap breite [] = [] +wrap breite txt = + [ zl | txtzl <- lines txt, + zl <- wrap' breite txtzl + ] + where + wrap' :: Int -> String -> [String] + wrap' breite [] = [""] + wrap' breite txt = + wrap'' breite (dropWhile isSpace txt) + + wrap'' :: Int -> String -> [String] + wrap'' breite txt = + if length txt <= breite + then [txt] + else + if null txt_anf + then -- Zu breit für eine Zeile + txt_br : wrap' breite txt_rest + else txt_anf : wrap' breite rest + + where + (txt_br, txt_rest) = + splitAt breite txt + + (txt_anf, txt_anf_rest) = + letzter_teil txt_br + + rest = txt_anf_rest ++ txt_rest + + -- Letztes Wort von zl abspalten. Liefert + -- ( Anfang von zl, Letztes Wort ) + letzter_teil zl = + let zl' = reverse zl + (wort, zl'') = span (/= ' ') zl' + zl''1 = dropWhile (== ' ') zl'' + zl''' = reverse zl''1 + wort' = reverse wort + in (zl''', wort') + + +-}