diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Simple.hs b/examples/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Simple.hs @@ -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 () diff --git a/hzenity.cabal b/hzenity.cabal new file mode 100644 --- /dev/null +++ b/hzenity.cabal @@ -0,0 +1,47 @@ +name: hzenity +version: 0.1 +synopsis: Haskell interface to Zenity dialogs +description: This is a Haskell wrapper around the + dialog + program. + . + Examples can be found in the + 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 diff --git a/src/Zenity.hs b/src/Zenity.hs new file mode 100644 --- /dev/null +++ b/src/Zenity.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | A wrapper for 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 +-- +-- 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]}