summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHenningThielemann <>2019-08-13 10:51:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-08-13 10:51:00 (GMT)
commit046bc47c285c7ad582c3ef62a07ca5bc468d8b81 (patch)
tree07d1bd1ea0475e6fc71d572100768c1b1a1410fb
version 0.0HEAD0.0master
-rw-r--r--LICENSE31
-rw-r--r--Setup.lhs3
-rw-r--r--shell-utility.cabal42
-rw-r--r--src/Shell/Utility/Exit.hs33
-rw-r--r--src/Shell/Utility/GetOpt.hs15
-rw-r--r--src/Shell/Utility/Log.hs70
-rw-r--r--src/Shell/Utility/ParseArgument.hs39
-rw-r--r--src/Shell/Utility/Quote.hs47
-rw-r--r--src/Shell/Utility/Verbosity.hs45
9 files changed, 325 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..5afcce1
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,31 @@
+Copyright (c) 2019, Henning Thielemann
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * The names of contributors may not be used to endorse or promote
+ products derived from this software without specific prior
+ written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..04cf113
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#! /usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/shell-utility.cabal b/shell-utility.cabal
new file mode 100644
index 0000000..a132be2
--- /dev/null
+++ b/shell-utility.cabal
@@ -0,0 +1,42 @@
+Name: shell-utility
+Version: 0.0
+License: BSD3
+License-File: LICENSE
+Author: Henning Thielemann <haskell@henning-thielemann.de>
+Maintainer: Henning Thielemann <haskell@henning-thielemann.de>
+Homepage: http://hub.darcs.net/thielema/shell-utility/
+Category: Console
+Synopsis: Utility functions for writing command-line programs
+Description:
+ Utility functions for writing command-line programs including
+ parsing of numbers with restrictions and enumerations
+ for command-line arguments,
+ verbosity controlled output,
+ escaping shell arguments, exit with message.
+ .
+ The package has very light dependencies and is Haskell 98.
+Tested-With: GHC==7.4.2, GHC==8.6.5
+Cabal-Version: >=1.6
+Build-Type: Simple
+Source-Repository this
+ Tag: 0.0
+ Type: darcs
+ Location: http://hub.darcs.net/thielema/shell-utility/
+
+Source-Repository head
+ Type: darcs
+ Location: http://hub.darcs.net/thielema/shell-utility/
+
+Library
+ Build-Depends:
+ base >=4.3 && <5
+
+ GHC-Options: -Wall
+ Hs-Source-Dirs: src
+ Exposed-Modules:
+ Shell.Utility.Exit
+ Shell.Utility.ParseArgument
+ Shell.Utility.GetOpt
+ Shell.Utility.Quote
+ Shell.Utility.Verbosity
+ Shell.Utility.Log
diff --git a/src/Shell/Utility/Exit.hs b/src/Shell/Utility/Exit.hs
new file mode 100644
index 0000000..caf5ed7
--- /dev/null
+++ b/src/Shell/Utility/Exit.hs
@@ -0,0 +1,33 @@
+{- |
+The Exit mechanism is not compositional
+and thus should not be used in larger long-running programs.
+However, in small command-line utilities
+and especially for signaling errors in command-line arguments
+it is acceptable.
+
+The 'IO' instance is useful for 'GetOpt' and immediate exit.
+The 'Either' instance is useful for 'Optparse.Applicative.eitherReader'.
+-}
+module Shell.Utility.Exit where
+
+import qualified System.Exit as Exit
+import qualified System.IO as IO
+
+import Control.Applicative (Applicative)
+
+import Data.String (IsString, fromString)
+
+
+class Applicative f => Exit f where
+ {- |
+ Also known as 'System.Exit.die' in newer versions of 'base'.
+ -}
+ exitFailureMsg :: String -> f a
+
+instance Exit IO where
+ exitFailureMsg msg = do
+ IO.hPutStrLn IO.stderr msg
+ Exit.exitFailure
+
+instance (IsString str) => Exit (Either str) where
+ exitFailureMsg = Left . fromString
diff --git a/src/Shell/Utility/GetOpt.hs b/src/Shell/Utility/GetOpt.hs
new file mode 100644
index 0000000..4c2253c
--- /dev/null
+++ b/src/Shell/Utility/GetOpt.hs
@@ -0,0 +1,15 @@
+module Shell.Utility.GetOpt where
+
+import qualified System.Console.GetOpt as G
+
+
+fmapArgDescr :: (a -> b) -> (G.ArgDescr a -> G.ArgDescr b)
+fmapArgDescr f d =
+ case d of
+ G.NoArg a -> G.NoArg $ f a
+ G.ReqArg g str -> G.ReqArg (f.g) str
+ G.OptArg g str -> G.OptArg (f.g) str
+
+fmapOptDescr :: (a -> b) -> (G.OptDescr a -> G.OptDescr b)
+fmapOptDescr f (G.Option short long arg help) =
+ G.Option short long (fmapArgDescr f arg) help
diff --git a/src/Shell/Utility/Log.hs b/src/Shell/Utility/Log.hs
new file mode 100644
index 0000000..a52af32
--- /dev/null
+++ b/src/Shell/Utility/Log.hs
@@ -0,0 +1,70 @@
+{- |
+Primitive verbosity controlled logging.
+-}
+module Shell.Utility.Log (
+ warn, notice, info, debug,
+ wrapWords,
+ ) where
+
+import Shell.Utility.Verbosity
+
+import qualified System.IO as IO
+import Control.Monad (when)
+
+import qualified Data.List as List
+
+
+{- |
+Non fatal condition that may indicate a problem.
+
+Display on 'IO.stderr' at 'normal' verbosity and above.
+-}
+warn :: Verbosity -> String -> IO ()
+warn = atLevel normal $ IO.hPutStrLn IO.stderr . ("Warning: " ++)
+
+{- |
+Useful status message.
+
+Display at 'normal' verbosity and above.
+
+This is for the ordinary helpful status messages that users see.
+Just enough information to know that things are working
+but not floods of detail.
+-}
+notice :: Verbosity -> String -> IO ()
+notice = atLevel normal putStrLn
+
+{- |
+More detail on the operation of some action.
+
+Display at 'verbose' verbosity and above.
+-}
+info :: Verbosity -> String -> IO ()
+info = atLevel verbose putStrLn
+
+{- |
+Detailed internal debugging information
+
+Display for 'deafening' verbosity.
+-}
+debug :: Verbosity -> String -> IO ()
+debug = atLevel deafening putStrLn
+
+atLevel ::
+ (Monad m, Ord verbosity) =>
+ verbosity -> (msg -> m ()) -> verbosity -> msg -> m ()
+atLevel minVerbosity act verbosity msg =
+ when (verbosity >= minVerbosity) $ act msg
+
+
+wrapWords :: Int -> [String] -> String
+wrapWords width =
+ drop 1 . concat . snd .
+ List.mapAccumL
+ (\pos w ->
+ let len = length w
+ newPos = pos + 1 + len
+ in if newPos <= width
+ then (newPos, ' ':w)
+ else (len, '\n':w))
+ (-1)
diff --git a/src/Shell/Utility/ParseArgument.hs b/src/Shell/Utility/ParseArgument.hs
new file mode 100644
index 0000000..a07ecdd
--- /dev/null
+++ b/src/Shell/Utility/ParseArgument.hs
@@ -0,0 +1,39 @@
+{- |
+Both "System.Console.GetOpt" and "Optparse.Applicative"
+do not have built-in support for number or enumeration arguments.
+But there is usually a lot to check,
+e.g. whether numbers are positive, not too big, etc.
+We provide argument parsers here in a way that can be used
+in all command-line parsing libraries.
+-}
+module Shell.Utility.ParseArgument where
+
+import qualified Shell.Utility.Exit as Exit
+
+import Control.Applicative (pure)
+import Text.Printf (printf)
+import Data.Maybe (listToMaybe)
+
+
+parseNumber ::
+ (Exit.Exit m, Read a) => String -> (a -> Bool) -> String -> String -> m a
+parseNumber name constraint constraintName str =
+ case reads str of
+ [(n, "")] ->
+ if constraint n
+ then pure n
+ else Exit.exitFailureMsg $
+ name ++ " must be a " ++ constraintName ++ " number"
+ _ ->
+ Exit.exitFailureMsg $
+ name ++ " must be a number, but is '" ++ str ++ "'"
+
+
+enumMaybe :: (Bounded a, Enum a, Eq str) => (a -> str) -> str -> Maybe a
+enumMaybe fmt str =
+ listToMaybe $ dropWhile ((str/=) . fmt) [minBound .. maxBound]
+
+enumeration ::
+ (Bounded a, Enum a) => String -> (a -> String) -> String -> Either String a
+enumeration name fmt str =
+ maybe (Left $ printf "unknown %s: %s" name str) Right $ enumMaybe fmt str
diff --git a/src/Shell/Utility/Quote.hs b/src/Shell/Utility/Quote.hs
new file mode 100644
index 0000000..477910a
--- /dev/null
+++ b/src/Shell/Utility/Quote.hs
@@ -0,0 +1,47 @@
+module Shell.Utility.Quote (always, minimal, lazy) where
+
+mustEscape, mustQuote :: [Char]
+mustEscape = "\"$`\\!"
+mustQuote = "' \t\n|&;()<>{}[]*?^#"
+
+
+{- |
+Escape a single character if it is necessary to escape it even within quotes.
+The exclamation mark is also escaped
+for compatibility with the history expansion misfeature of Bash.
+-}
+escapeChar :: Char -> String
+escapeChar c = (if elem c mustEscape then ('\\':) else id) [c]
+
+
+enclose :: String -> String
+enclose txt = '"' : txt ++ '"' : []
+
+{- |
+Put a string in quotes and escape characters as necessary.
+This allows you to construct shell commands
+such that a shell interprets the arguments in the right way.
+-}
+always :: String -> String
+always = enclose . concatMap escapeChar
+
+{- |
+Like 'always' but encloses in quotes only if necessary.
+-}
+minimal :: String -> String
+minimal txt =
+ if null txt || any (flip elem mustQuote) txt
+ then always txt
+ else concatMap escapeChar txt
+
+{- |
+Similar to 'minimal' but starts quoting only as soon as it becomes necessary.
+This is lazy both with respect to quoting and with respect to processing.
+-}
+lazy :: String -> String
+lazy "" = "\"\""
+lazy txt =
+ let go "" = ""
+ go str@(c:cs) =
+ if elem c mustQuote then always str else escapeChar c ++ go cs
+ in go txt
diff --git a/src/Shell/Utility/Verbosity.hs b/src/Shell/Utility/Verbosity.hs
new file mode 100644
index 0000000..d23de47
--- /dev/null
+++ b/src/Shell/Utility/Verbosity.hs
@@ -0,0 +1,45 @@
+module Shell.Utility.Verbosity (
+ Verbosity,
+ silent, normal, verbose, deafening,
+ parse,
+ ) where
+
+import qualified Shell.Utility.Exit as Exit
+
+import Control.Applicative (pure)
+
+
+data Verbosity = Silent | Normal | Verbose | Deafening
+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+
+-- | We shouldn't print /anything/ unless an error occurs in silent mode
+silent :: Verbosity
+silent = Silent
+
+-- | Print stuff we want to see by default
+normal :: Verbosity
+normal = Normal
+
+-- | Be more verbose about what's going on
+verbose :: Verbosity
+verbose = Verbose
+
+{- |
+Not only are we verbose ourselves
+(perhaps even noisier than when being 'verbose'),
+but we tell everything we run to be verbose too
+-}
+deafening :: Verbosity
+deafening = Deafening
+
+parse :: (Exit.Exit m) => String -> m Verbosity
+parse "" = Exit.exitFailureMsg "empty verbosity identifier"
+parse [c] =
+ case c of
+ '0' -> pure Silent
+ '1' -> pure Normal
+ '2' -> pure Verbose
+ '3' -> pure Deafening
+ _ -> Exit.exitFailureMsg "verbosity must be a number from [0..3]"
+parse _ = Exit.exitFailureMsg "more than one character for verbosity"