hzenity (empty) → 0.1

raw patch · 5 files changed

+614/−0 lines, 5 filesdep +basedep +containersdep +data-defaultsetup-changed

Dependencies added: base, containers, data-default, process, process-extras, text, time

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• examples/Simple.hs +46/−0
• hzenity.cabal +47/−0
• src/Zenity.hs +489/−0

@@ -0,0 +1,30 @@+Copyright (c) 2018, Emil Axelsson++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.++    * Neither the name of Emil Axelsson nor the names of other+      contributors may 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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,46 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++module Simple where++import Control.Monad+import Data.Monoid+import System.Process++import Zenity++-- Ask for a name and display a greeting+greeting = do+  Just name <-+    zenity def {title = Just "Name entry"} $+    Entry $ def {text = Just "What's your name?"}+  zenity def $ Info def {text = Just $ "Greetings, " <> name <> "!"}++data SystemCommand+  = Ls+  | Pwd+  | Uname+  deriving (Eq, Show, Read)++-- Ask for a system command to be executed+--+-- `keyedList` allows associating each option with a value of some type. We can+-- then scrutinize the result by matching on the associated values.+systemOperation = do+  op <- keyedList def radio def+    "Select a command"+    [ (Ls, "List files")+    , (Pwd, "Show current directory")+    , (Uname, "OS information")+    ]+  case op of+    Just Ls -> do+      putStrLn "These are the files in the current directory:"+      void $ system "ls"+    Just Pwd -> do+      putStrLn "This is the current directory:"+      void $ system "pwd"+    Just Uname -> do+      putStrLn "This is the OS that's running:"+      void $ system "uname"+    Nothing -> return ()

@@ -0,0 +1,47 @@+name:                hzenity+version:             0.1+synopsis:            Haskell interface to Zenity dialogs+description:         This is a Haskell wrapper around the+                     <https://en.wikipedia.org/wiki/Zenity Zenity> dialog+                     program.+                     .+                     Examples can be found in the <https://github.com/emilaxelsson/hzenity/tree/master/examples examples/>+                     directory.+homepage:            https://github.com/emilaxelsson/hzenity+license:             BSD3+license-file:        LICENSE+author:              Emil Axelsson+maintainer:          78emil@gmail.com+copyright:           2018 Emil Axelsson+homepage:            https://github.com/emilaxelsson/hzenity+bug-reports:         https://github.com/emilaxelsson/hzenity/issues+category:            Development+build-type:          Simple+cabal-version:       >=1.10++extra-source-files:  examples/*.hs++source-repository head+  type:     git+  location: https://github.com/emilaxelsson/hzenity.git++library+  exposed-modules:     Zenity+  build-depends:       base >=4.10 && <4.11,+                       containers,+                       data-default,+                       process,+                       process-extras,+                       text,+                       time+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  DeriveFunctor+                       DuplicateRecordFields+                       FlexibleInstances+                       GADTs+                       OverloadedStrings+                       RecordWildCards+                       StandaloneDeriving+  ghc-options:         -Wall+                       -Wno-missing-signatures

@@ -0,0 +1,489 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++-- | A wrapper for <https://en.wikipedia.org/wiki/Zenity Zenity> dialog boxes+--+-- It is advised to turn on the following extensions when using this module:+--+-- > DuplicateRecordFields+-- > OverloadedStrings+--+-- Here is a simple example for how to use the library. It asks the user for a+-- name and displays a greeting:+--+-- @+-- {-\# LANGUAGE DuplicateRecordFields \#-}+-- {-\# LANGUAGE OverloadedStrings \#-}+--+-- import "Data.Monoid"+-- import "Zenity"+--+-- greeting = do+--   Just name <-+--     `zenity` `def` {title = Just "Name entry"} $+--       `Entry` $ `def` {text = Just "What's your name?"}+--   `zenity` `def` $ `Info` `def` {text = Just $ "Greetings, " <> name <> "!"}+-- @+--+-- More examples can be found in the+-- <https://github.com/emilaxelsson/hzenity/tree/master/examples examples/>+-- directory.+module Zenity+  ( Text+  , Default (..)++    -- * Zenity dialogs+  , Config (..)+  , CalendarFlags (..)+  , EntryFlags (..)+  , FileSelectionFlags (..)+  , InfoFlags (..)+  , ReturnedColumns (..)+  , ListFlags (..)+  , SelectionHeader (..)+  , ListType (..)+  , radio+  , check+  , Matrix (..)+  , Dialog (..)+  , zenity++    -- ** Extra dialogs+  , keyedList+  ) where++import Control.Monad (void, when)+import Control.Monad.Fail (MonadFail)+import Data.Bool (bool)+import Data.Default (Default (..))+import Data.String (IsString)+import Data.Text (Text)+import Data.Time.Calendar (Day)+import Data.Time.Format (defaultTimeLocale, parseTimeM)+import qualified Data.Text as Text+import Data.Word (Word)+import qualified System.Process.Text as Text+import System.Process (showCommandForUser)++++-- | Chop a list into chunks of size @n@+chunk :: Int -> [a] -> [[a]]+chunk n as+  | n >= 1 = go (length as) as+  | otherwise = error "chunk: chunk size must be >= 1"+  where+    go l bs+      | l <= n = [bs]+      | otherwise = take n bs : go (l - n) (drop n bs)++++--------------------------------------------------------------------------------+-- * Zenity+--------------------------------------------------------------------------------++-- | General Zenity configuration+--+-- Use 'def' for default configuration.+data Config = Config+  { title :: Maybe Text -- ^ Dialog title+  , windowIcon :: Maybe FilePath+      -- ^ Window icon with the path to an image. Alternatively, one of the four+      -- stock icons can be used: @error@, @info@, @question@ or @warning@.+  , width :: Maybe Int -- ^ Dialog width+  , height :: Maybe Int -- ^ Dialog height+  , timeout :: Maybe Int -- ^ Dialog timeout in seconds+  }++instance Default Config where+  def = Config+    { title = Nothing+    , windowIcon = Nothing+    , width = Nothing+    , height = Nothing+    , timeout = Nothing+    }++data CmdFlag where+  CmdFlag+    :: { _flagName :: String+       , _flagField :: Maybe a+       , _flagParam :: a -> String}+    -> CmdFlag++cmdFlag :: CmdFlag -> [String]+cmdFlag (CmdFlag flag fld mkParam) = maybe [] (\f -> [flag, mkParam f]) fld++configFlags :: Config -> [String]+configFlags Config {..} =+  concatMap+    cmdFlag+    [ CmdFlag "--title" title Text.unpack+    , CmdFlag "--window-icon" windowIcon id+    , CmdFlag "--width" width show+    , CmdFlag "--height" height show+    , CmdFlag "--timeout" timeout show+    ]++class CmdParam p where+  serializeParam :: p -> [String]++boolParam :: Bool -> String -> [String]+boolParam param flag = bool [] [flag] param++maybeParam :: Maybe a -> (a -> [String]) -> [String]+maybeParam = flip $ maybe []++-- | Flags for the 'Calendar' dialog+--+-- Use 'def' for default flags.+data CalendarFlags = CalendarFlags+  { text :: Maybe Text -- ^ Dialog text+  , year :: Maybe Word -- ^ Calendar year+  , month :: Maybe Word -- ^ Calendar month+  , day :: Maybe Word -- ^ Calendar day+  } deriving (Eq, Show)++instance Default CalendarFlags where+  def = CalendarFlags Nothing Nothing Nothing Nothing++instance CmdParam CalendarFlags where+  serializeParam CalendarFlags {..} = concat+    [ maybeParam text $ \t -> ["--text", Text.unpack t]+    , maybeParam year $ \y -> ["--year", show y]+    , maybeParam month $ \m -> ["--month", show m]+    , maybeParam day $ \d -> ["--day", show d]+    ]++-- | Flags for the 'Entry' dialog+--+-- Use 'def' for default flags.+data EntryFlags = EntryFlags+  { text :: Maybe Text -- ^ Dialog text+  , entryText :: Maybe Text -- ^ Entry text+  , hideText :: Bool -- ^ Hide the text entered by the user+  } deriving (Eq, Show)++instance Default EntryFlags where+  def = EntryFlags Nothing Nothing False++instance CmdParam EntryFlags where+  serializeParam EntryFlags {..} = concat+    [ maybeParam text $ \t -> ["--text", Text.unpack t]+    , maybeParam entryText $ \t -> ["--entry-text", Text.unpack t]+    , boolParam hideText "--hide-text"+    ]++-- | Flags for the 'FileSelection' dialog+--+-- Use 'def' for default flags.+data FileSelectionFlags = FileSelectionFlags+  { fileName :: Maybe FilePath+      -- ^ File or directory to be selected by default+  , directory :: Bool+      -- ^ Activate directory-only selection+  , save :: Bool -- ^ Save mode+  , confirmOverwrite :: Bool+      -- ^ Confirm file selection if file name already exists+  -- TODO , fileFilter :: ???+  } deriving (Eq, Show)++instance Default FileSelectionFlags where+  def = FileSelectionFlags Nothing False False False++instance CmdParam FileSelectionFlags where+  serializeParam FileSelectionFlags {..} = concat+    [ maybeParam fileName $ \f -> ["--filename", f]+    , boolParam directory "--directory"+    , boolParam save "--save"+    , boolParam confirmOverwrite "--confirm-overwrite"+    ]++-- | Flags for the 'Error' and 'Info' dialogs+--+-- Use 'def' for default flags.+data InfoFlags = InfoFlags+  { text :: Maybe Text -- ^ Dialog text+  , noWrap :: Bool -- ^ Do not enable text wrapping+  , noMarkup :: Bool -- ^ Do not enable pango markup+  } deriving (Eq, Show)++instance Default InfoFlags where+  def = InfoFlags Nothing False False++instance CmdParam InfoFlags where+  serializeParam InfoFlags {..} = concat+    [ maybeParam text $ \t -> ["--text", Text.unpack t]+    , boolParam noWrap "--no-wrap"+    , boolParam noMarkup "--no-markup"+    ]++-- | What columns to return in a 'List' dialog+--+-- The default value is @`Col` 1@.+--+-- When 'All' is specified, the columns will be separated by newline characters+-- (@\\n@) in the result.+data ReturnedColumns a+  = All -- ^ Return all columns+  | Col a -- ^ Return the specified column (starting from 1)+  deriving (Eq, Show, Functor)++-- | Flags for the 'List' dialog+--+-- Use 'def' for default flags.+data ListFlags = ListFlags+  { text :: Maybe Text -- ^ Dialog text+  , editable :: Bool -- ^ Allow changes to text+  , returnColumn :: ReturnedColumns Word -- ^ What column to return+  , hideColumn :: Maybe Word -- ^ Hide a specific column+  , hideHeader :: Bool -- ^ Hide the column headers+  } deriving (Eq, Show)++instance Default ListFlags where+  def = ListFlags Nothing False (Col 1) Nothing False++instance CmdParam ListFlags where+  serializeParam ListFlags {..} = concat+    [ maybeParam text $ \t -> ["--text", Text.unpack t]+    , boolParam editable "--editable"+    , case returnColumn of+        All -> ["--print-column", "ALL"]+        Col c -> ["--print-column", show c]+    , maybeParam hideColumn $ \c -> ["--hide-column", show c]+    , boolParam hideHeader "--hide-header"+    ]++-- Increase the `returnColumn` option, to cater for the first column in+-- radio/check lists+shiftColumns :: ListFlags -> ListFlags+shiftColumns ListFlags {..} = ListFlags+  { returnColumn = fmap shift returnColumn+  , hideColumn = fmap shift hideColumn+  , ..+  }+  where+    shift 0 = 0+    shift c = c+1++-- | Header for the selection column in a radio or check list (can be empty)+newtype SelectionHeader = SelectionHeader {unSelectionHeader :: Text}+  deriving (Eq, Show, IsString)++-- | List dialog type+data ListType a where+  Single :: ListType (Maybe Text)+  Multi :: ListType [Text]+  Radio :: SelectionHeader -> ListType (Maybe Text)+  Check :: SelectionHeader -> ListType [Text]++deriving instance Eq (ListType a)++deriving instance Show (ListType a)++-- | A radio list type with no selection header+radio :: ListType (Maybe Text)+radio = Radio ""++-- | A check list type with no selection header+check :: ListType [Text]+check = Check ""++-- | The contents of a list dialog+--+-- When used in a dialog, the matrix will be transformed in the following ways:+--+-- * Make sure that the matrix is rectangular and has at least one column and+-- one row. Any headers or elements that are added will be empty strings.+--+-- * Any newline characters will be turned into space characters. (This is+-- because newline characters are used internally as separators when returning+-- multiple rows and/or columns.)+data Matrix = Matrix+  { headers :: [Text] -- ^ Column headers+  , rows :: [[Text]] -- ^ Rows+  } deriving (Eq, Show)++-- | Return the width of a 'Matrix' after applying 'fixMatrix' (so the smallest+-- possible value is 1)+matrixWidth :: Matrix -> Int+matrixWidth Matrix {..} = max (length headers) (maximum $ 1 : map length rows)++-- | Make sure that the matrix is rectangular and has at least one column and+-- one row. Any headers or elements that are added will be empty strings.+--+-- The main reason for requring a non-empty matrix is that Zenity gives the+-- result @"(null)"@ otherwise. Not using empty matrices avoids the need to+-- handle such results.+fixMatrix :: Matrix -> Matrix+fixMatrix mat@Matrix {..} = Matrix+  { headers = widen $ if null headers then [""] else headers+  , rows = map widen $ if null rows then [[]] else rows+  }+  where+    width = matrixWidth mat+    widen as = as ++ replicate n ""+      where+        n = width - length as++-- | Add a first column for 'Radio' or 'Check' lists+addSelectionColumn :: SelectionHeader -> Matrix -> Matrix+addSelectionColumn hdr mat = Matrix+  { headers = unSelectionHeader hdr : headers+  , rows = map ("" :) rows+  }+  where+    Matrix {..} = fixMatrix mat+      -- Need to apply `fixMatrix` before adding the column. It doesn't matter+      -- that `fixMatrix` will be applied again inside `matrixFlags`.++matrixFlags :: Matrix -> [String]+matrixFlags mat = concat+  [ concatMap (\hdr -> ["--column", Text.unpack hdr]) headers+  , concatMap (map (map convertNewline . Text.unpack)) rows+  ]+  where+    Matrix {..} = fixMatrix mat+    convertNewline '\n' = ' '+    convertNewline c = c++-- | Zenity commands+--+-- Things to be aware of:+--+-- * In the very unlikely case of a file name containing newline characters,+-- 'MultiFileSelection' will give an incorrect result. This is because it uses+-- @\\n@ to separate the files returned from Zenity.+data Dialog a where+  Calendar :: CalendarFlags -> Dialog (Maybe Day)+  Entry :: EntryFlags -> Dialog (Maybe Text)+  Error :: InfoFlags -> Dialog ()+  FileSelection :: FileSelectionFlags -> Dialog (Maybe FilePath)+  MultiFileSelection :: FileSelectionFlags -> Dialog [FilePath]+  Info :: InfoFlags -> Dialog ()+  List :: ListType a -> ListFlags -> Matrix -> Dialog a+  -- TODO:+  -- Notification+  -- Progress+  -- Question+  -- TextInfo+  -- Warning+  -- Scale+  -- ColorSelection+  -- Password+  -- Forms++-- | Call Zenity with the given flags and capture its 'stdout'+callZenity ::+     Config+  -> [String] -- ^ Additional command-line flags+  -> IO Text+callZenity cfg flags = do+  -- Set to `True` for logging:+  when False $ putStrLn $ showCommandForUser "zenity" flags'+  (\(_, o, _) -> o) <$> Text.readProcessWithExitCode "zenity" flags' ""+  where+    flags' = configFlags cfg ++ flags++parseResult :: Text -> Maybe Text+parseResult "" = Nothing+  -- If the user entered an empty string, "\n" will be returned+parseResult t = Just $ Text.dropWhileEnd (== '\n') t++dateFormat = "%Y-%m-%d"++readDay :: MonadFail m => Text -> m Day+readDay = parseTimeM False defaultTimeLocale dateFormat . Text.unpack++-- | If @`returnColumn` = All@, this function will treat the input list as a+-- concated list of elements from selected rows, and turn that into a list of+-- selected rows. Each row in the result is represented as a single 'Text' value+-- with elements separated by newline characters (@\\n@).+--+-- The 'Matrix' argument is just used to determine the number of returned+-- columns (the width of the matrix).+--+-- If @`returnColumn` = Col c@, the argument list is returned unchanged.+unconcat ::+     ListFlags+  -> Matrix+  -> [Text] -- ^ Concated elements from selected rows+  -> [Text] -- ^ Selected rows+unconcat ListFlags {..} mat+  | All <- returnColumn =+    map (Text.dropEnd 1 . Text.unlines) . chunk (matrixWidth mat)+  | otherwise = id++-- | Run a 'Dialog' action+zenity :: Config -> Dialog a -> IO a+zenity cfg (Calendar flags) =+  traverse readDay . parseResult =<<+  callZenity+    cfg+    ("--calendar" : ("--date-format=" ++ dateFormat) : serializeParam flags)+zenity cfg (Entry flags) =+  fmap parseResult $ callZenity cfg ("--entry" : serializeParam flags)+zenity cfg (Error flags) =+  void $ callZenity cfg $ "--error" : serializeParam flags+zenity cfg (FileSelection flags) =+  fmap (fmap Text.unpack . parseResult) $+  callZenity cfg $ "--file-selection" : serializeParam flags+zenity cfg (MultiFileSelection flags) =+  fmap (lines . Text.unpack) $+  callZenity cfg $+  "--file-selection" :+  "--multiple" : "--separator" : "\n" : serializeParam flags+zenity cfg (Info flags) =+  void $ callZenity cfg $ "--info" : serializeParam flags+zenity cfg (List Single flags mat) =+  fmap parseResult $+  callZenity cfg $+  "--list" : "--separator" : "\n" : serializeParam flags ++ matrixFlags mat+zenity cfg (List Multi flags mat) =+  fmap (unconcat flags mat . Text.lines) $+  callZenity cfg $+  "--list" :+  "--separator" : "\n" : "--multiple" : serializeParam flags ++ matrixFlags mat+zenity cfg (List (Radio h) flags mat) =+  fmap parseResult $+  callZenity cfg $+  "--list" :+  "--separator" :+  "\n" :+  "--radiolist" :+  serializeParam (shiftColumns flags) ++ matrixFlags (addSelectionColumn h mat)+zenity cfg (List (Check h) flags mat) =+  fmap (unconcat flags mat . Text.lines) $+  callZenity cfg $+  "--list" :+  "--separator" :+  "\n" :+  "--checklist" :+  serializeParam (shiftColumns flags) ++ matrixFlags (addSelectionColumn h mat)++++----------------------------------------+-- ** Extra dialogs+----------------------------------------++-- | Make a list selection dialog that selects values from an association list+--+-- Each item is a pair of a value of type @a@ and a text. Only the text will be+-- shown in the dialog, but the value associated with the selected text will be+-- returned.+keyedList ::+     (Show a, Read a, Functor f)+  => Config+  -> ListType (f Text)+  -> ListFlags -- ^ @returnColumn@ and @hideColumn@ will be ignored+  -> Text -- ^ Column head (can be empty)+  -> [(a, Text)] -- ^ List to select from+  -> IO (f a)+keyedList cfg ltype flags hd as =+  fmap (fmap (read . Text.unpack)) $+  zenity cfg $+  List ltype flags {returnColumn = Col 1, hideColumn = Just 1} $+  Matrix+  {headers = ["", hd], rows = [[Text.pack (show a), txt] | (a, txt) <- as]}