xmobar 0.44.2 → 0.45
raw patch · 35 files changed
+1670/−1693 lines, 35 filesdep +cairodep +colourdep +pangodep ~X11-xft
Dependencies added: cairo, colour, pango
Dependency ranges changed: X11-xft
Files
- changelog.md +4/−0
- doc/compiling.org +88/−67
- doc/plugins.org +1/−1
- doc/quick-start.org +268/−170
- etc/xmobar.config +7/−7
- etc/xmobar.el +8/−5
- readme.org +25/−15
- src/Xmobar/Config/Parse.hs +27/−10
- src/Xmobar/Config/Template.hs +188/−0
- src/Xmobar/Config/Types.hs +58/−11
- src/Xmobar/Draw/Boxes.hs +67/−0
- src/Xmobar/Draw/Cairo.hs +190/−0
- src/Xmobar/Draw/Types.hs +36/−0
- src/Xmobar/Plugins/Kraken.hs +7/−7
- src/Xmobar/Plugins/Monitors/Batt.hs +56/−53
- src/Xmobar/Plugins/Monitors/Common/Output.hs +1/−1
- src/Xmobar/Plugins/Monitors/Common/Types.hs +1/−1
- src/Xmobar/Run/Parsers.hs +0/−234
- src/Xmobar/System/Environment.hs +3/−3
- src/Xmobar/Text/Loop.hs +1/−1
- src/Xmobar/Text/Output.hs +13/−11
- src/Xmobar/Text/Pango.hs +4/−2
- src/Xmobar/Text/Swaybar.hs +9/−9
- src/Xmobar/X11/Bitmap.hs +14/−13
- src/Xmobar/X11/CairoSurface.hsc +69/−0
- src/Xmobar/X11/ColorCache.hs +25/−75
- src/Xmobar/X11/Draw.hs +66/−215
- src/Xmobar/X11/Events.hs +9/−10
- src/Xmobar/X11/Loop.hs +120/−176
- src/Xmobar/X11/MinXft.hsc +0/−333
- src/Xmobar/X11/Text.hs +23/−95
- src/Xmobar/X11/Types.hs +13/−13
- src/Xmobar/X11/Window.hs +104/−131
- src/Xmobar/X11/XRender.hsc +138/−0
- xmobar.cabal +27/−24
changelog.md view
@@ -1,3 +1,7 @@+## Version 0.45 (October, 2022)++- New cairo/pango font drawing backend, substituting the direct X11/Xft one.+ ## Version 0.44.2 (August, 2022) - Documentation improvements.
doc/compiling.org view
@@ -1,97 +1,114 @@-#+title: Compiling xmobar from source+#+title: Compiling xmobar -If you don't have =cabal-install= installed, you can get xmobar's source-code in a variety of ways:+* Getting the source -- From [[http://hackage.haskell.org/package/xmobar/][Hackage]]. Just download the latest release from xmobar's hackage- page.+ If you don't have =cabal-install= installed, you can get xmobar's source+ code in a variety of ways: -- From [[http://codeberg.org/xmobar/xmobar/][Codeberg]]. There are also tarballs available for every tagged- release on [[https://codeberg.org/xmobar/xmobar/releases][Codeberg's releases page]]+ - From [[http://hackage.haskell.org/package/xmobar/][Hackage]]. Just download the latest release from xmobar's hackage+ page. -- From the bleeding edge repo. If you prefer to live dangerously, just- get the latest and greatest (and buggiest, I guess) using git:+ - From [[http://codeberg.org/xmobar/xmobar/][Codeberg]]. There are also tarballs available for every tagged+ release on [[https://codeberg.org/xmobar/xmobar/releases][Codeberg's releases page]] + - From the bleeding edge repo. If you prefer to live dangerously, just+ get the latest and greatest (and buggiest, I guess) using git:++ #+begin_src shell+ git clone git://codeberg.org/xmobar/xmobar+ #+end_src++* C library dependencies+ :PROPERTIES:+ :CUSTOM_ID: c-libraries+ :END:++ To build xmobar you will need the Xorg and Pango/Cairo C-libraries and+ headers installed in your system. In Debian and derivatives that's easily+ accomplished via+ #+begin_src shell- git clone git://codeberg.org/xmobar/xmobar+ apt-get install -y xorg-dev libxrandr-dev libpango1.0-dev #+end_src -If you have cabal installed, you can now use it from within xmobar's-source tree:+ and, optionally, in order to be able to build all available extensions and+ plugins: -#+begin_src shell- cabal install --flags="all_extensions"-#+end_src+ #+begin_src shell+ apt-get install -y libasound2-dev libxpm-dev libmpd-dev+ #+end_src -There is also a =stack.yaml= file that will allow you to install the-xmobar executable with+* Compilation using cabal -#+begin_src shell- stack install-#+end_src+ If you have cabal installed, you can now use it from within xmobar's source+ tree: -See the =stack.yaml= file for the enabled extensions. You can also pass-them to =stack= directly:+ #+begin_src shell+ cabal install --flags="all_extensions"+ #+end_src -#+begin_src shell- stack install --flag xmobar:all_extensions-#+end_src+* Compilation using stack -** Optional features- :PROPERTIES:- :CUSTOM_ID: optional-features- :END:+ There is also a =stack.yaml= file that will allow you to install the+ xmobar executable with - You can configure xmobar to include some optional plugins and- features, which are not compiled by default. To that end, you need- to add one or more flags to either the cabal install command or- the configure setup step, as shown in the examples above.+ #+begin_src shell+ stack install+ #+end_src - Extensions need additional libraries (listed below) that will be- automatically downloaded and installed if you're using cabal- install. Otherwise, you'll need to install them yourself.+ See the =stack.yaml= file for the enabled extensions. You can also pass+ them to =stack= directly: + #+begin_src shell+ stack install --flag xmobar:all_extensions+ #+end_src++* Compilation flags+ :PROPERTIES:+ :CUSTOM_ID: optional-features+ :END:++ You can configure xmobar to include some optional plugins and features,+ which are not compiled by default. To that end, you need to add one or more+ flags to either the cabal install command or the configure setup step.++ Extensions need additional Haskell packages (listed below) that will be+ automatically downloaded and installed if you're using cabal install.+ Otherwise, you'll need to install them yourself.++** Optional features+ - =with_dbus= Enables support for DBUS by making xmobar to publish a service on the session bus. Requires the [[http://hackage.haskell.org/package/dbus][dbus]] package. - =with_threaded= Uses GHC's threaded runtime. Use this option if xmobar enters a high-CPU regime right after starting. - - =with_utf8= UTF-8 support. Requires the [[http://hackage.haskell.org/package/utf8-string/][utf8-string]] package.-- - =with_xft= Antialiased fonts. Requires the [[http://hackage.haskell.org/package/X11-xft/][X11-xft]] package. This- option automatically enables UTF-8. To use XFT fonts you need to use- the =xft:= prefix in the =font= configuration option. For instance:+ - =with_xrender= Enables the main bar background alpha parameter. Requires+ the [[http://hackage.haskell.org/package/X11-xft/][X11-xft]] package. - #+begin_src haskell- font = "xft:Times New Roman-10:italic"- #+end_src+ - =with_xpm= Support for xpm image file format. This will allow loading+ .xpm files in =<icon>=. Requires the [[http://cgit.freedesktop.org/xorg/lib/libXpm][libXpm]] C library. - Or to have fallback fonts, just separate them by commas:+** Optional plugins - #+begin_src haskell- font = "xft:Open Sans:size=9,WenQuanYi Zen Hei:size=9"- #+end_src+ The following plugins and monitors are optional. You can enable them all+ at once using the flag ~all_extensions~, or one by one with the following+ flags: - =with_mpd= Enables support for the [[http://mpd.wikia.com/][MPD]] daemon. Requires the [[http://hackage.haskell.org/package/libmpd/][libmpd]] package. - - =with_mpris= Enables support for MPRIS v1/v2 protocol. Requires the- [[http://hackage.haskell.org/package/dbus][dbus]] and [[http://hackage.haskell.org/package/text][text]] packages.+ - =with_mpris= Enables support for MPRIS v1/v2 protocol used by the plugins+ of the same name. Requires the [[http://hackage.haskell.org/package/dbus][dbus]] and [[http://hackage.haskell.org/package/text][text]] packages. - - =with_inotify= Support for inotify in modern Linux kernels. This- option is needed for the MBox and Mail plugins to work. Requires the- [[http://hackage.haskell.org/package/hinotify/][hinotify]] package.+ - =with_inotify= Support for inotify in modern Linux kernels. This option is+ needed for the ~MBox~ and ~Mail~ plugins to work. Requires the [[http://hackage.haskell.org/package/hinotify/][hinotify]]+ package. - =with_nl80211= Support for wireless cards on Linux via nl80211 (all- upstream drivers). Enables the Wireless plugin. Requires [netlink] and- [cereal] packages.-- - =with_iwlib= Support for wireless cards via Wext ioctls (deprecated).- Enables the Wireless plugin. No Haskell library is required, but you- will need the [[http://www.hpl.hp.com/personal/Jean_Tourrilhes/Linux/Tools.html][iwlib]] C library and headers in your system (e.g.,- install =libiw-dev= in Debian-based systems or =wireless_tools= on- Arch Linux). Conflicts with =with_nl80211=.+ upstream drivers). Enables the ~Wireless~ plugin. Requires [[http://hackage.haskell.org/package/netlink][netlink]] and+ [[http://hackage.haskell.org/package/cereal/][cereal]] packages. - =with_alsa= Support for ALSA sound cards. Enables the Volume plugin. Requires the [[http://hackage.haskell.org/package/alsa-mixer][alsa-mixer]] package. To install the latter, you'll need@@ -101,13 +118,17 @@ - =with_datezone= Support for other timezones. Enables the DateZone plugin. Requires [[http://hackage.haskell.org/package/timezone-olson][timezone-olson]] and [[http://hackage.haskell.org/package/timezone-series][timezone-series]] package. - - =with_xpm= Support for xpm image file format. This will allow loading- .xpm files in =<icon>=. Requires the [[http://cgit.freedesktop.org/xorg/lib/libXpm][libXpm]] C library.+ - =with_weather= Support to display weather information. Enables Weather+ plugin. - - =with_uvmeter= Enables UVMeter plugin. The plugin shows UV data for+ Finally, the following flags enable plugins not included by ~all_extensions~:++ - =with_uvmeter= Enables the ~UVMeter~ plugin. The plugin shows UV data for Australia. - - =with_weather= Support to display weather information. Enables Weather- plugin.+ - =with_kraken= Enables the ~Kraken~ plugin. - - =all_extensions= Enables all the extensions above.+ - =with_iwlib= Support for wireless cards via Wext ioctls (deprecated).+ Enables the ~Wireless~ plugin. You will need the [[http://www.hpl.hp.com/personal/Jean_Tourrilhes/Linux/Tools.html][iwlib]] C library and+ headers in your system (e.g., install =libiw-dev= in Debian-based systems+ or =wireless_tools= on Arch Linux). Conflicts with =with_nl80211=.
doc/plugins.org view
@@ -390,7 +390,7 @@ - Default template: =Freq: <cpu0>GHz= - - This monitor requires acpi_cpufreq module to be loaded in kernel+ - This monitor requires the ~acpi_cpufreq~ module to be loaded in kernel - Example:
doc/quick-start.org view
@@ -20,7 +20,7 @@ This is the list of command line options (the output of =xmobar --help=): - #+begin_src shell+ #+begin_example Usage: xmobar [OPTION...] [FILE] Options: -h, -? --help This help@@ -38,182 +38,319 @@ -o --top Place xmobar at the top of the screen -b --bottom Place xmobar at the bottom of the screen -d --dock Don't override redirect from WM and function as a dock- -a alignsep --alignsep=alignsep Separators for left, center and right text- alignment. Default: '}{'- -s char --sepchar=char Character used to separate commands in- the output template. Default '%'- -t template --template=template Output template- -c commands --commands=commands List of commands to be executed- -C command --add-command=command Add to the list of commands to be executed- -x screen --screen=screen On which X screen number to start- -p position --position=position Specify position of xmobar. Same syntax as in config file- -T [format] --text[=format] Write output to stdout+ -a alignsep --alignsep=alignsep Separators for left, center and right text+ alignment. Default: '}{'+ -s char --sepchar=char Character used to separate commands in+ the output template. Default '%'+ -t template --template=template Output template+ -c commands --commands=commands List of commands to be executed+ -C command --add-command=command Add to the list of commands to be executed+ -x screen --screen=screen On which X screen number to start+ -p position --position=position Specify position of xmobar. Same syntax as in config file+ -T [format] --text[=format] Write output to stdout - Mail bug reports and suggestions to <mail@jao.io>- #+end_src+ Mail bug reports and suggestions to <mail@jao.io>+ #+end_example+ * Configuration Options :PROPERTIES: :CUSTOM_ID: configuration-options :END: ** Global options- Here are all the global configuration options that you can set within- the =Config= block in your configuration.+ Here are all the global options that you can set within the =Config= block in+ your configuration and will define the overall behaviour and looks of your+ bar. - - =font= Name of the font to be used. Use the =xft:= prefix for XFT- fonts.+*** Fonts+ :PROPERTIES:+ :CUSTOM_ID: fonts+ :END: - - =additionalFonts= Haskell-style list of fonts to be used with the- =fn=-template. Use the =xft:= prefix for XFT fonts. See also- =textOffsets= below. For example:+ The following configuration options control the fonts used by xmobar: - #+begin_src haskell- additionalFonts = [iconFont, altIconFont]- #+end_src+ - =font= Name, as a string, of the default font to use. - - =bgColor= Background color.+ - =additionalFonts= Haskell-style list of fonts to us with the+ =fn=-template. See also =textOffsets= below. For example: - - =fgColor= Default font color.+ #+begin_src haskell+ additionalFonts = [iconFont, altIconFont]+ #+end_src - - =alpha= The transparency. 0 is transparent, 255 is opaque.+ The global font is used by default when none of the others is specified+ using the ~<fn=n>...</fn>~ markup, with ~n~ a 1-based index in the+ ~additionalFonts~ array. So, for instance - - =position= Top, TopH, TopP, TopW, TopSize, Bottom, BottomH,- BottomP, BottomW, BottomSize or Static (with x, y, width and height).+ #+begin_src+ <fn=2>some text</fn>+ #+end_src - TopP and BottomP take 2 arguments: left padding and right padding.+ will use, in the configuration above, ~altIconFont~ to display "some text". - TopW and BottomW take 2 arguments: an alignment parameter (L for left,- C for centered, R for Right) and an integer for the percentage width- xmobar window will have in respect to the screen width.+ Font names use the [[https://docs.gtk.org/Pango/type_func.FontDescription.from_string.html][Pango format]]. Here are a few simple examples: - TopSize and BottomSize take 3 arguments: an alignment parameter, an- integer for the percentage width, and an integer for the minimum pixel- height that the xmobar window will have.+ #+begin_example+ DejaVu Sans Mono 10 - TopH and BottomH take one argument (Int) which adjusts the bar height.+ Iosevka Comfy Semi-Bold Italic 12 - For example:+ Noto Color Emoji 10+ #+end_example - #+begin_src haskell- position = TopH 30- #+end_src+ We start with a family name (DejaVu Sans Mono, Iosevka Comfy, etc.),+ followed by optional, space-separated /style options/ (Semi-Bold Italic in+ the second example above), and ending with a size, in points. - to make a 30 tall bar on the top, or+ There are many possible style options (if your font supports them). They+ can be - #+begin_src haskell- position = BottomH 30- #+end_src+ - *Plain styles*: Normal, Roman, Oblique, Italic.+ - *Variants*: Small-Caps, All-Small-Caps, Petite-Caps, All-Petite-Caps,+ Unicase, Title-Caps.+ - *Weights*: Thin, Ultra-Light, Extra-Light, Light, Semi-Ligh, Demi-Light,+ Book, Regular, Medium, Semi-Bold, Demi-Bold, Bold, Ultra-Bold,+ Extra-Bold, Heavy, Black, Ultra-Black, Extra-Black.+ - *Strectch values:* Thin, Ultra-Light, Extra-Light, Light, Semi-Light,+ Demi-Light, Book, Regular, Medium, Semi-Bold, Demi-Bold, Bold,+ Ultra-Bold, Extra-Bold, Heavy, Black, Ultra-Black, Extra-Black.+ - *Gravity values*: Not-Rotated, South, Upside-Down, North, Rotated-Left,+ East, Rotated-Right, West. - to make a 30 tall bar on the bottom of the screen.+ So you can add up to 5 style options per family: - #+begin_src haskell- position = BottomW C 75- #+end_src+ #+begin_example+ Monospace Italic All-Small-Caps Extra-Light Thin North 12+ #+end_example - to place xmobar at the bottom, centered with the 75% of the screen- width. Or+ It's also possible to specify a list of fonts, separating them by commas,+ so that they act as fallbacks when the preceding one is not able to display+ a given glyph. A bit confusingly, the styles and sizes come in reverse+ order after the families: - #+begin_src haskell- position = BottomP 120 0- #+end_src+ #+begin_example+ Family 1, Family 2 Styles 2 Size 2, Styles 1 Size 1+ #+end_example - to place xmobar at the bottom, with 120 pixel indent of the left. Or+ For instance you could have: - #+begin_src haskell- position = Static { xpos = 0 , ypos = 0, width = 1024, height = 15 }- #+end_src+ #+begin_example+ Souce Code Pro, Noto Color Emoji Regular 12, Semi-Bold 10+ #+end_example - or+ to use Source Code Pro Semi-Bold 10 when possible, and fall back to Noto+ Color Emoji Regular 12 for characters that the former cannot display. - #+begin_src haskell- position = Top- #+end_src+*** Colors - - =textOffset= The vertical offset, in pixels, for the text baseline. If- negative or not given, xmobar will try to center text vertically.+ - =bgColor= Background color. - - =textOffsets= A list of vertical offsets, in pixels, for the text- baseline, to be used with the each of the fonts in =additionalFonts=- (if any). If negative or not given, xmobar will try to center text- vertically for that font.+ - =fgColor= Default font color. - - =iconOffset= The vertical offset, in pixels, for icons bottom line. If- negative or not given, xmobar will try to center icons vertically.+ - =alpha= The transparency. 0 is transparent, 255 is opaque. - - =lowerOnStart= When True the window is sent the bottom of the window- stack initially.+*** Vertical offsets - - =hideOnStart= When set to True the window is initially not mapped,- i.e. hidden. It then can be toggled manually (for example using the- dbus interface) or automatically (by a plugin) to make it reappear.+ By default, all text and icons in the bar will be vertically centered+ according to the configured height of the bar. You can override that+ behaviour with the following options: - - =allDesktops= When set to True (the default), xmobar will tell the- window manager explicitly to be shown in all desktops, by setting- =_NET_WM_DESKTOP= to 0xffffffff.+ - =textOffset= The vertical offset, in pixels, for the text baseline. If+ negative or not given, xmobar will try to center text vertically. - - =overrideRedirect= If you're running xmobar in a tiling window- manager, you might need to set this option to =False= so that it- behaves as a docked application. Defaults to =True=.+ - =textOffsets= A list of vertical offsets, in pixels, for the text+ baseline, to be used with the each of the fonts in =additionalFonts=+ (if any). If negative or not given, xmobar will try to center text+ vertically for that font. - - =pickBroadest= When multiple displays are available, xmobar will- choose by default the first one to place itself. With this flag set to- =True= (the default is =False=) it will choose the broadest one- instead.+ - =iconOffset= The vertical offset, in pixels, for icons bottom line. If+ negative or not given, xmobar will try to center icons vertically. - - =persistent= When True the window status is fixed i.e. hiding or- revealing is not possible. This option can be toggled at runtime.- Defaults to False.+*** Borders - - =border= TopB, TopBM, BottomB, BottomBM, FullB, FullBM or NoBorder- (default).+ - =border= TopB, TopBM, BottomB, BottomBM, FullB, FullBM or NoBorder+ (default). - TopB, BottomB, FullB take no arguments, and request drawing a border- at the top, bottom or around xmobar's window, respectively.+ TopB, BottomB, FullB take no arguments, and request drawing a border+ at the top, bottom or around xmobar's window, respectively. - TopBM, BottomBM, FullBM take an integer argument, which is the margin,- in pixels, between the border of the window and the drawn border.+ TopBM, BottomBM, FullBM take an integer argument, which is the margin,+ in pixels, between the border of the window and the drawn border. - - =borderColor= Border color.+ - =borderColor= Border color. - - =borderWidth= Border width in pixels.+ - =borderWidth= Border width in pixels. - - =iconRoot= Root folder where icons are stored. For =<icon=path/>= if- path start with =/=, =./= or =../= it is interpreted as it is.- Otherwise it will have+ - =iconRoot= Root folder where icons are stored. For =<icon=path/>= if+ path start with =/=, =./= or =../= it is interpreted as it is.+ Otherwise it will have - #+begin_src haskell- iconRoot ++ "/"- #+end_src+ #+begin_src haskell+ iconRoot ++ "/"+ #+end_src - prepended to it. Default is =.=.+ prepended to it. Default is =.=. - - =commands= For setting the options of the programs to run (optional).+*** Bar position - - =sepChar= The character to be used for indicating commands in the- output template (default '%').+ - =position= Top, TopH, TopP, TopW, TopSize, Bottom, BottomH,+ BottomP, BottomW, BottomSize or Static (with x, y, width and height). - - =alignSep= a 2 character string for aligning text in the output- template. The text before the first character will be align to left,- the text in between the 2 characters will be centered, and the text- after the second character will be align to the right.+ TopP and BottomP take 2 arguments: left padding and right padding. - - =template= The output template.+ TopW and BottomW take 2 arguments: an alignment parameter (L for left,+ C for centered, R for Right) and an integer for the percentage width+ xmobar window will have in respect to the screen width. - - =wmClass= The value for the window's X11 ~WM_CLASS~ property. Defaults- to "xmobar".+ TopSize and BottomSize take 3 arguments: an alignment parameter, an+ integer for the percentage width, and an integer for the minimum pixel+ height that the xmobar window will have. - - =wmName= The value for the window's X11 ~WM_NAME~ property. Defaults to- "xmobar".+ TopH and BottomH take one argument (Int) which adjusts the bar height. - - =textOutput= When True, instead of running as an X11 application,- write output to stdout, with optional color escape sequences. In- this mode, icon and action specifications are ignored. Default is- False.+ For example: - - =textOutputFormat= Plain, Ansi or Pango, to emit, when in text- mode, escape color sequences using ANSI controls (for terminals) or- pango markup. Default is Plain.+ #+begin_src haskell+ position = TopH 30+ #+end_src + to make a 30 tall bar on the top, or++ #+begin_src haskell+ position = BottomH 30+ #+end_src++ to make a 30 tall bar on the bottom of the screen.++ #+begin_src haskell+ position = BottomW C 75+ #+end_src++ to place xmobar at the bottom, centered with the 75% of the screen+ width. Or++ #+begin_src haskell+ position = BottomP 120 0+ #+end_src++ to place xmobar at the bottom, with 120 pixel indent of the left. Or++ #+begin_src haskell+ position = Static { xpos = 0 , ypos = 0, width = 1024, height = 15 }+ #+end_src++ or++ #+begin_src haskell+ position = Top+ #+end_src++ - =lowerOnStart= When True the window is sent the bottom of the window+ stack initially.++ - =hideOnStart= When set to True the window is initially not mapped,+ i.e. hidden. It then can be toggled manually (for example using the+ dbus interface) or automatically (by a plugin) to make it reappear.++ - =allDesktops= When set to True (the default), xmobar will tell the+ window manager explicitly to be shown in all desktops, by setting+ =_NET_WM_DESKTOP= to 0xffffffff.++ - =overrideRedirect= If you're running xmobar in a tiling window+ manager, you might need to set this option to =False= so that it+ behaves as a docked application. Defaults to =True=.++ - =pickBroadest= When multiple displays are available, xmobar will+ choose by default the first one to place itself. With this flag set to+ =True= (the default is =False=) it will choose the broadest one+ instead.++ - =persistent= When True the window status is fixed i.e. hiding or+ revealing is not possible. This option can be toggled at runtime.+ Defaults to False.++ - =wmClass= The value for the window's X11 ~WM_CLASS~ property. Defaults+ to "xmobar".++ - =wmName= The value for the window's X11 ~WM_NAME~ property. Defaults to+ "xmobar".++*** Text output++ - =textOutput= When True, instead of running as an X11 application,+ write output to stdout, with optional color escape sequences. In+ this mode, icon and action specifications are ignored. Default is+ False.++ - =textOutputFormat= Plain, Ansi or Pango, to emit, when in text+ mode, escape color sequences using ANSI controls (for terminals) or+ pango markup. Default is Plain.++*** Commands and monitors++ - =commands= The list of monitors and plugins to run, together with their+ individual configurations. The [[./plugins.org][plugin documentation]] details all the+ available monitors, and you can also create new ones using Haskell. See+ [[#commands-list][The commands list]] section below for more.++ - =sepChar= The character to be used for indicating commands in the+ output template (default '%').++ - =alignSep= a 2 character string for aligning text in the output+ template. The text before the first character will be align to left,+ the text in between the 2 characters will be centered, and the text+ after the second character will be align to the right.++ - =template= The output template: a string telling xmobar how to display the+ outputs of all the =commands= above. See [[#output-template][the next section]] for a full+ description.++** The =commands= list+ :PROPERTIES:+ :CUSTOM_ID: commands-list+ :END:++ The =commands= configuration option is a list of commands information+ and arguments to be used by xmobar when parsing the output template.+ Each member of the list consists in a command prefixed by the =Run=+ keyword. Each command has arguments to control the way xmobar is going+ to execute it.++ The options consist in a list of commands separated by a comma and enclosed+ by square parenthesis.++ Example:++ #+begin_src haskell+ [Run Memory ["-t","Mem: <usedratio>%"] 10, Run Swap [] 10]+ #+end_src++ to run the Memory monitor plugin with the specified template, and the+ swap monitor plugin, with default options, every second. And here's an+ example of a template for the commands above using an icon:++ #+begin_src haskell+ template = "<icon=/home/jao/.xmobar/mem.xbm/><memory> <swap>"+ #+end_src++ This example will run "xclock" command when date is clicked:++ #+begin_src haskell+ template = "<action=`xclock`>%date%</action>"+ #+end_src++ The only internal available command is =Com= (see below Executing+ External Commands). All other commands are provided by plugins. xmobar+ comes with some plugins, providing a set of system monitors, a standard+ input reader, an Unix named pipe reader, a configurable date plugin, and+ much more: we list all available plugins below.++ Other commands can be created as plugins with the Plugin infrastructure.+ See below.+ ** The output =template=+ :PROPERTIES:+ :CUSTOM_ID: output-template+ :END: The output template is how xmobar will end up printing all of your configured commands. It must contain at least one command. Xmobar@@ -237,10 +374,11 @@ contain markups to change the characters' color. - =<fc=#FF0000>string</fc>= will print =string= with =#FF0000= color- (red). =<fc=#FF0000,#000000>string</fc>= will print =string= in red- with a black background (=#000000=). Background absolute offsets can- be specified for XFT fonts. =<fc=#FF0000,#000000:0>string</fc>= will- have a background matching the bar's height.+ (red). =<fc=#FF0000,#000000>string</fc>= will print =string= in red with a+ black background (=#000000=). Background absolute offsets can be specified+ for fonts. =<fc=#FF0000,#000000:0>string</fc>= will have a background+ matching the bar's height. It is also possible to specify the colour's+ opacity, with two additional hex digits (e.g. #FF00000aa). - =<fn=1>string</fn>= will print =string= with the first font from =additionalFonts=. The index =0= corresponds to the standard font.@@ -291,9 +429,9 @@ foreground color. The =box= tag accepts several optional arguments to tailor its looks: - - =type=: =Top=, =Bottom=, =VBoth= (a single line above or below- string, or both), =Left=, =Right=, =HBoth= (single vertical lines),- =Full= (a rectangle, the default).+ - =type=: =Top=, =Bottom=, =VBoth= (a single line above or below string, or+ both), =Left=, =Right=, =HBoth= (single vertical lines), =Full= (a rectangle,+ the default). - =color=: the color of the box lines. - =width=: the width of the box lines. - =offset=: an alignment char (L, C or R) followed by the amount of@@ -320,7 +458,7 @@ types, colors and widths are valid too, but margins and offsets are ignored. -*** Bitmap Icons+*** Bitmap icons It's possible to insert in the global templates icon directives of the form:@@ -345,7 +483,7 @@ Icons are ignored when xmobar is run in text output mode. -*** Action Directives+*** Using the mouse: Action directives It's also possible to use action directives of the form: @@ -359,46 +497,6 @@ Actions work also when xmobar is run in text mode and used as the status command of swaybar.--** The =commands= configuration option-- The =commands= configuration option is a list of commands information- and arguments to be used by xmobar when parsing the output template.- Each member of the list consists in a command prefixed by the =Run=- keyword. Each command has arguments to control the way xmobar is going- to execute it.-- The option consists in a list of commands separated by a comma and- enclosed by square parenthesis.-- Example:-- #+begin_src haskell- [Run Memory ["-t","Mem: <usedratio>%"] 10, Run Swap [] 10]- #+end_src-- to run the Memory monitor plugin with the specified template, and the- swap monitor plugin, with default options, every second. And here's an- example of a template for the commands above using an icon:-- #+begin_src haskell- template = "<icon=/home/jao/.xmobar/mem.xbm/><memory> <swap>"- #+end_src-- This example will run "xclock" command when date is clicked:-- #+begin_src haskell- template = "<action=`xclock`>%date%</action>"- #+end_src-- The only internal available command is =Com= (see below Executing- External Commands). All other commands are provided by plugins. xmobar- comes with some plugins, providing a set of system monitors, a standard- input reader, an Unix named pipe reader, a configurable date plugin, and- much more: we list all available plugins below.-- Other commands can be created as plugins with the Plugin infrastructure.- See below. * Runtime behaviour ** Running xmobar in text mode
etc/xmobar.config view
@@ -1,10 +1,10 @@-Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"- , additionalFonts = []+Config { font = "DejaVu Sans Mono 9"+ , additionalFonts = ["DejaVu Sans Mono italic 9"] , borderColor = "black"- , border = TopB+ , border = FullB , bgColor = "black"- , fgColor = "grey"- , alpha = 255+ , fgColor = "whitesmoke"+ , alpha = 128 , position = Top , textOffset = -1 , iconOffset = -1@@ -34,6 +34,6 @@ ] , sepChar = "%" , alignSep = "}{"- , template = "%cpu% | %memory% * %swap% | %eth0% - %eth1% }\- \{ <fc=#ee9a00>%date%</fc>| %EGPF% | %uname%"+ , template = "%cpu% | <box>%memory% * %swap%</box> | %eth0% - %eth1% }\+ \{ <fc=#ee9a00><fn=1>%date%</fn></fc>| %EGPF% | %uname%" }
etc/xmobar.el view
@@ -54,7 +54,7 @@ :type 'string) (defcustom xmobar-tab-bar-format- '(xmobar-left-string tab-bar-format-align-right xmobar-right-string)+ '(xmobar-left-string xmobar-elastic-space xmobar-right-string) "Format for the tab bar when `xmobar-tab-bar' is t." :type 'list) @@ -72,10 +72,12 @@ (if (featurep 'xterm-color) #'xterm-color-filter #'ansi-color-apply)) (defvar xmobar--old-tab-format tab-bar-format)+(defvar xmobar--len 0) (defun xmobar-string () xmobar-string) (defun xmobar-right-string () xmobar-string) (defun xmobar-left-string () xmobar--left-string)+(defun xmobar-elastic-space () (make-string (- (frame-width) xmobar--len 3) ? )) ;;;###autoload (define-minor-mode xmobar-mode@@ -90,8 +92,7 @@ (tab-bar-mode 1)) (or global-mode-string (setq global-mode-string '(""))) (unless (memq 'xmobar-string global-mode-string)- (setq global-mode-string- (append global-mode-string '(xmobar-string)))))+ (add-to-list 'global-mode-string 'xmobar-string t))) (xmobar--start)) (when xmobar-tab-bar (setq tab-bar-format xmobar--old-tab-format)))) @@ -101,7 +102,9 @@ (let* ((str (funcall xmobar--colorize-fn update)) (strs (and xmobar-tab-split (split-string str xmobar-tab-split)))) (setq xmobar-string (if strs (cadr strs) str)- xmobar--left-string (or (car strs) "")))+ xmobar--left-string (or (car strs) "")+ xmobar--len (+ (string-width xmobar--left-string)+ (string-width xmobar-string)))) (force-mode-line-update t))) (defun xmobar--process-filter (proc string)@@ -115,7 +118,7 @@ (insert string) (set-marker (process-mark proc) (point))) (when (string-match-p "\n$" string)- (xmobar--update (buffer-string))+ (xmobar--update (buffer-substring (point-min) (- (point-max) 1))) (delete-region (point-min) (point-max))))))) (defun xmobar--process-sentinel (proc status)
readme.org view
@@ -29,6 +29,17 @@ Check [[./changelog.md][the change log]] for our release history. We also have an IRC channel, ~#xmobar~, at [[ircs://irc.libera.chat][Libera]]. +* Breaking news++ - Starting with version 0.45 we use cairo/pango as our drawing engine+ (instead of plain X11/Xft). From a user's point of view, that change+ should be mostly transparent, except for the facts that it's allowed+ fixing quite a few bugs and that your /font names/ in your configuration, if+ you used ~xft~ ones, might need to be adapted to Pango's syntax: please see+ [[./doc/quick-start.org#fonts][this section of the documentation]] for all the details. If you're+ compiling your own xmobar, there's a new dependency on libpango (see+ [[./doc/compiling.org#c-libraries][C library dependencies]]).+ * Installation :PROPERTIES: :CUSTOM_ID: installation@@ -64,29 +75,28 @@ emerge --ask xmobar #+end_src -** Using cabal-install+** Using cabal or stack - Xmobar is available from [[http://hackage.haskell.org/package/xmobar/][Hackage]], and you can install it using- =cabal-install=:+ Xmobar is available from [[http://hackage.haskell.org/package/xmobar/][Hackage]], and you can compile and install it using+ =cabal-install=, making sure the [[doc/compiling.org#c-libraries][required C libraries]] are in place. For a+ full build with all available extensions: #+begin_src shell- cabal install xmobar+ # required C librarises+ apt-get install xorg-dev libxrandr-dev libpango1.0-dev+ # optional C libraries for additional plugins+ apt-get install libasound2-dev libxpm-dev libmpd-dev++ cabal install xmobar -fall_extensions #+end_src - Starting with version 0.35.1, xmobar now requires at least GHC version+ Starting with version 0.35.1, xmobar requires at least GHC version 8.4.x. to build. See [[https://codeberg.org/xmobar/xmobar/issues/461][this issue]] for more information. See [[file:doc/compiling.org#optional-features][here]] for a list of optional compilation flags that will enable some- optional plugins. For instance, to install xmobar with all the bells and- whistles (this is probably what you want), use:-- #+begin_src shell- cabal install xmobar --flags="all_extensions"- #+end_src--** From source+ optional plugins. - See [[file:doc/compiling.org][compiling]].+ See [[file:doc/compiling.org][compiling]] for full compilation instructions starting from source. * Running xmobar ** Running xmobar with a configuration file@@ -158,7 +168,7 @@ Janoušek, Ada Joule, Spencer Janssen, Roman Joost, Pavel Kalugin, Jochen Keil, Sam Kirby, Lennart Kolmodin, Krzysztof Kosciuszkiewicz, Dmitry Kurochkin, Todd Lunter, Vanessa McHale, Robert J. Macomber,- Dmitry Malikov, David McLean, Joan MIlev, Marcin Mikołajczyk, Dino+ Dmitry Malikov, David McLean, Joan Milev, Marcin Mikołajczyk, Dino Morelli, Tony Morris, Eric Mrak, Thiago Negri, Edward O'Callaghan, Svein Ove, Martin Perner, Jens Petersen, Alexander Polakov, Sibi Prabakaran, Pavan Rikhi, Petr Rockai, Andrew Emmanuel Rosa,
src/Xmobar/Config/Parse.hs view
@@ -16,7 +16,11 @@ ------------------------------------------------------------------------------ -module Xmobar.Config.Parse(readConfig, parseConfig) where+module Xmobar.Config.Parse(readConfig+ , parseConfig+ , indexedFont+ , indexedOffset+ , colorComponents) where import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Number (int)@@ -26,17 +30,16 @@ import Xmobar.Config.Types -#ifdef XFT import qualified System.IO as S (readFile)-#endif -readFileSafe :: FilePath -> IO String-#ifdef XFT-readFileSafe = S.readFile-#else-readFileSafe = readFile-#endif+-- | Splits a colors string into its two components+colorComponents :: Config -> String -> (String, String)+colorComponents conf c =+ case break (==',') c of+ (f,',':b) -> (f, b)+ (f, _) -> (f, bgColor conf) + stripComments :: String -> String stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines@@ -182,4 +185,18 @@ -- parsed. readConfig :: Config -> FilePath -> IO (Either ParseError (Config,[String])) readConfig defaultConfig f =- liftIO (readFileSafe f) <&> parseConfig defaultConfig+ liftIO (S.readFile f) <&> parseConfig defaultConfig++-- | Extracts from a configuration the additional font at the corresponding index.+-- Returns the default font if not present.+indexedFont :: Config -> FontIndex -> String+indexedFont config idx =+ if idx < 1 || idx > length (additionalFonts config)+ then font config else additionalFonts config !! (idx - 1)++-- | Extracts from a configuration the offset at the corresponding index.+-- Returns the default offset if not present.+indexedOffset :: Config -> FontIndex -> Int+indexedOffset config idx =+ if idx < 1 || idx > length (textOffsets config)+ then textOffset config else textOffsets config !! (idx - 1)
+ src/Xmobar/Config/Template.hs view
@@ -0,0 +1,188 @@+------------------------------------------------------------------------------+-- |+-- Module: Xmobar.Config.Template+-- Copyright: (c) 2022 jao+-- License: BSD3-style (see LICENSE)+--+-- Maintainer: mail@jao.io+-- Stability: unstable+-- Portability: portable+-- Created: Fri Sep 30, 2022 06:33+--+--+-- Parsing template strings+--+------------------------------------------------------------------------------+++module Xmobar.Config.Template (parseString) where++import Data.Maybe (fromMaybe)+import qualified Control.Monad as CM++import Text.Parsec ((<|>))+import Text.Read (readMaybe)++import qualified Text.Parsec as P+import qualified Text.Parsec.Combinator as C++import Text.ParserCombinators.Parsec (Parser)++import qualified Xmobar.Config.Types as T++type Context = (T.TextRenderInfo, T.FontIndex, Maybe [T.Action])++retSegment :: Context -> T.Widget -> Parser [T.Segment]+retSegment (i, idx, as) widget = return [(widget, i, idx, as)]++-- | Run the template string parser for the given config, producing a list of+-- drawable segment specifications.+parseString :: T.Config -> String -> [T.Segment]+parseString c s =+ case P.parse (stringParser ci) "" s of+ Left _ -> [(T.Text $ "Could not parse string: " ++ s, ti, 0, Nothing)]+ Right x -> concat x+ where ci = (ti , 0, Nothing)+ ti = T.TextRenderInfo (T.fgColor c) 0 0 []++-- Top level parser reading the full template string+stringParser :: Context -> Parser [[T.Segment]]+stringParser c = C.manyTill (allParsers c) C.eof++allParsers :: Context -> Parser [T.Segment]+allParsers c = C.choice (textParser c:map (\f -> P.try (f c)) parsers)+ where parsers = [ iconParser, hspaceParser, rawParser, actionParser+ , fontParser, boxParser, colorParser ]++-- Wrapper for notFollowedBy that returns the result of the first parser.+-- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy+-- accepts only parsers with return type Char.+notFollowedBy' :: Parser a -> Parser b -> Parser a+notFollowedBy' p e = do x <- p+ C.notFollowedBy $ P.try (e >> return '*')+ return x++-- Parse a maximal string without markup+textParser :: Context -> Parser [T.Segment]+textParser c =+ C.many1 (P.noneOf "<" <|> P.try (notFollowedBy' (P.char '<') suffixes))+ >>= retSegment c . T.Text+ where suffixes = C.choice $ map (P.try . P.string)+ [ "icon=" , "hspace=", "raw="+ , "action=", "/action>", "fn=", "/fn>"+ , "box", "/box>", "fc=", "/fc>" ]++-- Parse a "raw" tag, which we use to prevent other tags from creeping in.+-- The format here is net-string-esque: a literal "<raw=" followed by a string+-- of digits (base 10) denoting the length of the raw string, a literal ":" as+-- digit-string-terminator, the raw string itself, and then a literal "/>".+rawParser :: Context -> Parser [T.Segment]+rawParser c = do+ P.string "<raw="+ lenstr <- C.many1 P.digit+ P.char ':'+ case reads lenstr of+ [(len,[])] -> do+ CM.guard ((len :: Integer) <= fromIntegral (maxBound :: Int))+ s <- C.count (fromIntegral len) P.anyChar+ P.string "/>"+ retSegment c (T.Text s)+ _ -> CM.mzero++iconParser :: Context -> Parser [T.Segment]+iconParser c = do+ P.string "<icon="+ i <- C.manyTill (P.noneOf ">") (P.try (P.string "/>"))+ retSegment c (T.Icon i)++hspaceParser :: Context -> Parser [T.Segment]+hspaceParser c = do+ P.string "<hspace="+ pVal <- C.manyTill P.digit (P.try (P.string "/>"))+ retSegment c (T.Hspace (fromMaybe 0 $ readMaybe pVal))++actionParser :: Context -> Parser [T.Segment]+actionParser (ti, fi, act) = do+ P.string "<action="+ command <- C.between (P.char '`') (P.char '`') (C.many1 (P.noneOf "`"))+ <|> C.many1 (P.noneOf ">")+ buttons <- (P.char '>' >> return "1") <|> (P.space >> P.spaces >>+ C.between (P.string "button=") (P.string ">") (C.many1 (P.oneOf "12345")))+ let a = T.Spawn (toButtons buttons) command+ a' = case act of+ Nothing -> Just [a]+ Just act' -> Just $ a : act'+ s <- C.manyTill (allParsers (ti, fi, a')) (P.try $ P.string "</action>")+ return (concat s)++toButtons :: String -> [T.Button]+toButtons = map (\x -> read [x])++colorParser :: Context -> Parser [T.Segment]+colorParser (T.TextRenderInfo _ _ _ bs, fidx, a) = do+ c <- C.between (P.string "<fc=") (P.string ">") (C.many1 colorc)+ let colorParts = break (==':') c+ let (ot,ob) = case break (==',') (drop 1 $ snd colorParts) of+ (top,',':btm) -> (top, btm)+ (top, _) -> (top, top)+ tri = T.TextRenderInfo (fst colorParts)+ (fromMaybe (-1) $ readMaybe ot)+ (fromMaybe (-1) $ readMaybe ob)+ bs+ s <- C.manyTill (allParsers (tri, fidx, a)) (P.try $ P.string "</fc>")+ return (concat s)+ where colorc = P.alphaNum <|> P.oneOf ",:#"++boxParser :: Context -> Parser [T.Segment]+boxParser (T.TextRenderInfo cs ot ob bs, f, a) = do+ c <- C.between (P.string "<box") (P.string ">")+ (C.option "" (C.many1 (P.alphaNum <|> P.oneOf "= #,")))+ let b = T.Box T.BBFull (T.BoxOffset T.C 0) 1 cs (T.BoxMargins 0 0 0 0)+ let g = boxReader b (words c)+ s <- C.manyTill+ (allParsers (T.TextRenderInfo cs ot ob (g : bs), f, a))+ (P.try $ P.string "</box>")+ return (concat s)++boxReader :: T.Box -> [String] -> T.Box+boxReader b [] = b+boxReader b (x:xs) = boxReader (boxParamReader b param val) xs+ where (param,val) = case break (=='=') x of+ (p,'=':v) -> (p, v)+ (p, _) -> (p, "")++boxParamReader :: T.Box -> String -> String -> T.Box+boxParamReader b _ "" = b++boxParamReader (T.Box bb off lw fc mgs) "type" val =+ T.Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs++boxParamReader (T.Box bb (T.BoxOffset alg off) lw fc mgs) "offset" (a:o) =+ T.Box bb (T.BoxOffset align offset) lw fc mgs+ where offset = fromMaybe off $ readMaybe o+ align = fromMaybe alg $ readMaybe [a]++boxParamReader (T.Box bb off lw fc mgs) "width" val =+ T.Box bb off (fromMaybe lw $ readMaybe val) fc mgs++boxParamReader (T.Box bb off lw _ mgs) "color" val =+ T.Box bb off lw val mgs++boxParamReader (T.Box bb off lw fc mgs@(T.BoxMargins mt mr mb ml)) ('m':pos) v =+ let mgs' = case pos of+ "t" -> T.BoxMargins (maybeVal mt) mr mb ml+ "r" -> T.BoxMargins mt (maybeVal mr) mb ml+ "b" -> T.BoxMargins mt mr (maybeVal mb) ml+ "l" -> T.BoxMargins mt mr mb (maybeVal ml)+ _ -> mgs+ maybeVal d = fromMaybe d (readMaybe v)+ in T.Box bb off lw fc mgs'++boxParamReader b _ _ = b++fontParser :: Context -> Parser [T.Segment]+fontParser (i, _, a) = do+ f <- C.between (P.string "<fn=") (P.string ">") (C.many1 P.digit)+ s <- C.manyTill (allParsers (i, fromMaybe 0 $ readMaybe f, a))+ (P.try $ P.string "</fn>")+ return (concat s)
src/Xmobar/Config/Types.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Module : Xmobar.Config+-- Module : Xmobar.Config.Types -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) --@@ -13,17 +13,30 @@ ----------------------------------------------------------------------------- module Xmobar.Config.Types- ( -- * Configuration- -- $config- Config (..)+ ( Config (..) , XPosition (..), Align (..), Border (..), TextOutputFormat (..)+ , Segment+ , FontIndex+ , Box(..)+ , BoxBorder(..)+ , BoxOffset(..)+ , BoxMargins(..)+ , TextRenderInfo(..)+ , Widget(..) , SignalChan (..)+ , Action (..)+ , Button ) where import qualified Control.Concurrent.STM as STM-import Xmobar.Run.Runnable (Runnable(..))-import Xmobar.System.Signal (SignalType)+import qualified Xmobar.Run.Runnable as R+import qualified Xmobar.System.Signal as S +import Data.Int (Int32)+import Foreign.C.Types (CInt)++import Xmobar.Run.Actions (Action (..), Button)+ -- $config -- Configuration data type @@ -37,7 +50,8 @@ , fgColor :: String -- ^ Default font color , position :: XPosition -- ^ Top Bottom or Static , textOutput :: Bool -- ^ Write data to stdout instead of X- , textOutputFormat :: TextOutputFormat -- ^ Which color format to use for stdout: Ansi or Pango+ , textOutputFormat :: TextOutputFormat+ -- ^ Which color format to use for stdout: Ansi or Pango , textOffset :: Int -- ^ Offset from top of window for text , textOffsets :: [Int] -- ^ List of offsets for additionalFonts , iconOffset :: Int -- ^ Offset from top of window for icons@@ -59,8 +73,8 @@ , persistent :: Bool -- ^ Whether automatic hiding should -- be enabled or disabled , iconRoot :: FilePath -- ^ Root folder for icons- , commands :: [Runnable] -- ^ For setting the command,- -- the command arguments+ , commands :: [R.Runnable] -- ^ For setting the command,+ -- the command arguments -- and refresh rate for the programs -- to run (optional) , sepChar :: String -- ^ The character to be used for indicating@@ -70,7 +84,7 @@ -- right text alignment , template :: String -- ^ The output template , verbose :: Bool -- ^ Emit additional debug messages- , signal :: SignalChan -- ^ The signal channel used to send signals to xmobar+ , signal :: SignalChan -- ^ Channel to send signals to xmobar } deriving (Read, Show) data XPosition = Top@@ -100,11 +114,44 @@ data TextOutputFormat = Plain | Ansi | Pango | Swaybar deriving (Read, Show, Eq) -newtype SignalChan = SignalChan { unSignalChan :: Maybe (STM.TMVar SignalType) }+type FontIndex = Int +newtype SignalChan = SignalChan {unSignalChan :: Maybe (STM.TMVar S.SignalType)}+ instance Read SignalChan where readsPrec _ _ = fail "SignalChan is not readable from a String" instance Show SignalChan where show (SignalChan (Just _)) = "SignalChan (Just <tmvar>)" show (SignalChan Nothing) = "SignalChan Nothing"++data Widget = Icon String | Text String | Hspace Int32 deriving Show++data BoxOffset = BoxOffset Align Int32 deriving (Eq, Show)++-- margins: Top, Right, Bottom, Left+data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving (Eq, Show)++data BoxBorder = BBTop+ | BBBottom+ | BBVBoth+ | BBLeft+ | BBRight+ | BBHBoth+ | BBFull+ deriving (Read, Eq, Show)++data Box = Box { bBorder :: BoxBorder+ , bOffset :: BoxOffset+ , bWidth :: CInt+ , bColor :: String+ , bMargins :: BoxMargins+ } deriving (Eq, Show)++data TextRenderInfo = TextRenderInfo { tColorsString :: String+ , tBgTopOffset :: Int32+ , tBgBottomOffset :: Int32+ , tBoxes :: [Box]+ } deriving Show++type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action])
+ src/Xmobar/Draw/Boxes.hs view
@@ -0,0 +1,67 @@+------------------------------------------------------------------------------+-- |+-- Module: Xmobar.X11.Boxes+-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz+-- License: BSD3-style (see LICENSE)+--+-- Maintainer: jao@gnu.org+-- Stability: unstable+-- Portability: unportable+-- Start date: Fri Sep 16, 2022 04:01+--+-- Borders and boxes+--+------------------------------------------------------------------------------++module Xmobar.Draw.Boxes (Line, boxLines, BoxRect, borderRect) where++import qualified Xmobar.Config.Types as T++type Line = (Double, Double, Double, Double)+type BoxRect = (Double, Double, Double, Double)++-- | Computes the coordinates of a list of lines representing a Box.+-- The Box is to be positioned between x0 and x1, with height ht, and drawn+-- with line width lw. The returned lists are coordinates of the beginning+-- and end of each line.+boxLines :: T.Box -> Double -> Double -> Double -> [Line]+boxLines (T.Box bd offset lw _ margins) ht x0 x1 =+ case bd of+ T.BBTop -> [rtop]+ T.BBBottom -> [rbot]+ T.BBVBoth -> [rtop, rbot]+ T.BBLeft -> [rleft]+ T.BBRight -> [rright]+ T.BBHBoth -> [rleft, rright]+ T.BBFull -> [rtop, rbot, rleft, rright]+ where+ (T.BoxMargins top right bot left) = margins+ (T.BoxOffset align m) = offset+ ma = fromIntegral m+ (p0, p1) = case align of+ T.L -> (0, -ma)+ T.C -> (ma, -ma)+ T.R -> (ma, 0)+ lc = fromIntegral lw / 2+ [mt, mr, mb, ml] = map fromIntegral [top, right, bot, left]+ xmin = x0 - ml - lc+ xmax = x1 + mr + lc+ ymin = mt + lc+ ymax = ht - mb - lc+ rtop = (xmin + p0, ymin, xmax + p1, ymin)+ rbot = (xmin + p0, ymax, xmax + p1, ymax)+ rleft = (xmin, ymin + p0, xmin, ymax + p1)+ rright = (xmax, ymin + p0, xmax, ymax + p1)++-- | Computes the rectangle (x, y, width, height) for the given Border.+borderRect :: T.Border -> Double -> Double -> BoxRect+borderRect bdr w h =+ case bdr of+ T.TopB -> (0, 0, w - 1, 0)+ T.BottomB -> (0, h - 1, w - 1, 0)+ T.FullB -> (0, 0, w - 1, h - 1)+ T.TopBM m -> (0, fi m, w - 1, 0)+ T.BottomBM m -> (0, h - fi m, w - 1, 0)+ T.FullBM m -> (fi m, fi m, w - 2 * fi m, h - 2 * fi m)+ T.NoBorder -> (-1, -1, -1, -1)+ where fi = fromIntegral
+ src/Xmobar/Draw/Cairo.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE CPP #-}+------------------------------------------------------------------------------+-- |+-- Module: Xmobar.X11.Cairo+-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz+-- License: BSD3-style (see LICENSE)+--+-- Maintainer: jao@gnu.org+-- Stability: unstable+-- Portability: unportable+-- Created: Fri Sep 09, 2022 02:03+--+-- Drawing the xmobar contents using Cairo and Pango+--+--+------------------------------------------------------------------------------++module Xmobar.Draw.Cairo (drawSegments) where++import qualified Data.Colour.SRGB as SRGB+import qualified Data.Colour.Names as CNames++import Control.Monad (foldM, when)++import qualified Graphics.Rendering.Cairo as Cairo+import qualified Graphics.Rendering.Pango as Pango++import Graphics.Rendering.Cairo.Types(Surface)++import qualified Xmobar.Config.Types as C+import qualified Xmobar.Config.Parse as ConfigParse+import qualified Xmobar.Text.Pango as TextPango++import qualified Xmobar.Draw.Boxes as Boxes+import qualified Xmobar.Draw.Types as T++type Renderinfo = (C.Segment, Surface -> Double -> Double -> IO (), Double)+type BoundedBox = (Double, Double, [C.Box])+type Acc = (Double, T.Actions, [BoundedBox])++readColourName :: String -> (SRGB.Colour Double, Double)+readColourName str =+ case CNames.readColourName str of+ Just c -> (c, 1.0)+ Nothing -> case SRGB.sRGB24reads str of+ [(c, "")] -> (c, 1.0)+ [(c,d)] -> (c, read ("0x" ++ d))+ _ -> (CNames.white, 1.0)++setSourceColor :: (SRGB.Colour Double, Double) -> Cairo.Render ()+setSourceColor (colour, alph) =+ if alph < 1 then Cairo.setSourceRGBA r g b alph else Cairo.setSourceRGB r g b+ where rgb = SRGB.toSRGB colour+ r = SRGB.channelRed rgb+ g = SRGB.channelGreen rgb+ b = SRGB.channelBlue rgb++renderLines :: String -> Double -> [Boxes.Line] -> Cairo.Render ()+renderLines color wd lns = do+ setSourceColor (readColourName color)+ Cairo.setLineWidth wd+ mapM_ (\(x0, y0, x1, y1) ->+ Cairo.moveTo x0 y0 >> Cairo.lineTo x1 y1 >> Cairo.stroke) lns++segmentMarkup :: C.Config -> C.Segment -> String+segmentMarkup conf (C.Text txt, info, idx, _actions) =+ let fnt = TextPango.fixXft $ ConfigParse.indexedFont conf idx+ (fg, bg) = ConfigParse.colorComponents conf (C.tColorsString info)+ attrs = [Pango.FontDescr fnt, Pango.FontForeground fg]+ attrs' = if bg == C.bgColor conf+ then attrs+ else Pango.FontBackground bg:attrs+ in Pango.markSpan attrs' $ Pango.escapeMarkup txt+segmentMarkup _ _ = ""++withRenderinfo :: Pango.PangoContext -> T.DrawContext -> C.Segment -> IO Renderinfo+withRenderinfo ctx dctx seg@(C.Text _, inf, idx, a) = do+ let conf = T.dcConfig dctx+ lyt <- Pango.layoutEmpty ctx+ mk <- Pango.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String+ (_, Pango.PangoRectangle o u w h) <- Pango.layoutGetExtents lyt+ let voff' = fromIntegral $ ConfigParse.indexedOffset conf idx+ voff = voff' + (T.dcHeight dctx - h + u) / 2.0+ wd = w - o+ slyt s off mx = do+ when (off + w > mx) $ do+ Pango.layoutSetEllipsize lyt Pango.EllipsizeEnd+ Pango.layoutSetWidth lyt (Just $ mx - off)+ Cairo.renderWith s $ Cairo.moveTo off voff >> Pango.showLayout lyt+ return ((C.Text mk, inf, idx, a), slyt, wd)++withRenderinfo _ _ seg@(C.Hspace w, _, _, _) =+ return (seg, \_ _ _ -> return (), fromIntegral w)++withRenderinfo _ dctx seg@(C.Icon p, _, _, _) = do+ let (wd, _) = T.dcIconLookup dctx p+ ioff = C.iconOffset (T.dcConfig dctx)+ vpos = T.dcHeight dctx / 2 + fromIntegral ioff+ render _ off mx = when (off + wd <= mx) $ T.dcIconDrawer dctx off vpos p+ return (seg, render, wd)++drawBox :: T.DrawContext -> Surface -> Double -> Double -> C.Box -> IO ()+drawBox dctx surf x0 x1 box@(C.Box _ _ w color _) =+ Cairo.renderWith surf $+ renderLines color (fromIntegral w) (Boxes.boxLines box (T.dcHeight dctx) x0 x1)++drawSegmentBackground ::+ T.DrawContext -> Surface -> C.TextRenderInfo -> Double -> Double -> IO ()+drawSegmentBackground dctx surf info x0 x1 =+ when (bg /= C.bgColor conf && (top >= 0 || bot >= 0)) $+ Cairo.renderWith surf $ do+ setSourceColor (readColourName bg)+ Cairo.rectangle x0 top (x1 - x0) (T.dcHeight dctx - bot - top)+ Cairo.fillPreserve+ where conf = T.dcConfig dctx+ (_, bg) = ConfigParse.colorComponents conf (C.tColorsString info)+ top = fromIntegral $ C.tBgTopOffset info+ bot = fromIntegral $ C.tBgBottomOffset info++drawSegment :: T.DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc+drawSegment dctx surface maxoff (off, acts, boxs) (segment, render, lwidth) = do+ let end = min maxoff (off + lwidth)+ (_, info, _, a) = segment+ acts' = case a of Just as -> (as, off, end):acts; _ -> acts+ bs = C.tBoxes info+ boxs' = if null bs then boxs else (off, end, bs):boxs+ drawSegmentBackground dctx surface info off end+ render surface off maxoff+ return (off + lwidth, acts', boxs')++renderOuterBorder :: C.Config -> Double -> Double -> Cairo.Render ()+renderOuterBorder conf mw mh = do+ let (x0, y0, w, h) = Boxes.borderRect (C.border conf) mw mh+ setSourceColor (readColourName (C.borderColor conf))+ Cairo.setLineWidth (fromIntegral (C.borderWidth conf))+ Cairo.rectangle x0 y0 w h+ Cairo.stroke++drawBorder :: C.Config -> Double -> Double -> Surface -> IO ()+drawBorder conf w h surf =+ case C.border conf of+ C.NoBorder -> return ()+ _ -> Cairo.renderWith surf (renderOuterBorder conf w h)++drawBBox :: T.DrawContext -> Surface -> BoundedBox -> IO ()+drawBBox dctx surf (from, to, bs) = mapM_ (drawBox dctx surf from to) bs++drawBoxes :: T.DrawContext -> Surface -> [BoundedBox] -> IO ()+drawBoxes dctx surf ((from, to, b):(from', to', b'):bxs) =+ if to < from' || b /= b'+ then do drawBBox dctx surf (from, to, b)+ drawBoxes dctx surf $ (from', to', b'):bxs+ else drawBoxes dctx surf $ (from, to', b'):bxs++drawBoxes dctx surf [bi] = drawBBox dctx surf bi++drawBoxes _ _ [] = return ()++#ifndef XRENDER+drawCairoBackground :: T.DrawContext -> Surface -> IO ()+drawCairoBackground dctx surf = do+ let (c, _) = readColourName (C.bgColor (T.dcConfig dctx))+ Cairo.renderWith surf $ setSourceColor (c, 1.0) >> Cairo.paint+#endif++drawSegments :: T.DrawContext -> Surface -> IO T.Actions+drawSegments dctx surf = do+ let [left, center, right] = take 3 $ T.dcSegments dctx ++ repeat []+ dh = T.dcHeight dctx+ dw = T.dcWidth dctx+ conf = T.dcConfig dctx+ sWidth = foldl (\a (_,_,w) -> a + w) 0+ ctx <- Pango.cairoCreateContext Nothing+ llyts <- mapM (withRenderinfo ctx dctx) left+ rlyts <- mapM (withRenderinfo ctx dctx) right+ clyts <- mapM (withRenderinfo ctx dctx) center+#ifndef XRENDER+ drawCairoBackground dctx surf+#endif+ (lend, as, bx) <- foldM (drawSegment dctx surf dw) (0, [], []) llyts+ let rw = sWidth rlyts+ rstart = max (lend + 1) (dw - rw - 1)+ cmax = rstart - 1+ cw = sWidth clyts+ cstart = lend + 1 + max 0 (dw - rw - lend - cw) / 2.0+ (_, as', bx') <- foldM (drawSegment dctx surf cmax) (cstart, as, bx) clyts+ (_, as'', bx'') <- foldM (drawSegment dctx surf dw) (rstart, as', bx') rlyts+ drawBoxes dctx surf (reverse bx'')+ when (C.borderWidth conf > 0) (drawBorder conf dw dh surf)+ return as''
+ src/Xmobar/Draw/Types.hs view
@@ -0,0 +1,36 @@+------------------------------------------------------------------------------+-- |+-- Module: Xmobar.Draw.Types+-- Copyright: (c) 2022 jao+-- License: BSD3-style (see LICENSE)+--+-- Maintainer: mail@jao.io+-- Stability: unstable+-- Portability: portable+-- Created: Tue Sep 20, 2022 04:49+--+--+-- Type definitions for describing drawing operations+--+------------------------------------------------------------------------------+++module Xmobar.Draw.Types where++import Xmobar.Config.Types (Config, Segment)+import Xmobar.Run.Actions (Action)++type Position = Double+type ActionPos = ([Action], Position, Position)+type Actions = [ActionPos]++type IconLookup = String -> (Double, Double)+type IconDrawer = Double -> Double -> String -> IO ()++data DrawContext = DC { dcIconDrawer :: IconDrawer+ , dcIconLookup :: IconLookup+ , dcConfig :: Config+ , dcWidth :: Double+ , dcHeight :: Double+ , dcSegments :: [[Segment]]+ }
src/Xmobar/Plugins/Kraken.hs view
@@ -28,7 +28,7 @@ instance Exec Kraken where alias (Kraken _ a) = a start (Kraken ps _) cb = do- mvar <- newEmptyMVar + mvar <- newEmptyMVar bracket (async $ reconnectOnConnectionClose $ wsClientApp ps mvar) cancel $ \_ -> do let loop mv p = do v <- takeMVar mv@@ -39,7 +39,7 @@ loop mvar (Map.fromList $ zip ps (repeat 0.0)) where- display :: Map.Map String Double -> String + display :: Map.Map String Double -> String display m = unwords $ sort $ map (\x -> fst x ++ ": " ++ show (snd x)) $ Map.toList m reconnectOnConnectionClose :: ClientApp () -> IO ()@@ -71,7 +71,7 @@ Just num -> return num Nothing -> typeMismatch "Double inside a String" v -instance FromJSON Ask where +instance FromJSON Ask where parseJSON (Array v) | V.length v == 3 = do p <- parseDoubleString $ v V.! 0@@ -87,7 +87,7 @@ , bidLotVolume :: Double } deriving Show -instance FromJSON Bid where +instance FromJSON Bid where parseJSON (Array v) | V.length v == 3 = do p <- parseDoubleString $ v V.! 0@@ -102,7 +102,7 @@ , closeLotVolume :: Double } deriving Show -instance FromJSON Close where +instance FromJSON Close where parseJSON (Array v) | V.length v == 2 = do p <- parseDoubleString $ v V.! 0@@ -117,12 +117,12 @@ , close :: Close } deriving Show -instance FromJSON TickerInformation where +instance FromJSON TickerInformation where parseJSON = withObject "P" $ \v -> TickerInformation <$> v .: "a" <*> v .: "b" <*> v .: "c"- + data Message = Heartbeat | TickerMessage { channelId :: Int, tickerInformation :: TickerInformation, channelName :: Text, tickerPair :: Text }
src/Xmobar/Plugins/Monitors/Batt.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Plugins.Monitors.Batt--- Copyright : (c) 2010, 2011, 2012, 2013, 2015, 2016, 2018, 2019 Jose A Ortega+-- Copyright : (c) 2010-2013, 2015, 2016, 2018, 2019, 2022 Jose A Ortega -- (c) 2010 Andrea Rossato, Petr Rockai -- License : BSD-style (see LICENSE) --@@ -15,11 +15,9 @@ -- ----------------------------------------------------------------------------- -module Xmobar.Plugins.Monitors.Batt ( battConfig, runBatt, runBatt' ) where+module Xmobar.Plugins.Monitors.Batt (battConfig, runBatt, runBatt') where -import Xmobar.Plugins.Monitors.Batt.Common (BattOpts(..)- , Result(..)- , Status(..))+import Xmobar.Plugins.Monitors.Batt.Common (BattOpts(..), Result(..), Status(..)) import Xmobar.Plugins.Monitors.Common import System.Console.GetOpt @@ -83,9 +81,9 @@ ] battConfig :: IO MConfig-battConfig = mkMConfig- "Batt: <watts>, <left>% / <timeleft>" -- template- ["leftbar", "leftvbar", "left", "acstatus", "timeleft", "watts", "leftipat"] -- replacements+battConfig = mkMConfig "Batt: <watts>, <left>% / <timeleft>" vs+ where vs = ["leftbar", "leftvbar", "left"+ , "acstatus", "timeleft", "watts", "leftipat"] data BatteryStatus = BattHigh@@ -129,48 +127,53 @@ (100 * x) parseTemplate (l ++ [st, fmtTime $ floor t, ws, si]) NA -> getConfigValue naString- where fmtPercent :: Float -> Bool -> Monitor [String]- fmtPercent x sp = do- let x' = minimum [1, x]- pc <- if sp then colorizeString (100 * x') "%" else return ""- p <- showPercentWithColors x'- b <- showPercentBar (100 * x') x'- vb <- showVerticalBar (100 * x') x'- return [b, vb, p ++ pc]- fmtWatts x o s d = do- ws <- showWithPadding $ showDigits d x ++ (if s then "W" else "")- return $ color x o ws- fmtTime :: Integer -> String- fmtTime x = hours ++ ":" ++ if length minutes == 2- then minutes else '0' : minutes- where hours = show (x `div` 3600)- minutes = show ((x `mod` 3600) `div` 60)- fmtStatus- :: BattOpts- -> Status- -> String -- ^ What to in case battery status is unknown- -> BatteryStatus- -> String- fmtStatus opts Idle _ _ = idleString opts- fmtStatus _ Unknown na _ = na- fmtStatus opts Full _ _ = idleString opts- fmtStatus opts Charging _ _ = onString opts- fmtStatus opts Discharging _ battStatus =- (case battStatus of- BattHigh -> highString- BattMedium -> mediumString- BattLow -> lowString) opts ++ offString opts- maybeColor Nothing str = str- maybeColor (Just c) str = "<fc=" ++ c ++ ">" ++ str ++ "</fc>"- color x o | x >= 0 = maybeColor (posColor o)- | -x >= highThreshold o = maybeColor (highWColor o)- | -x >= lowThreshold o = maybeColor (mediumWColor o)- | otherwise = maybeColor (lowWColor o)- getIconPattern opts st x = do- let x' = minimum [1, x]- case st of- Unknown -> showIconPattern (offIconPattern opts) x'- Idle -> showIconPattern (idleIconPattern opts) x'- Full -> showIconPattern (idleIconPattern opts) x'- Charging -> showIconPattern (onIconPattern opts) x'- Discharging -> showIconPattern (offIconPattern opts) x'++fmtWatts :: Float -> BattOpts -> Bool -> Int -> Monitor String+fmtWatts x o s d = do+ ws <- showWithPadding $ showDigits d x ++ (if s then "W" else "")+ return $ color x o ws++color :: Float -> BattOpts -> String -> String+color x o | x >= 0 = maybeColor (posColor o)+ | -x >= highThreshold o = maybeColor (highWColor o)+ | -x >= lowThreshold o = maybeColor (mediumWColor o)+ | otherwise = maybeColor (lowWColor o)++fmtTime :: Integer -> String+fmtTime x = hours ++ ":" ++ if length minutes == 2 then minutes else '0' : minutes+ where hours = show (x `div` 3600)+ minutes = show ((x `mod` 3600) `div` 60)++fmtPercent :: Float -> Bool -> Monitor [String]+fmtPercent x sp = do+ let x' = min 1 x+ pc <- if sp then colorizeString (100 * x') "%" else return ""+ p <- showPercentWithColors x'+ b <- showPercentBar (100 * x') x'+ vb <- showVerticalBar (100 * x') x'+ return [b, vb, p ++ pc]++fmtStatus :: BattOpts -> Status -> String -> BatteryStatus -> String+fmtStatus opts Idle _ _ = idleString opts+fmtStatus _ Unknown na _ = na+fmtStatus opts Full _ _ = idleString opts+fmtStatus opts Charging _ _ = onString opts+fmtStatus opts Discharging _ battStatus =+ (case battStatus of+ BattHigh -> highString+ BattMedium -> mediumString+ BattLow -> lowString) opts ++ offString opts++maybeColor :: Maybe String -> String -> String+maybeColor Nothing str = str+maybeColor (Just c) str = "<fc=" ++ c ++ ">" ++ str ++ "</fc>"++getIconPattern :: BattOpts -> Status -> Float -> Monitor String+getIconPattern opts st x = do+ let x' = min 1 x+ case st of+ Unknown -> showIconPattern (offIconPattern opts) x'+ Idle -> showIconPattern (idleIconPattern opts) x'+ Full -> showIconPattern (idleIconPattern opts) x'+ Charging -> showIconPattern (onIconPattern opts) x'+ Discharging -> showIconPattern (offIconPattern opts) x'
src/Xmobar/Plugins/Monitors/Common/Output.hs view
@@ -223,7 +223,7 @@ bw <- getConfigValue barWidth let c = bw < 1 w = if c then length bf else bw- len = min w $ round (fromIntegral w * x)+ len = min w $ (if c then ceiling else round) (fromIntegral w * x) bfs = if c then [bf !! max 0 (len - 1)] else take len $ cycle bf s <- colorizeString v bfs return $ s ++ if c then "" else take (bw - len) (cycle bb)
src/Xmobar/Plugins/Monitors/Common/Types.hs view
@@ -116,7 +116,7 @@ pBarBack <- readIORef barBack pBarFore <- readIORef barFore pBarWidth <- readIORef barWidth- pUseSuffix <- readIORef useSuffix + pUseSuffix <- readIORef useSuffix pNaString <- readIORef naString pMaxTotalWidth <- readIORef maxTotalWidth pMaxTotalWidthEllipsis <- readIORef maxTotalWidthEllipsis
− src/Xmobar/Run/Parsers.hs
@@ -1,234 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}---------------------------------------------------------------------------------- |--- Module : Xmobar.Run.Parsers--- Copyright : (c) Andrea Rossato--- License : BSD-style (see LICENSE)------ Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>--- Stability : unstable--- Portability : portable------ Parsing for template substrings-----------------------------------------------------------------------------------module Xmobar.Run.Parsers ( parseString- , colorComponents- , Segment- , FontIndex- , Box(..)- , BoxBorder(..)- , BoxOffset(..)- , BoxMargins(..)- , TextRenderInfo(..)- , Widget(..)) where--import Control.Monad (guard, mzero)-import Data.Maybe (fromMaybe)-import Data.Int (Int32)-import Text.ParserCombinators.Parsec-import Text.Read (readMaybe)-import Foreign.C.Types (CInt)--import Xmobar.Config.Types-import Xmobar.Run.Actions--data Widget = Icon String | Text String | Hspace Int32 deriving Show--data BoxOffset = BoxOffset Align Int32 deriving (Eq, Show)--- margins: Top, Right, Bottom, Left-data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving (Eq, Show)-data BoxBorder = BBTop- | BBBottom- | BBVBoth- | BBLeft- | BBRight- | BBHBoth- | BBFull- deriving ( Read, Eq, Show )-data Box = Box BoxBorder BoxOffset CInt String BoxMargins deriving (Eq, Show)-data TextRenderInfo =- TextRenderInfo { tColorsString :: String- , tBgTopOffset :: Int32- , tBgBottomOffset :: Int32- , tBoxes :: [Box]- } deriving Show-type FontIndex = Int--type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action])---- | Runs the string parser-parseString :: Config -> String -> IO [Segment]-parseString c s =- case parse (stringParser ci 0 Nothing) "" s of- Left _ -> return [(Text $ "Could not parse string: " ++ s- , ci- , 0- , Nothing)]- Right x -> return (concat x)- where ci = TextRenderInfo (fgColor c) 0 0 []---- | Splits a colors string into its two components-colorComponents :: Config -> String -> (String, String)-colorComponents conf c =- case break (==',') c of- (f,',':b) -> (f, b)- (f, _) -> (f, bgColor conf)--allParsers :: TextRenderInfo- -> FontIndex- -> Maybe [Action]- -> Parser [Segment]-allParsers c f a = textParser c f a- <|> try (iconParser c f a)- <|> try (hspaceParser c f a)- <|> try (rawParser c f a)- <|> try (actionParser c f a)- <|> try (fontParser c a)- <|> try (boxParser c f a)- <|> colorParser c f a---- | Gets the string and combines the needed parsers-stringParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [[Segment]]-stringParser c f a = manyTill (allParsers c f a) eof---- | Parses a maximal string without markup.-textParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]-textParser c f a = do s <- many1 $- noneOf "<" <|>- try (notFollowedBy' (char '<')- (try (string "fc=") <|>- try (string "box") <|>- try (string "fn=") <|>- try (string "action=") <|>- try (string "/action>") <|>- try (string "icon=") <|>- try (string "hspace=") <|>- try (string "raw=") <|>- try (string "/fn>") <|>- try (string "/box>") <|>- string "/fc>"))- return [(Text s, c, f, a)]---- | Parse a "raw" tag, which we use to prevent other tags from creeping in.--- The format here is net-string-esque: a literal "<raw=" followed by a--- string of digits (base 10) denoting the length of the raw string,--- a literal ":" as digit-string-terminator, the raw string itself, and--- then a literal "/>".-rawParser :: TextRenderInfo- -> FontIndex- -> Maybe [Action]- -> Parser [Segment]-rawParser c f a = do- string "<raw="- lenstr <- many1 digit- char ':'- case reads lenstr of- [(len,[])] -> do- guard ((len :: Integer) <= fromIntegral (maxBound :: Int))- s <- count (fromIntegral len) anyChar- string "/>"- return [(Text s, c, f, a)]- _ -> mzero---- | Wrapper for notFollowedBy that returns the result of the first parser.--- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy--- accepts only parsers with return type Char.-notFollowedBy' :: Parser a -> Parser b -> Parser a-notFollowedBy' p e = do x <- p- notFollowedBy $ try (e >> return '*')- return x--iconParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]-iconParser c f a = do- string "<icon="- i <- manyTill (noneOf ">") (try (string "/>"))- return [(Icon i, c, f, a)]--hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]-hspaceParser c f a = do- string "<hspace="- pVal <- manyTill digit (try (string "/>"))- return [(Hspace (fromMaybe 0 $ readMaybe pVal), c, f, a)]--actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]-actionParser c f act = do- string "<action="- command <- choice [between (char '`') (char '`') (many1 (noneOf "`")),- many1 (noneOf ">")]- buttons <- (char '>' >> return "1") <|> (space >> spaces >>- between (string "button=") (string ">") (many1 (oneOf "12345")))- let a = Spawn (toButtons buttons) command- a' = case act of- Nothing -> Just [a]- Just act' -> Just $ a : act'- s <- manyTill (allParsers c f a') (try $ string "</action>")- return (concat s)--toButtons :: String -> [Button]-toButtons = map (\x -> read [x])---- | Parsers a string wrapped in a color specification.-colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]-colorParser (TextRenderInfo _ _ _ bs) f a = do- c <- between (string "<fc=") (string ">") colors- let colorParts = break (==':') c- let (ot,ob) = case break (==',') (Prelude.drop 1 $ snd colorParts) of- (top,',':btm) -> (top, btm)- (top, _) -> (top, top)- s <- manyTill- (allParsers (TextRenderInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob) bs) f a)- (try $ string "</fc>")- return (concat s)---- | Parses a string wrapped in a box specification.-boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment]-boxParser (TextRenderInfo cs ot ob bs) f a = do- c <- between (string "<box") (string ">") (option "" (many1 (alphaNum <|> char '=' <|> char ' ' <|> char '#' <|> char ',')))- let b = Box BBFull (BoxOffset C 0) 1 cs (BoxMargins 0 0 0 0)- let g = boxReader b (words c)- s <- manyTill- (allParsers (TextRenderInfo cs ot ob (g : bs)) f a)- (try $ string "</box>")- return (concat s)--boxReader :: Box -> [String] -> Box-boxReader b [] = b-boxReader b (x:xs) = do- let (param,val) = case break (=='=') x of- (p,'=':v) -> (p, v)- (p, _) -> (p, "")- boxReader (boxParamReader b param val) xs--boxParamReader :: Box -> String -> String -> Box-boxParamReader b _ "" = b-boxParamReader (Box bb off lw fc mgs) "type" val =- Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs-boxParamReader (Box bb (BoxOffset alg off) lw fc mgs) "offset" (a:o) =- Box bb (BoxOffset (fromMaybe alg $ readMaybe [a]) (fromMaybe off $ readMaybe o)) lw fc mgs-boxParamReader (Box bb off lw fc mgs) "width" val =- Box bb off (fromMaybe lw $ readMaybe val) fc mgs-boxParamReader (Box bb off lw _ mgs) "color" val =- Box bb off lw val mgs-boxParamReader (Box bb off lw fc mgs@(BoxMargins mt mr mb ml)) ('m':pos) val = do- let mgs' = case pos of- "t" -> BoxMargins (fromMaybe mt $ readMaybe val) mr mb ml- "r" -> BoxMargins mt (fromMaybe mr $ readMaybe val) mb ml- "b" -> BoxMargins mt mr (fromMaybe mb $ readMaybe val) ml- "l" -> BoxMargins mt mr mb (fromMaybe ml $ readMaybe val)- _ -> mgs- Box bb off lw fc mgs'-boxParamReader b _ _ = b---- | Parsers a string wrapped in a font specification.-fontParser :: TextRenderInfo -> Maybe [Action] -> Parser [Segment]-fontParser c a = do- f <- between (string "<fn=") (string ">") colors- s <- manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (try $ string "</fn>")- return (concat s)---- | Parses a color specification (hex or named)-colors :: Parser String-colors = many1 (alphaNum <|> char ',' <|> char ':' <|> char '#')
src/Xmobar/System/Environment.hs view
@@ -13,14 +13,14 @@ ----------------------------------------------------------------------------- module Xmobar.System.Environment(expandEnv) where -import Data.Maybe (fromMaybe)-import System.Environment (lookupEnv)+import qualified Data.Maybe as M+import qualified System.Environment as E expandEnv :: String -> IO String expandEnv "" = return "" expandEnv (c:s) = case c of '$' -> do- envVar <- fromMaybe "" <$> lookupEnv e+ envVar <- M.fromMaybe "" <$> E.lookupEnv e remainder <- expandEnv s' return $ envVar ++ remainder where (e, s') = getVar s
src/Xmobar/Text/Loop.hs view
@@ -45,4 +45,4 @@ updateString :: Config -> TVar [String] -> IO String updateString conf v = do s <- readTVarIO v- format conf (concat s)+ return $ format conf (concat s)
src/Xmobar/Text/Output.hs view
@@ -15,14 +15,16 @@ module Xmobar.Text.Output (initLoop, format) where -import Xmobar.Config.Types (Config(textOutputFormat, additionalFonts, font)- , TextOutputFormat(..))-import Xmobar.Run.Parsers ( Segment- , Widget(..)- , parseString- , tColorsString- , colorComponents)+import Xmobar.Config.Types ( Config (..)+ , TextOutputFormat (..)+ , Segment+ , Widget (..)+ , tColorsString) ++import Xmobar.Config.Parse (colorComponents)+import Xmobar.Config.Template (parseString)+ import Xmobar.Text.Ansi (withAnsiColor) import Xmobar.Text.Pango (withPangoMarkup) import Xmobar.Text.Swaybar (formatSwaybar, prepare)@@ -47,9 +49,9 @@ formatWithColor conf (Text $ replicate (fromIntegral n) ' ', i, x, y) formatWithColor _ _ = "" -format :: Config -> String -> IO String+format :: Config -> String -> String format conf s = do- segments <- parseString conf s+ let segments = parseString conf s case textOutputFormat conf of- Swaybar -> return $ formatSwaybar conf segments- _ -> return (concatMap (formatWithColor conf) segments)+ Swaybar -> formatSwaybar conf segments+ _ -> concatMap (formatWithColor conf) segments
src/Xmobar/Text/Pango.hs view
@@ -15,7 +15,8 @@ -- ------------------------------------------------------------------------------ -module Xmobar.Text.Pango (withPangoColor, withPangoFont, withPangoMarkup) where+module Xmobar.Text.Pango (withPangoColor, withPangoFont, withPangoMarkup, fixXft)+where import Text.Printf (printf) import Data.List (isPrefixOf)@@ -36,7 +37,8 @@ where fmt = "<span foreground=\"%s\" background=\"%s\">%s</span>" fixXft :: String -> String-fixXft font = if "xft:" `isPrefixOf` font then drop 4 font else font+fixXft font =+ if "xft:" `isPrefixOf` font then replaceAll '-' " " $ drop 4 font else font withPangoFont :: String -> String -> String withPangoFont font txt = printf fmt (fixXft font) (xmlEscape txt)
src/Xmobar/Text/Swaybar.hs view
@@ -24,16 +24,16 @@ import GHC.Generics -import Xmobar.Config.Types (Config (additionalFonts))+import Xmobar.Config.Types ( Config (additionalFonts)+ , Segment+ , Widget(..)+ , Box(..)+ , BoxBorder(..)+ , FontIndex+ , tBoxes+ , tColorsString) -import Xmobar.Run.Parsers ( Segment- , Widget(..)- , Box(..)- , BoxBorder(..)- , FontIndex- , tBoxes- , tColorsString- , colorComponents)+import Xmobar.Config.Parse (colorComponents) import Xmobar.Text.SwaybarClicks (startHandler) import Xmobar.Text.Pango (withPangoFont)
src/Xmobar/X11/Bitmap.hs view
@@ -14,17 +14,19 @@ module Xmobar.X11.Bitmap ( updateCache , drawBitmap- , Bitmap(..)) where+ , Bitmap(..)+ , BitmapCache) where import Control.Monad import Control.Monad.Trans(MonadIO(..))-import Data.Map hiding (map, filter)-import Graphics.X11.Xlib+import Data.Map hiding (map)++import Graphics.X11.Xlib hiding (Segment)+ import System.Directory (doesFileExist) import System.FilePath ((</>)) import System.Mem.Weak ( addFinalizer )-import Xmobar.Run.Actions (Action)-import Xmobar.Run.Parsers (TextRenderInfo(..), Widget(..))+ import Xmobar.X11.ColorCache #ifdef XPM@@ -53,13 +55,12 @@ , bitmapType :: BitmapType } -updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath ->- [[(Widget, TextRenderInfo, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap)-updateCache dpy win cache iconRoot ps = do- let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps- icons (Icon _, _, _, _) = True- icons _ = False- expandPath path@('/':_) = path+type BitmapCache = Map FilePath Bitmap++updateCache :: Display -> Window -> BitmapCache -> FilePath -> [FilePath]+ -> IO BitmapCache+updateCache dpy win cache iconRoot paths = do+ let expandPath path@('/':_) = path expandPath path@('.':'/':_) = path expandPath path@('.':'.':'/':_) = path expandPath path = iconRoot </> path@@ -115,7 +116,7 @@ drawBitmap :: Display -> Drawable -> GC -> String -> String -> Position -> Position -> Bitmap -> IO () drawBitmap d p gc fc bc x y i =- withColors d [fc, bc] $ \[fc', bc'] -> do+ withColors d [fc, bc] $ \[fc', bc'] -> do let w = width i h = height i y' = 1 + y - fromIntegral h `div` 2
+ src/Xmobar/X11/CairoSurface.hsc view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}++------------------------------------------------------------------------------+-- |+-- Module: Xmobar.X11.Cairo+-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz+-- License: BSD3-style (see LICENSE)+--+-- Maintainer: jao@gnu.org+-- Stability: unstable+-- Portability: unportable+-- Created: Thu Sep 08, 2022 01:25+--+--+-- Xlib Cairo Surface creation+--+------------------------------------------------------------------------------++module Xmobar.X11.CairoSurface (withXlibSurface+ , withBitmapSurface+ , setSurfaceDrawable) where++import Graphics.X11.Xlib.Types+import Graphics.X11.Types+import Graphics.X11.Xlib (defaultScreenOfDisplay)+import Graphics.Rendering.Cairo.Types+import qualified Graphics.Rendering.Cairo.Internal as Internal++import Foreign+import Foreign.C++#include <cairo/cairo-xlib.h>++foreign import ccall "cairo_xlib_surface_create"+ cSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> Ptr Surface++foreign import ccall "cairo_xlib_surface_create_for_bitmap"+ cBitmapCreate :: Display -> Pixmap -> Screen -> CInt -> CInt -> Ptr Surface++foreign import ccall "cairo_xlib_surface_set_drawable"+ cSetDrawable :: Ptr Surface -> Drawable -> CInt -> CInt -> ()++createXlibSurface :: Display -> Drawable -> Visual -> Int -> Int -> IO Surface+createXlibSurface d dr v w h =+ mkSurface $ cSurfaceCreate d dr v (fromIntegral w) (fromIntegral h)++withXlibSurface ::+ Display -> Drawable -> Visual -> Int -> Int -> (Surface -> IO a) -> IO a+withXlibSurface d dr v w h f = do+ surface <- createXlibSurface d dr v w h+ ret <- f surface+ Internal.surfaceDestroy surface+ return ret++createBitmapSurface :: Display -> Pixmap -> Screen -> Int -> Int -> IO Surface+createBitmapSurface d p s w h =+ mkSurface $ cBitmapCreate d p s (fromIntegral w) (fromIntegral h)++withBitmapSurface :: Display -> Pixmap -> Int -> Int -> (Surface -> IO a) -> IO a+withBitmapSurface d p w h f = do+ surface <- createBitmapSurface d p (defaultScreenOfDisplay d) w h+ ret <- f surface+ Internal.surfaceDestroy surface+ return ret++setSurfaceDrawable :: Surface -> Drawable -> Int -> Int -> IO ()+setSurfaceDrawable surface dr w h =+ withSurface surface $+ \s -> return $ cSetDrawable s dr (fromIntegral w) (fromIntegral h)
src/Xmobar/X11/ColorCache.hs view
@@ -2,7 +2,7 @@ ------------------------------------------------------------------------------ -- | -- Module: ColorCache--- Copyright: (c) 2012 Jose Antonio Ortega Ruiz+-- Copyright: (c) 2012, 2022 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org@@ -15,97 +15,47 @@ -- ------------------------------------------------------------------------------ -#if defined XFT--module Xmobar.X11.ColorCache(withColors, withDrawingColors) where--import Xmobar.X11.MinXft--#else- module Xmobar.X11.ColorCache(withColors) where -#endif+import qualified Data.IORef as IO+import qualified System.IO.Unsafe as U -import Data.IORef-import System.IO.Unsafe (unsafePerformIO)-import Control.Monad.Trans (MonadIO, liftIO)-import Control.Exception (SomeException, handle)-import Graphics.X11.Xlib+import qualified Control.Exception as E+import qualified Control.Monad.Trans as Tr -data DynPixel = DynPixel Bool Pixel+import qualified Graphics.X11.Xlib as X -initColor :: Display -> String -> IO DynPixel-initColor dpy c = handle black $ initColor' dpy c+data DynPixel = DynPixel Bool X.Pixel++initColor :: X.Display -> String -> IO DynPixel+initColor dpy c = E.handle black $ initColor' dpy c where- black :: SomeException -> IO DynPixel- black = const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)+ black :: E.SomeException -> IO DynPixel+ black = const . return $ DynPixel False (X.blackPixel dpy $ X.defaultScreen dpy) -type ColorCache = [(String, Color)]+type ColorCache = [(String, X.Color)] {-# NOINLINE colorCache #-}-colorCache :: IORef ColorCache-colorCache = unsafePerformIO $ newIORef []+colorCache :: IO.IORef ColorCache+colorCache = U.unsafePerformIO $ IO.newIORef [] -getCachedColor :: String -> IO (Maybe Color)-getCachedColor color_name = lookup color_name `fmap` readIORef colorCache+getCachedColor :: String -> IO (Maybe X.Color)+getCachedColor color_name = lookup color_name `fmap` IO.readIORef colorCache -putCachedColor :: String -> Color -> IO ()-putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c+putCachedColor :: String -> X.Color -> IO ()+putCachedColor name c_id = IO.modifyIORef colorCache $ \c -> (name, c_id) : c -initColor' :: Display -> String -> IO DynPixel+initColor' :: X.Display -> String -> IO DynPixel initColor' dpy c = do- let colormap = defaultColormap dpy (defaultScreen dpy)+ let colormap = X.defaultColormap dpy (X.defaultScreen dpy) cached_color <- getCachedColor c c' <- case cached_color of Just col -> return col- _ -> do (c'', _) <- allocNamedColor dpy colormap c+ _ -> do (c'', _) <- X.allocNamedColor dpy colormap c putCachedColor c c'' return c''- return $ DynPixel True (color_pixel c')+ return $ DynPixel True (X.color_pixel c') -withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a+withColors :: Tr.MonadIO m => X.Display -> [String] -> ([X.Pixel] -> m a) -> m a withColors d cs f = do- ps <- mapM (liftIO . initColor d) cs+ ps <- mapM (Tr.liftIO . initColor d) cs f $ map (\(DynPixel _ pixel) -> pixel) ps--#ifdef XFT--type AXftColorCache = [(String, AXftColor)]-{-# NOINLINE xftColorCache #-}-xftColorCache :: IORef AXftColorCache-xftColorCache = unsafePerformIO $ newIORef []--getXftCachedColor :: String -> IO (Maybe AXftColor)-getXftCachedColor name = lookup name `fmap` readIORef xftColorCache--putXftCachedColor :: String -> AXftColor -> IO ()-putXftCachedColor name cptr =- modifyIORef xftColorCache $ \c -> (name, cptr) : c--initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor-initAXftColor' d v cm c = do- cc <- getXftCachedColor c- c' <- case cc of- Just col -> return col- _ -> do c'' <- mallocAXftColor d v cm c- putXftCachedColor c c''- return c''- return c'--initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor-initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c)- where- black :: SomeException -> IO AXftColor- black = (const $ initAXftColor' d v cm "black")--withDrawingColors :: -- MonadIO m =>- Display -> Drawable -> String -> String- -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO ()-withDrawingColors dpy drw fc bc f = do- let screen = defaultScreenOfDisplay dpy- colormap = defaultColormapOfScreen screen- visual = defaultVisualOfScreen screen- fc' <- initAXftColor dpy visual colormap fc- bc' <- initAXftColor dpy visual colormap bc- withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc'-#endif
src/Xmobar/X11/Draw.hs view
@@ -1,243 +1,94 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TupleSections #-}- ------------------------------------------------------------------------------ -- | -- Module: Xmobar.X11.Draw--- Copyright: (c) 2018, 2020, 2022 Jose Antonio Ortega Ruiz+-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org -- Stability: unstable--- Portability: portable--- Created: Sat Nov 24, 2018 18:49+-- Portability: unportable+-- Created: Fri Sep 09, 2022 02:03 --+-- Drawing the xmobar contents using Cairo and Pango ----- Drawing the xmobar contents -- ------------------------------------------------------------------------------ +module Xmobar.X11.Draw (draw) where -module Xmobar.X11.Draw (drawInWin) where+import qualified Data.Map as M -import Prelude hiding (lookup)-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Arrow ((&&&))-import Data.Map hiding ((\\), foldr, map, filter)-import Data.List ((\\))-import qualified Data.List.NonEmpty as NE+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask)+import Foreign.C.Types as FT+import qualified Graphics.X11.Xlib as X11 -import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment)-import Graphics.X11.Xlib.Extras+import qualified Xmobar.Config.Types as C+import qualified Xmobar.Draw.Types as D+import qualified Xmobar.Draw.Cairo as DC -import Xmobar.Config.Types-import Xmobar.Run.Parsers hiding (parseString) import qualified Xmobar.X11.Bitmap as B-import Xmobar.X11.Types-import Xmobar.X11.Text-import Xmobar.X11.ColorCache-import Xmobar.X11.Window (drawBorder)-import Xmobar.System.Utils (safeIndex)+import qualified Xmobar.X11.Types as T+import qualified Xmobar.X11.CairoSurface as CS -#ifdef XFT-import Xmobar.X11.MinXft-import Graphics.X11.Xrender+#ifdef XRENDER+import qualified Xmobar.X11.XRender as XRender #endif -fi :: (Integral a, Num b) => a -> b-fi = fromIntegral---- | Draws in and updates the window-drawInWin :: Rectangle -> [[Segment]] -> X ()-drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do- r <- ask- let (c,d) = (config &&& display) r- (w,(fs,vs)) = (window &&& fontListS &&& verticalOffsets) r- strLn = liftIO . mapM getWidth- iconW i = maybe 0 B.width (lookup i $ iconS r)- getWidth (Text s,cl,i,_) =- textWidth d (safeIndex fs i) s >>= \tw -> return (Text s,cl,i,fi tw)- getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s)- getWidth (Hspace p,cl,i,_) = return (Hspace p,cl,i,fi p)+drawXBitmap :: T.XConf -> X11.GC -> X11.Pixmap -> D.IconDrawer+drawXBitmap xconf gc p h v path = do+ let disp = T.display xconf+ conf = T.config xconf+ fc = C.fgColor conf+ bc = C.bgColor conf+ case M.lookup path (T.iconCache xconf) of+ Just bm -> liftIO $ B.drawBitmap disp p gc fc bc (round h) (round v) bm+ Nothing -> return () - p <- liftIO $ createPixmap d w wid ht- (defaultDepthOfScreen (defaultScreenOfDisplay d))-#if XFT- when (alpha c /= 255) (liftIO $ drawBackground d p (bgColor c) (alpha c) wr)-#else- _ <- return wr-#endif- withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do- gc <- liftIO $ createGC d w- liftIO $ setGraphicsExposures d gc False-#if XFT- when (alpha c == 255) $ do-#else- do-#endif- liftIO $ setForeground d gc bgcolor- liftIO $ fillRectangle d p gc 0 0 wid ht- -- write to the pixmap the new string- printStrings p gc fs vs 1 L [] =<< strLn left- printStrings p gc fs vs 1 R [] =<< strLn right- printStrings p gc fs vs 1 C [] =<< strLn center- -- draw border if requested- liftIO $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht- -- copy the pixmap with the new string to the window- liftIO $ copyArea d p w gc 0 0 wid ht 0 0- -- free up everything (we do not want to leak memory!)- liftIO $ freeGC d gc- liftIO $ freePixmap d p- -- resync (discard events, we don't read/process events from this display conn)- liftIO $ sync d True+lookupXBitmap :: T.XConf -> String -> (Double, Double)+lookupXBitmap xconf path =+ case M.lookup path (T.iconCache xconf) of+ Just bm -> (fromIntegral (B.width bm), fromIntegral (B.height bm))+ Nothing -> (0, 0) -verticalOffset :: (Integral b, Integral a, MonadIO m) =>- a -> Widget -> XFont -> Int -> Config -> m b-verticalOffset ht (Text t) fontst voffs _- | voffs > -1 = return $ fi voffs- | otherwise = do- (as,ds) <- liftIO $ textExtents fontst t- let margin = (fi ht - fi ds - fi as) `div` 2- return $ fi as + margin - 1-verticalOffset ht (Icon _) _ _ conf- | iconOffset conf > -1 = return $ fi (iconOffset conf)- | otherwise = return $ fi (ht `div` 2) - 1-verticalOffset _ (Hspace _) _ voffs _ = return $ fi voffs+withPixmap :: X11.Display -> X11.Drawable -> X11.Rectangle -> FT.CInt+ -> (X11.GC -> X11.Pixmap -> IO a) -> IO a+withPixmap disp win (X11.Rectangle _ _ w h) depth action = do+ p <- X11.createPixmap disp win w h depth+ gc <- X11.createGC disp win+ X11.setGraphicsExposures disp gc False+ res <- action gc p+ -- copy the pixmap with the new string to the window+ X11.copyArea disp p win gc 0 0 w h 0 0+ -- free up everything (we do not want to leak memory!)+ X11.freeGC disp gc+ X11.freePixmap disp p+ -- resync (discard events, we don't read/process events from this display conn)+ X11.sync disp True+ return res -printString :: Display- -> Drawable- -> XFont- -> GC- -> String- -> String- -> Position- -> Position- -> Position- -> Position- -> String- -> Int- -> IO ()-printString d p (Core fs) gc fc bc x y _ _ s a = do- setFont d gc $ fontFromFontStruct fs- withColors d [fc, bc] $ \[fc', bc'] -> do- setForeground d gc fc'- when (a == 255) (setBackground d gc bc')- drawImageString d p gc x y s+draw :: [[C.Segment]] -> T.X [D.ActionPos]+draw segments = do+ xconf <- ask+ let disp = T.display xconf+ win = T.window xconf+ rect@(X11.Rectangle _ _ w h) = T.rect xconf+ screen = X11.defaultScreenOfDisplay disp+ depth = X11.defaultDepthOfScreen screen+ vis = X11.defaultVisualOfScreen screen+ conf = T.config xconf -printString d p (Utf8 fs) gc fc bc x y _ _ s a =- withColors d [fc, bc] $ \[fc', bc'] -> do- setForeground d gc fc'- when (a == 255) (setBackground d gc bc')- liftIO $ wcDrawImageString d p fs gc x y s+ liftIO $ withPixmap disp win rect depth $ \gc p -> do+ let bdraw = drawXBitmap xconf gc p+ blook = lookupXBitmap xconf+ dctx = D.DC bdraw blook conf (fromIntegral w) (fromIntegral h) segments+ render = DC.drawSegments dctx -#ifdef XFT-printString dpy drw fs@(Xft fonts) _ fc bc x y ay ht s al =- withDrawingColors dpy drw fc bc $ \draw fc' bc' -> do- when (al == 255) $ do- (a,d) <- textExtents fs s- gi <- xftTxtExtents' dpy fonts s- if ay < 0- then drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2)- else drawXftRect draw bc' x ay (1 + xglyphinfo_xOff gi) ht- drawXftString' draw fc' fonts (toInteger x) (toInteger y) s+#ifdef XRENDER+ color = C.bgColor conf+ alph = C.alpha conf+ XRender.drawBackground disp p color alph (X11.Rectangle 0 0 w h) #endif --- | An easy way to print the stuff we need to print-printStrings :: Drawable- -> GC- -> NE.NonEmpty XFont- -> NE.NonEmpty Int- -> Position- -> Align- -> [((Position, Position), Box)]- -> [(Widget, TextRenderInfo, Int, Position)] -> X ()-printStrings _ _ _ _ _ _ _ [] = return ()-printStrings dr gc fontlist voffs offs a boxes sl@((s,c,i,l):xs) = do- r <- ask- let (conf,d) = (config &&& display) r- alph = alpha conf- Rectangle _ _ wid ht = rect r- totSLen = foldr (\(_,_,_,len) -> (+) len) 0 sl- remWidth = fi wid - fi totSLen- fontst = safeIndex fontlist i- voff = safeIndex voffs i- offset = case a of- C -> (remWidth + offs) `div` 2- R -> remWidth- L -> offs- (fc,bc) = colorComponents conf (tColorsString c)- valign <- verticalOffset ht s fontst voff conf- let (ht',ay) = case (tBgTopOffset c, tBgBottomOffset c) of- (-1,_) -> (0, -1)- (_,-1) -> (0, -1)- (ot,ob) -> (fromIntegral ht - ot - ob, ob)- case s of- (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign ay ht' t alph- (Icon p) -> liftIO $ maybe (return ())- (B.drawBitmap d dr gc fc bc offset valign)- (lookup p (iconS r))- (Hspace _) -> liftIO $ return ()- let triBoxes = tBoxes c- dropBoxes = filter (\(_,b) -> b `notElem` triBoxes) boxes- boxes' = map (\((x1,_),b) -> ((x1, offset + l), b))- (filter (\(_,b) -> b `elem` triBoxes) boxes)- ++ map ((offset, offset + l),) (triBoxes \\ map snd boxes)- if Prelude.null xs- then liftIO $ drawBoxes d dr gc (fromIntegral ht) (dropBoxes ++ boxes')- else liftIO $ drawBoxes d dr gc (fromIntegral ht) dropBoxes- printStrings dr gc fontlist voffs (offs + l) a boxes' xs--drawBoxes :: Display- -> Drawable- -> GC- -> Position- -> [((Position, Position), Box)]- -> IO ()-drawBoxes _ _ _ _ [] = return ()-drawBoxes d dr gc ht (b:bs) = do- let (xx, Box bb offset lineWidth fc mgs) = b- lw = fromIntegral lineWidth :: Position- withColors d [fc] $ \[fc'] -> do- setForeground d gc fc'- setLineAttributes d gc lineWidth lineSolid capNotLast joinMiter- case bb of- BBVBoth -> do- drawBoxBorder d dr gc BBTop offset ht xx lw mgs- drawBoxBorder d dr gc BBBottom offset ht xx lw mgs- BBHBoth -> do- drawBoxBorder d dr gc BBLeft offset ht xx lw mgs- drawBoxBorder d dr gc BBRight offset ht xx lw mgs- BBFull -> do- drawBoxBorder d dr gc BBTop offset ht xx lw mgs- drawBoxBorder d dr gc BBBottom offset ht xx lw mgs- drawBoxBorder d dr gc BBLeft offset ht xx lw mgs- drawBoxBorder d dr gc BBRight offset ht xx lw mgs- _ -> drawBoxBorder d dr gc bb offset ht xx lw mgs- drawBoxes d dr gc ht bs--drawBoxBorder :: Display- -> Drawable- -> GC- -> BoxBorder- -> BoxOffset- -> Position- -> (Position, Position)- -> Position- -> BoxMargins- -> IO ()-drawBoxBorder- d dr gc pos (BoxOffset alg offset) ht (x1,x2) lw (BoxMargins mt mr mb ml) = do- let (p1,p2) = case alg of- L -> (0, -offset)- C -> (offset, -offset)- R -> (offset, 0 )- lc = lw `div` 2- case pos of- BBTop -> drawLine d dr gc (x1 + p1) (mt + lc) (x2 + p2) (mt + lc)- BBBottom -> do- let lc' = max lc 1 + mb- drawLine d dr gc (x1 + p1) (ht - lc') (x2 + p2) (ht - lc')- BBLeft -> drawLine d dr gc (x1 - 1 + ml) p1 (x1 - 1 + ml) (ht + p2)- BBRight -> drawLine d dr gc (x2 + lc - 1 - mr) p1 (x2 + lc - 1 - mr) (ht + p2)- _ -> error "unreachable code"+ CS.withXlibSurface disp p vis (fromIntegral w) (fromIntegral h) render
src/Xmobar/X11/Events.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.X11.Events--- Copyright: (c) 2018 Jose Antonio Ortega Ruiz+-- Copyright: (c) 2018, 2022 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org@@ -17,20 +17,19 @@ module Xmobar.X11.Events(nextEvent') where -import Control.Concurrent-import System.Posix.Types (Fd(..))+import qualified Control.Concurrent as C+import qualified System.Posix.Types as T -import Graphics.X11.Xlib (- Display(..), XEventPtr, nextEvent, pending, connectionNumber)+import qualified Graphics.X11.Xlib as X -- | A version of nextEvent that does not block in foreign calls.-nextEvent' :: Display -> XEventPtr -> IO ()+nextEvent' :: X.Display -> X.XEventPtr -> IO () nextEvent' d p = do- pend <- pending d+ pend <- X.pending d if pend /= 0- then nextEvent d p+ then X.nextEvent d p else do- threadWaitRead (Fd fd)+ C.threadWaitRead (T.Fd fd) nextEvent' d p where- fd = connectionNumber d+ fd = X.connectionNumber d
src/Xmobar/X11/Loop.hs view
@@ -19,214 +19,158 @@ module Xmobar.X11.Loop (x11Loop) where import Prelude hiding (lookup)-import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment)-import Graphics.X11.Xlib.Extras-import Graphics.X11.Xinerama-import Graphics.X11.Xrandr -import Control.Arrow ((&&&))-import Control.Monad.Reader-import Control.Concurrent-import Control.Concurrent.STM+import Control.Concurrent as Concurrent+import Control.Concurrent.STM as STM+import Control.Monad.Reader as MR -import Data.Bits-import Data.Map hiding (foldr, map, filter)+import Data.Bits (Bits((.|.)))+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map-import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (fromJust, isJust)-import qualified Data.List.NonEmpty as NE+import qualified Graphics.X11.Xlib as X11+import qualified Graphics.X11.Xlib.Extras as X11x+import qualified Graphics.X11.Xinerama as Xinerama+import qualified Graphics.X11.Xrandr as Xrandr -import Xmobar.System.Signal-import Xmobar.Config.Types ( persistent- , alpha- , font- , additionalFonts- , textOffset- , textOffsets- , position- , iconRoot- , Config- , Align(..)- , XPosition(..))+import qualified Xmobar.Config.Types as C+import qualified Xmobar.Config.Template as CT -import Xmobar.Run.Actions-import Xmobar.Run.Parsers-import Xmobar.X11.Window-import Xmobar.X11.Text-import Xmobar.X11.Draw-import Xmobar.X11.Bitmap as Bitmap-import Xmobar.X11.Types-import Xmobar.System.Utils (safeIndex, forkThread)+import qualified Xmobar.Run.Actions as A+import qualified Xmobar.Run.Loop as L -import Xmobar.Run.Loop (loop)+import qualified Xmobar.System.Utils as U+import qualified Xmobar.System.Signal as S -#ifndef THREADED_RUNTIME-import Xmobar.X11.Events(nextEvent')-#endif+import qualified Xmobar.Draw.Types as D -#ifdef XFT-import Graphics.X11.Xft+import qualified Xmobar.X11.Types as T+import qualified Xmobar.X11.Text as Text+import qualified Xmobar.X11.Draw as Draw+import qualified Xmobar.X11.Bitmap as Bitmap+import qualified Xmobar.X11.Window as W++#ifndef THREADED_RUNTIME+import qualified Xmobar.X11.Events as E #endif -runX :: XConf -> X () -> IO ()-runX xc f = runReaderT f xc+runX :: T.XConf -> T.X a -> IO a+runX xc f = MR.runReaderT f xc --- | Starts the main event loop and threads-x11Loop :: Config -> IO ()+-- | Starts the main event loop thread+x11Loop :: C.Config -> IO () x11Loop conf = do- initThreads- d <- openDisplay ""- fs <- initFont d (font conf)- fl <- mapM (initFont d) (additionalFonts conf)- let ic = Map.empty- to = textOffset conf- ts = textOffsets conf ++ replicate (length fl) (-1)-#ifdef XFT- xftInitFtLibrary-#endif- (r,w) <- createWin d fs conf- loop conf (startLoop (XConf d r w (fs :| fl) (to :| ts) ic conf))+ X11.initThreads+ d <- X11.openDisplay ""+ fs <- Text.initFont d (C.font conf)+ fl <- mapM (Text.initFont d) (C.additionalFonts conf)+ (r,w) <- W.createWin d fs conf+ L.loop conf (startLoop (T.XConf d r w (fs :| fl) Map.empty conf)) -startLoop :: XConf -> TMVar SignalType -> TVar [String] -> IO ()-startLoop xcfg@(XConf _ _ w _ _ _ _) sig tv = do- forkThread "X event handler" (x11EventLoop w sig)- signalLoop xcfg [] sig tv+startLoop :: T.XConf -> STM.TMVar S.SignalType -> STM.TVar [String] -> IO ()+startLoop xcfg sig tv = do+ U.forkThread "X event handler" (eventLoop (T.display xcfg) (T.window xcfg) sig)+ signalLoop xcfg [] sig tv -- | Translates X11 events received by w to signals handled by signalLoop-x11EventLoop :: Window -> TMVar SignalType -> IO ()-x11EventLoop w signal =- allocaXEvent $ \e -> do- dpy <- openDisplay ""- xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask- selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask)+eventLoop :: X11.Display -> X11.Window -> STM.TMVar S.SignalType -> IO ()+eventLoop dpy w signalv =+ X11.allocaXEvent $ \e -> do+ let root = X11.defaultRootWindow dpy+ m = X11.exposureMask .|. X11.structureNotifyMask .|. X11.buttonPressMask+ Xrandr.xrrSelectInput dpy root X11.rrScreenChangeNotifyMask+ X11.selectInput dpy w m - forever $ do+ MR.forever $ do #ifdef THREADED_RUNTIME- nextEvent dpy e+ X11.nextEvent dpy e #else- nextEvent' dpy e+ E.nextEvent' dpy e #endif- ev <- getEvent e+ ev <- X11x.getEvent e+ let send = STM.atomically . STM.putTMVar signalv case ev of- ConfigureEvent {} -> atomically $ putTMVar signal Reposition- ExposeEvent {} -> atomically $ putTMVar signal Wakeup- RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition- ButtonEvent {} -> atomically $- putTMVar signal (Action (ev_button ev) (fi $ ev_x ev))+ X11x.ConfigureEvent {} -> send S.Reposition+ X11x.RRScreenChangeNotifyEvent {} -> send S.Reposition+ X11x.ExposeEvent {} -> send S.Wakeup+ X11x.ButtonEvent {} -> send (S.Action b p)+ where (b, p) = (X11x.ev_button ev, fromIntegral $ X11x.ev_x ev) _ -> return () --- | Continuously wait for a signal from a thread or an interrupt handler-signalLoop :: XConf- -> [([Action], Position, Position)]- -> TMVar SignalType- -> TVar [String]- -> IO ()-signalLoop xc@(XConf d r w fs vos is cfg) as signal tv = do- typ <- atomically $ takeTMVar signal- case typ of- Wakeup -> do- str <- updateString cfg tv- xc' <- updateCache d w is (iconRoot cfg) str >>=- \c -> return xc { iconS = c }- as' <- updateActions xc r str- runX xc' $ drawInWin r str- signalLoop xc' as' signal tv-- Reposition ->- reposWindow cfg-- ChangeScreen -> do- ncfg <- updateConfigPosition cfg- reposWindow ncfg-- Hide t -> hide (t*100*1000)- Reveal t -> reveal (t*100*1000)- Toggle t -> toggle t-- TogglePersistent -> signalLoop- xc { config = cfg { persistent = not $ persistent cfg } } as signal tv-- SetAlpha a -> signalLoop xc { config = cfg { alpha = a}} as signal tv-- Action but x -> action but x-+-- | Continuously wait for a signal from a thread or an interrupt handler.+-- The list of actions provides the positions of clickable rectangles,+-- and there is a mutable variable for received signals and the list+-- of strings updated by running monitors.+signalLoop ::+ T.XConf -> D.Actions -> STM.TMVar S.SignalType -> STM.TVar [String] -> IO ()+signalLoop xc@(T.XConf d r w fs is cfg) actions signalv strs = do+ typ <- STM.atomically $ STM.takeTMVar signalv+ case typ of+ S.Wakeup -> wakeup+ S.Action button x -> runActions actions button x >> loopOn+ S.Reposition -> reposWindow cfg+ S.ChangeScreen -> updateConfigPosition d cfg >>= reposWindow+ S.Hide t -> hiderev t S.Hide W.hideWindow+ S.Reveal t -> hiderev t S.Reveal (W.showWindow r cfg)+ S.Toggle t -> toggle t+ S.TogglePersistent -> updateCfg $ cfg {C.persistent = not $ C.persistent cfg}+ S.SetAlpha a -> updateCfg $ cfg {C.alpha = a} where- isPersistent = not $ persistent cfg- loopOn = signalLoop xc as signal tv- hide t- | t == 0 =- when isPersistent (hideWindow d w) >> loopOn- | otherwise = do- void $ forkIO- $ threadDelay t >> atomically (putTMVar signal $ Hide 0)- loopOn+ loopOn' xc' = signalLoop xc' actions signalv strs+ loopOn = loopOn' xc+ updateCfg cfg' = loopOn' (xc {T.config = cfg'}) - reveal t- | t == 0 = do- when isPersistent (showWindow r cfg d w)- loopOn+ wakeup = do+ segs <- parseSegments cfg strs+ xc' <- updateIconCache xc segs+ actions' <- runX xc' (Draw.draw segs)+ signalLoop xc' actions' signalv strs++ hiderev t sign op+ | t == 0 = MR.unless (C.persistent cfg) (op d w) >> loopOn | otherwise = do- void $ forkIO- $ threadDelay t >> atomically (putTMVar signal $ Reveal 0)+ MR.void $ Concurrent.forkIO+ $ Concurrent.threadDelay (t*100*1000) >>+ STM.atomically (STM.putTMVar signalv $ sign 0) loopOn toggle t = do- ismapped <- isMapped d w- atomically (putTMVar signal $ if ismapped then Hide t else Reveal t)- loopOn+ ismapped <- W.isMapped d w+ let s = if ismapped then S.Hide t else S.Reveal t+ STM.atomically (STM.putTMVar signalv s)+ loopOn reposWindow rcfg = do- r' <- repositionWin d w (NE.head fs) rcfg- signalLoop (XConf d r' w fs vos is rcfg) as signal tv+ r' <- W.repositionWin d w (NE.head fs) rcfg+ signalLoop (T.XConf d r' w fs is rcfg) actions signalv strs - updateConfigPosition ocfg =- case position ocfg of- OnScreen n o -> do- srs <- getScreenInfo d- return (if n == length srs- then- (ocfg {position = OnScreen 1 o})- else- (ocfg {position = OnScreen (n+1) o}))- o -> return (ocfg {position = OnScreen 1 o})+parseSegments :: C.Config -> STM.TVar [String] -> IO [[C.Segment]]+parseSegments conf v = do+ s <- STM.readTVarIO v+ let l:c:r:_ = s ++ repeat ""+ return $ map (CT.parseString conf) [l, c, r] - action button x = do- mapM_ runAction $- filter (\(Spawn b _) -> button `elem` b) $- concatMap (\(a,_,_) -> a) $- filter (\(_, from, to) -> x >= from && x <= to) as- loopOn+updateIconCache :: T.XConf -> [[C.Segment]] -> IO T.XConf+updateIconCache xc@(T.XConf d _ w _ c cfg) segs = do+ let paths = [p | (C.Icon p, _, _, _) <- concat segs]+ c' <- Bitmap.updateCache d w c (C.iconRoot cfg) paths+ return $ xc {T.iconCache = c'} -updateString :: Config -> TVar [String] -> IO [[Segment]]-updateString conf v = do- s <- readTVarIO v- let l:c:r:_ = s ++ repeat ""- liftIO $ mapM (parseString conf) [l, c, r]+updateConfigPosition :: X11.Display -> C.Config -> IO C.Config+updateConfigPosition disp cfg =+ case C.position cfg of+ C.OnScreen n o -> do+ srs <- Xinerama.getScreenInfo disp+ return (if n == length srs+ then (cfg {C.position = C.OnScreen 1 o})+ else (cfg {C.position = C.OnScreen (n+1) o}))+ o -> return (cfg {C.position = C.OnScreen 1 o}) -updateActions :: XConf -> Rectangle -> [[Segment]]- -> IO [([Action], Position, Position)]-updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do- let (d,fs) = (display &&& fontListS) conf- strLn :: [Segment] -> IO [(Maybe [Action], Position, Position)]- strLn = liftIO . mapM getCoords- iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf)- getCoords (Text s,_,i,a) =- textWidth d (safeIndex fs i) s >>= \tw -> return (a, 0, fi tw)- getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s)- getCoords (Hspace w,_,_,a) = return (a, 0, fi w)- partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $- filter (\(a, _,_) -> isJust a) $- scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w'))- (Nothing, 0, off)- xs- totSLen = foldr (\(_,_,len) -> (+) len) 0- remWidth xs = fi wid - totSLen xs- offs = 1- offset a xs = case a of- C -> (remWidth xs + offs) `div` 2- R -> remWidth xs- L -> offs- fmap concat $ mapM (\(a,xs) ->- (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $- zip [L,C,R] [left,center,right]+runActions :: D.Actions -> A.Button -> X11.Position -> IO ()+runActions actions button pos =+ mapM_ A.runAction $+ filter (\(A.Spawn b _) -> button `elem` b) $+ concatMap (\(a,_,_) -> a) $+ filter (\(_, from, to) -> pos' >= from && pos' <= to) actions+ where pos' = fromIntegral pos
− src/Xmobar/X11/MinXft.hsc
@@ -1,333 +0,0 @@---------------------------------------------------------------------------------- |--- Module: MinXft--- Copyright: (c) 2012, 2014, 2015, 2017 Jose Antonio Ortega Ruiz--- (c) Clemens Fruhwirth <clemens@endorphin.org> 2007--- License: BSD3-style (see LICENSE)------ Maintainer: jao@gnu.org--- Stability: unstable--- Portability: unportable--- Created: Mon Sep 10, 2012 18:12--------- Pared down Xft library, based on Graphics.X11.Xft and providing--- explicit management of XftColors, so that they can be cached.------ Most of the code is lifted from Clemens's.------------------------------------------------------------------------------------{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}--module Xmobar.X11.MinXft ( AXftColor- , AXftDraw (..)- , AXftFont- , mallocAXftColor- , freeAXftColor- , withAXftDraw- , drawXftString- , drawXftString'- , drawBackground- , drawXftRect- , openAXftFont- , closeAXftFont- , xftTxtExtents- , xftTxtExtents'- , xft_ascent- , xft_ascent'- , xft_descent- , xft_descent'- , xft_height- , xft_height'- )--where--import Graphics.X11-import Graphics.X11.Xlib.Types-import Graphics.X11.Xrender-import Graphics.X11.Xlib.Extras (xGetWindowProperty, xFree)--import Foreign-import Foreign.C.Types-import Foreign.C.String-import Codec.Binary.UTF8.String as UTF8-import Data.Char (ord)--import Control.Monad (when)--#include <X11/Xft/Xft.h>---- Color Handling--newtype AXftColor = AXftColor (Ptr AXftColor)--foreign import ccall "XftColorAllocName"- cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool)---- this is the missing bit in X11.Xft, not implementable from the--- outside because XftColor does not export a constructor.-mallocAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor-mallocAXftColor d v cm n = do- color <- mallocBytes (#size XftColor)- withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color)- return (AXftColor color)--foreign import ccall "XftColorFree"- freeAXftColor :: Display -> Visual -> Colormap -> AXftColor -> IO ()---- Font handling--newtype AXftFont = AXftFont (Ptr AXftFont)--xft_ascent :: AXftFont -> IO Int-xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent}--xft_ascent' :: [AXftFont] -> IO Int-xft_ascent' = (fmap maximum) . (mapM xft_ascent)--xft_descent :: AXftFont -> IO Int-xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent}--xft_descent' :: [AXftFont] -> IO Int-xft_descent' = (fmap maximum) . (mapM xft_descent)--xft_height :: AXftFont -> IO Int-xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height}--xft_height' :: [AXftFont] -> IO Int-xft_height' = (fmap maximum) . (mapM xft_height)--foreign import ccall "XftTextExtentsUtf8"- cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO ()--xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo-xftTxtExtents d f string =- withArrayLen (map fi (UTF8.encode string)) $- \len str_ptr -> alloca $- \cglyph -> do- cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph- peek cglyph--xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo-xftTxtExtents' d fs string = do- chunks <- getChunks d fs string- let (_, _, gi, _, _) = last chunks- return gi--foreign import ccall "XftFontOpenName"- c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont--openAXftFont :: Display -> Screen -> String -> IO AXftFont-openAXftFont dpy screen name =- withCAString name $- \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname--foreign import ccall "XftFontClose"- closeAXftFont :: Display -> AXftFont -> IO ()--foreign import ccall "XftCharExists"- cXftCharExists :: Display -> AXftFont -> (#type FcChar32) -> IO (#type FcBool)--xftCharExists :: Display -> AXftFont -> Char -> IO Bool-xftCharExists d f c = bool `fmap` cXftCharExists d f (fi $ ord c)- where- bool 0 = False- bool _ = True--- Drawing--fi :: (Integral a, Num b) => a -> b-fi = fromIntegral--newtype AXftDraw = AXftDraw (Ptr AXftDraw)--foreign import ccall "XftDrawCreate"- c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw--foreign import ccall "XftDrawDisplay"- c_xftDrawDisplay :: AXftDraw -> IO Display--foreign import ccall "XftDrawDestroy"- c_xftDrawDestroy :: AXftDraw -> IO ()--withAXftDraw :: Display -> Drawable -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a-withAXftDraw d p v c act = do- draw <- c_xftDrawCreate d p v c- a <- act draw- c_xftDrawDestroy draw- return a--foreign import ccall "XftDrawStringUtf8"- cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO ()--drawXftString :: (Integral a1, Integral a) =>- AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO ()-drawXftString d c f x y string =- withArrayLen (map fi (UTF8.encode string))- (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len))--drawXftString' :: AXftDraw ->- AXftColor ->- [AXftFont] ->- Integer ->- Integer ->- String -> IO ()-drawXftString' d c fs x y string = do- display <- c_xftDrawDisplay d- chunks <- getChunks display fs string- mapM_ (\(f, s, _, xo, yo) -> drawXftString d c f (x+xo) (y+yo) s) chunks---- Split string and determine fonts/offsets for individual parts-getChunks :: Display -> [AXftFont] -> String ->- IO [(AXftFont, String, XGlyphInfo, Integer, Integer)]-getChunks disp fts str = do- chunks <- getFonts disp fts str- getOffsets (XGlyphInfo 0 0 0 0 0 0) chunks- where- -- Split string and determine fonts for individual parts- getFonts _ [] _ = return []- getFonts _ _ [] = return []- getFonts _ [ft] s = return [(ft, s)]- getFonts d fonts@(ft:_) s = do- -- Determine which glyph can be rendered by current font- glyphs <- mapM (xftCharExists d ft) s- -- Split string into parts that can/cannot be rendered- let splits = split (runs glyphs) s- -- Determine which font to render each chunk with- concat `fmap` mapM (getFont d fonts) splits-- -- Determine fonts for substrings- getFont _ [] _ = return []- getFont _ [ft] (_, s) = return [(ft, s)] -- Last font, use it- getFont _ (ft:_) (True, s) = return [(ft, s)] -- Current font can render this substring- getFont d (_:fs) (False, s) = getFonts d fs s -- Fallback to next font-- -- Helpers- runs [] = []- runs (x:xs) = let (h, t) = span (==x) xs in (x, length h + 1) : runs t- split [] _ = []- split ((x, c):xs) s = let (h, t) = splitAt c s in (x, h) : split xs t-- -- Determine coordinates for chunks using extents- getOffsets _ [] = return []- getOffsets (XGlyphInfo _ _ x y xo yo) ((f, s):chunks) = do- (XGlyphInfo w' h' _ _ xo' yo') <- xftTxtExtents disp f s- let gi = XGlyphInfo (xo+w') (yo+h') x y (xo+xo') (yo+yo')- rest <- getOffsets gi chunks- return $ (f, s, gi, fromIntegral xo, fromIntegral yo) : rest--foreign import ccall "XftDrawRect"- cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()--drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) =>- AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO ()-drawXftRect draw color x y width height =- cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height)--#include <X11/extensions/Xrender.h>--type Picture = XID-type PictOp = CInt--data XRenderPictFormat-data XRenderPictureAttributes = XRenderPictureAttributes---- foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFillRectangle"- -- xRenderFillRectangle :: Display -> PictOp -> Picture -> Ptr XRenderColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()-foreign import ccall unsafe "X11/extensions/Xrender.h XRenderComposite"- xRenderComposite :: Display -> PictOp -> Picture -> Picture -> Picture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CUInt -> CUInt -> IO ()-foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreateSolidFill"- xRenderCreateSolidFill :: Display -> Ptr XRenderColor -> IO Picture-foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFreePicture"- xRenderFreePicture :: Display -> Picture -> IO ()-foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO ()-foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFindStandardFormat"- xRenderFindStandardFormat :: Display -> CInt -> IO (Ptr XRenderPictFormat)-foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreatePicture"- xRenderCreatePicture :: Display -> Drawable -> Ptr XRenderPictFormat -> CULong -> Ptr XRenderPictureAttributes -> IO Picture----- Attributes not supported-instance Storable XRenderPictureAttributes where- sizeOf _ = #{size XRenderPictureAttributes}- alignment _ = alignment (undefined :: CInt)- peek _ = return XRenderPictureAttributes- poke p XRenderPictureAttributes =- memset p 0 #{size XRenderPictureAttributes}---- | Convenience function, gives us an XRender handle to a traditional--- Pixmap. Don't let it escape.-withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO ()-withRenderPicture d p f = do- format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24- alloca $ \attr -> do- pic <- xRenderCreatePicture d p format 0 attr- f pic- xRenderFreePicture d pic---- | Convenience function, gives us an XRender picture that is a solid--- fill of color 'c'. Don't let it escape.-withRenderFill :: Display -> XRenderColor -> (Picture -> IO a) -> IO ()-withRenderFill d c f = do- pic <- with c (xRenderCreateSolidFill d)- f pic- xRenderFreePicture d pic---- | Drawing the background to a pixmap and taking into account--- transparency-drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO ()-drawBackground d p bgc alpha (Rectangle x y wid ht) = do- let render opt bg pic m =- xRenderComposite d opt bg m pic- (fromIntegral x) (fromIntegral y) 0 0- 0 0 (fromIntegral wid) (fromIntegral ht)- withRenderPicture d p $ \pic -> do- -- Handle background color- bgcolor <- parseRenderColor d bgc- withRenderFill d bgcolor $ \bgfill ->- withRenderFill d- (XRenderColor 0 0 0 (257 * alpha))- (render pictOpSrc bgfill pic)- -- Handle transparency- internAtom d "_XROOTPMAP_ID" False >>= \xid ->- let xroot = defaultRootWindow d in- alloca $ \x1 ->- alloca $ \x2 ->- alloca $ \x3 ->- alloca $ \x4 ->- alloca $ \pprop -> do- xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop- prop <- peek pprop- when (prop /= nullPtr) $ do- rootbg <- peek (castPtr prop) :: IO Pixmap- xFree prop- withRenderPicture d rootbg $ \bgpic ->- withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha))- (render pictOpAdd bgpic pic)---- | Parses color into XRender color (allocation not necessary!)-parseRenderColor :: Display -> String -> IO XRenderColor-parseRenderColor d c = do- let colormap = defaultColormap d (defaultScreen d)- Color _ red green blue _ <- parseColor d colormap c- return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF--pictOpSrc, pictOpAdd :: PictOp-pictOpSrc = 1-pictOpAdd = 12---- pictOpMinimum = 0--- pictOpClear = 0--- pictOpDst = 2--- pictOpOver = 3--- pictOpOverReverse = 4--- pictOpIn = 5--- pictOpInReverse = 6--- pictOpOut = 7--- pictOpOutReverse = 8--- pictOpAtop = 9--- pictOpAtopReverse = 10--- pictOpXor = 11--- pictOpSaturate = 13--- pictOpMaximum = 13
src/Xmobar/X11/Text.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Xmobar.X11.Text--- Copyright : (C) 2011, 2012, 2013, 2014, 2015, 2017, 2018 Jose Antonio Ortega Ruiz+-- Copyright : (C) 2011-2015, 2017, 2018, 2022 Jose Antonio Ortega Ruiz -- (C) 2007 Andrea Rossato -- License : BSD3 --@@ -14,116 +14,44 @@ ----------------------------------------------------------------------------- module Xmobar.X11.Text- ( XFont(..)+ ( XFont , initFont- , initCoreFont- , initUtf8Font , textExtents , textWidth ) where -import Control.Exception (SomeException, handle)-import Data.List-import Foreign-import Graphics.X11.Xlib hiding (textExtents, textWidth)-import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth)-import Graphics.X11.Xlib.Extras-import System.Mem.Weak ( addFinalizer )+import qualified Control.Exception as E+import qualified Foreign as F+import qualified System.Mem.Weak as W -#if defined XFT-import Xmobar.X11.MinXft-import Graphics.X11.Xrender-#else-import System.IO(hPutStrLn, stderr)-#endif+import qualified Graphics.X11.Xlib as X+import qualified Graphics.X11.Xlib.Extras as Xx -data XFont = Core FontStruct- | Utf8 FontSet-#ifdef XFT- | Xft [AXftFont]-#endif+type XFont = Xx.FontSet --- | When initFont gets a font name that starts with 'xft:' it switchs--- to the Xft backend Example: 'xft:Sans-10'-initFont :: Display -> String -> IO XFont-initFont d s =- let xftPrefix = "xft:" in- if xftPrefix `isPrefixOf` s then-#ifdef XFT- fmap Xft $ initXftFont d s-#else- do- hPutStrLn stderr $ "Warning: Xmobar must be built with "- ++ "the with_xft flag to support font '" ++ s- ++ ".' Falling back on default."- initFont d miscFixedFont-#endif- else- fmap Utf8 $ initUtf8Font d s+initFont :: X.Display -> String -> IO XFont+initFont = initUtf8Font miscFixedFont :: String miscFixedFont = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*" -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned.-initCoreFont :: Display -> String -> IO FontStruct-initCoreFont d s = do- f <- handle fallBack getIt- addFinalizer f (freeFont d f)- return f- where getIt = loadQueryFont d s- fallBack :: SomeException -> IO FontStruct- fallBack = const $ loadQueryFont d miscFixedFont---- | Given a fontname returns the font structure. If the font name is--- not valid the default font will be loaded and returned.-initUtf8Font :: Display -> String -> IO FontSet+initUtf8Font :: X.Display -> String -> IO Xx.FontSet initUtf8Font d s = do- (_,_,f) <- handle fallBack getIt- addFinalizer f (freeFontSet d f)+ (_,_,f) <- E.handle fallBack getIt+ W.addFinalizer f (Xx.freeFontSet d f) return f- where getIt = createFontSet d s- fallBack :: SomeException -> IO ([String], String, FontSet)- fallBack = const $ createFontSet d miscFixedFont--#ifdef XFT-initXftFont :: Display -> String -> IO [AXftFont]-initXftFont d s = do- let fontNames = wordsBy (== ',') (drop 4 s)- mapM openFont fontNames- where- openFont fontName = do- f <- openAXftFont d (defaultScreenOfDisplay d) fontName- addFinalizer f (closeAXftFont d f)- return f- wordsBy p str = case dropWhile p str of- "" -> []- str' -> w : wordsBy p str''- where- (w, str'') = break p str'-#endif+ where getIt = Xx.createFontSet d s+ fallBack :: E.SomeException -> IO ([String], String, Xx.FontSet)+ fallBack = const $ Xx.createFontSet d miscFixedFont -textWidth :: Display -> XFont -> String -> IO Int-textWidth _ (Utf8 fs) s = return $ fromIntegral $ wcTextEscapement fs s-textWidth _ (Core fs) s = return $ fromIntegral $ Xlib.textWidth fs s-#ifdef XFT-textWidth dpy (Xft xftdraw) s = do- gi <- xftTxtExtents' dpy xftdraw s- return $ xglyphinfo_xOff gi-#endif+textWidth :: X.Display -> XFont -> String -> IO Int+textWidth _ fs s = return $ fromIntegral $ Xx.wcTextEscapement fs s -textExtents :: XFont -> String -> IO (Int32,Int32)-textExtents (Core fs) s = do- let (_,a,d,_) = Xlib.textExtents fs s- return (a,d)-textExtents (Utf8 fs) s = do- let (_,rl) = wcTextExtents fs s- ascent = fromIntegral $ negate (rect_y rl)- descent = fromIntegral $ rect_height rl + fromIntegral (rect_y rl)- return (ascent, descent)-#ifdef XFT-textExtents (Xft xftfonts) _ = do- ascent <- fromIntegral `fmap` xft_ascent' xftfonts- descent <- fromIntegral `fmap` xft_descent' xftfonts+textExtents :: XFont -> String -> IO (F.Int32, F.Int32)+textExtents fs s = do+ let (_,rl) = Xx.wcTextExtents fs s+ ascent = fromIntegral $ negate (X.rect_y rl)+ descent = fromIntegral $ X.rect_height rl + fromIntegral (X.rect_y rl) return (ascent, descent)-#endif
src/Xmobar/X11/Types.hs view
@@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.Types--- Copyright: (c) 2018 Jose Antonio Ortega Ruiz+-- Copyright: (c) 2018, 2022 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org@@ -15,27 +15,27 @@ ------------------------------------------------------------------------------ -module Xmobar.X11.Types (X, XConf (..)) where+module Xmobar.X11.Types where -import Graphics.X11.Xlib-import Control.Monad.Reader-import Data.Map+import qualified Graphics.X11.Xlib as X11 import qualified Data.List.NonEmpty as NE -import Xmobar.X11.Bitmap-import Xmobar.X11.Text+import Control.Monad.Reader (ReaderT)+ import Xmobar.Config.Types +import Xmobar.X11.Bitmap (BitmapCache)+import Xmobar.X11.Text (XFont)+ -- | The X type is a ReaderT type X = ReaderT XConf IO -- | The ReaderT inner component data XConf =- XConf { display :: Display- , rect :: Rectangle- , window :: Window- , fontListS :: NE.NonEmpty XFont- , verticalOffsets :: NE.NonEmpty Int- , iconS :: Map FilePath Bitmap+ XConf { display :: X11.Display+ , rect :: X11.Rectangle+ , window :: X11.Window+ , fontList :: NE.NonEmpty XFont+ , iconCache :: BitmapCache , config :: Config }
src/Xmobar/X11/Window.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Window--- Copyright : (c) 2011-18, 20, 21 Jose A. Ortega Ruiz+-- Copyright : (c) 2011-18, 2020-22 Jose A. Ortega Ruiz -- : (c) 2012 Jochen Keil -- License : BSD-style (see LICENSE) --@@ -15,164 +15,171 @@ module Xmobar.X11.Window where -import Prelude-import Control.Monad (when, unless)-import Graphics.X11.Xlib hiding (textExtents)-import Graphics.X11.Xlib.Extras-import Graphics.X11.Xinerama-import Foreign.C.Types (CLong)+import qualified Control.Monad as CM -import Data.Function (on)-import Data.List (maximumBy)-import Data.Maybe (fromMaybe)-import System.Posix.Process (getProcessID)+import qualified Data.Function as DF+import qualified Data.List as DL+import qualified Data.Maybe as DM -import Xmobar.Config.Types-import Xmobar.X11.Text+import qualified Graphics.X11.Xlib as X+import qualified Graphics.X11.Xlib.Extras as Xx +import qualified Graphics.X11.Xinerama as Xi+import qualified Foreign.C.Types as C++import qualified System.Posix.Process as PP++import qualified Xmobar.Config.Types as T+import qualified Xmobar.X11.Text as Txt+ -- $window -- | Creates a window with the attribute override_redirect set to True. -- Windows Managers should not touch this kind of windows.-newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window-newWindow dpy scr rw (Rectangle x y w h) o = do- let visual = defaultVisualOfScreen scr- attrmask = if o then cWOverrideRedirect else 0- allocaSetWindowAttributes $+newWindow ::+ X.Display -> X.Screen -> X.Window -> X.Rectangle -> Bool -> IO X.Window+newWindow dpy scr rw (X.Rectangle x y w h) o = do+ let visual = X.defaultVisualOfScreen scr+ attrmask = if o then X.cWOverrideRedirect else 0+ X.allocaSetWindowAttributes $ \attributes -> do- set_override_redirect attributes o- createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr)- inputOutput visual attrmask attributes+ X.set_override_redirect attributes o+ X.createWindow dpy rw x y w h 0 (X.defaultDepthOfScreen scr)+ X.inputOutput visual attrmask attributes -- | The function to create the initial window-createWin :: Display -> XFont -> Config -> IO (Rectangle,Window)+createWin :: X.Display -> Txt.XFont -> T.Config -> IO (X.Rectangle, X.Window) createWin d fs c = do- let dflt = defaultScreen d- srs <- getScreenInfo d- rootw <- rootWindow d dflt- (as,ds) <- textExtents fs "0"+ let dflt = X.defaultScreen d+ srs <- Xi.getScreenInfo d+ rootw <- X.rootWindow d dflt+ (as,ds) <- Txt.textExtents fs "0" let ht = as + ds + 4- r = setPosition c (position c) srs (fromIntegral ht)- win <- newWindow d (defaultScreenOfDisplay d) rootw r (overrideRedirect c)+ r = setPosition c (T.position c) srs (fromIntegral ht)+ win <- newWindow d (X.defaultScreenOfDisplay d) rootw r (T.overrideRedirect c) setProperties c d win setStruts r c d win srs- when (lowerOnStart c) $ lowerWindow d win- unless (hideOnStart c) $ showWindow r c d win+ CM.when (T.lowerOnStart c) $ X.lowerWindow d win+ CM.unless (T.hideOnStart c) $ showWindow r c d win return (r,win) -- | Updates the size and position of the window-repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle+repositionWin :: X.Display -> X.Window -> Txt.XFont -> T.Config -> IO X.Rectangle repositionWin d win fs c = do- srs <- getScreenInfo d- (as,ds) <- textExtents fs "0"+ srs <- Xi.getScreenInfo d+ (as,ds) <- Txt.textExtents fs "0" let ht = as + ds + 4- r = setPosition c (position c) srs (fromIntegral ht)- moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r)+ r = setPosition c (T.position c) srs (fromIntegral ht)+ X.moveResizeWindow d win+ (X.rect_x r) (X.rect_y r) (X.rect_width r) (X.rect_height r) setStruts r c d win srs- sync d False+ X.sync d False return r fi :: (Integral a, Num b) => a -> b fi = fromIntegral -setPosition :: Config -> XPosition -> [Rectangle] -> Dimension -> Rectangle+setPosition ::+ T.Config -> T.XPosition -> [X.Rectangle] -> X.Dimension -> X.Rectangle setPosition c p rs ht = case p' of- Top -> Rectangle rx ry rw h- TopP l r -> Rectangle (rx + fi l) ry (rw - fi l - fi r) h- TopH ch -> Rectangle rx ry rw (mh ch)- TopW a i -> Rectangle (ax a i) ry (nw i) h- TopSize a i ch -> Rectangle (ax a i) ry (nw i) (mh ch)- Bottom -> Rectangle rx ny rw h- BottomH ch -> Rectangle rx (ny' ch) rw (mh ch)- BottomW a i -> Rectangle (ax a i) ny (nw i) h- BottomP l r -> Rectangle (rx + fi l) ny (rw - fi l - fi r) h- BottomSize a i ch -> Rectangle (ax a i) (ny' ch) (nw i) (mh ch)- Static cx cy cw ch -> Rectangle (fi cx) (fi cy) (fi cw) (fi ch)- OnScreen _ p'' -> setPosition c p'' [scr] ht+ T.Top -> X.Rectangle rx ry rw h+ T.TopP l r -> X.Rectangle (rx + fi l) ry (rw - fi l - fi r) h+ T.TopH ch -> X.Rectangle rx ry rw (mh ch)+ T.TopW a i -> X.Rectangle (ax a i) ry (nw i) h+ T.TopSize a i ch -> X.Rectangle (ax a i) ry (nw i) (mh ch)+ T.Bottom -> X.Rectangle rx ny rw h+ T.BottomH ch -> X.Rectangle rx (ny' ch) rw (mh ch)+ T.BottomW a i -> X.Rectangle (ax a i) ny (nw i) h+ T.BottomP l r -> X.Rectangle (rx + fi l) ny (rw - fi l - fi r) h+ T.BottomSize a i ch -> X.Rectangle (ax a i) (ny' ch) (nw i) (mh ch)+ T.Static cx cy cw ch -> X.Rectangle (fi cx) (fi cy) (fi cw) (fi ch)+ T.OnScreen _ p'' -> setPosition c p'' [scr] ht where- (scr@(Rectangle rx ry rw rh), p') =- case p of OnScreen i x -> (fromMaybe (picker rs) $ safeIndex i rs, x)+ (scr@(X.Rectangle rx ry rw rh), p') =+ case p of T.OnScreen i x -> (DM.fromMaybe (picker rs) $ safeIndex i rs, x) _ -> (picker rs, p) ny = ry + fi (rh - ht) center i = rx + fi (div (remwid i) 2) right i = rx + fi (remwid i) remwid i = rw - pw (fi i)- ax L = const rx- ax R = right- ax C = center+ ax T.L = const rx+ ax T.R = right+ ax T.C = center pw i = rw * min 100 i `div` 100 nw = fi . pw . fi h = fi ht mh h' = max (fi h') h ny' h' = ry + fi (rh - mh h') safeIndex i = lookup i . zip [0..]- picker = if pickBroadest c- then maximumBy (compare `on` rect_width)+ picker = if T.pickBroadest c+ then DL.maximumBy (compare `DF.on` X.rect_width) else head -setProperties :: Config -> Display -> Window -> IO ()+setProperties :: T.Config -> X.Display -> X.Window -> IO () setProperties c d w = do- let mkatom n = internAtom d n False+ let mkatom n = X.internAtom d n False card <- mkatom "CARDINAL" atom <- mkatom "ATOM" - setTextProperty d w (wmClass c) wM_CLASS- setTextProperty d w (wmName c) wM_NAME+ X.setTextProperty d w (T.wmClass c) X.wM_CLASS+ X.setTextProperty d w (T.wmName c) X.wM_NAME wtype <- mkatom "_NET_WM_WINDOW_TYPE" dock <- mkatom "_NET_WM_WINDOW_TYPE_DOCK"- changeProperty32 d w wtype atom propModeReplace [fi dock]+ Xx.changeProperty32 d w wtype atom Xx.propModeReplace [fi dock] - when (allDesktops c) $ do+ CM.when (T.allDesktops c) $ do desktop <- mkatom "_NET_WM_DESKTOP"- changeProperty32 d w desktop card propModeReplace [0xffffffff]+ Xx.changeProperty32 d w desktop card Xx.propModeReplace [0xffffffff] pid <- mkatom "_NET_WM_PID"- getProcessID >>= changeProperty32 d w pid card propModeReplace . return . fi+ PP.getProcessID >>=+ Xx.changeProperty32 d w pid card Xx.propModeReplace . return . fi -setStruts' :: Display -> Window -> [Foreign.C.Types.CLong] -> IO ()+setStruts' :: X.Display -> X.Window -> [C.CLong] -> IO () setStruts' d w svs = do- let mkatom n = internAtom d n False+ let mkatom n = X.internAtom d n False card <- mkatom "CARDINAL" pstrut <- mkatom "_NET_WM_STRUT_PARTIAL" strut <- mkatom "_NET_WM_STRUT"- changeProperty32 d w pstrut card propModeReplace svs- changeProperty32 d w strut card propModeReplace (take 4 svs)+ Xx.changeProperty32 d w pstrut card Xx.propModeReplace svs+ Xx.changeProperty32 d w strut card Xx.propModeReplace (take 4 svs) -setStruts :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO ()+setStruts ::+ X.Rectangle -> T.Config -> X.Display -> X.Window -> [X.Rectangle] -> IO () setStruts r c d w rs = do- let svs = map fi $ getStrutValues r (position c) (getRootWindowHeight rs)+ let svs = map fi $ getStrutValues r (T.position c) (getRootWindowHeight rs) setStruts' d w svs -getRootWindowHeight :: [Rectangle] -> Int+getRootWindowHeight :: [X.Rectangle] -> Int getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) where- getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr)+ getMaxScreenYCoord sr = fi (X.rect_y sr) + fi (X.rect_height sr) -getStrutValues :: Rectangle -> XPosition -> Int -> [Int]-getStrutValues r@(Rectangle x y w h) p rwh =+getStrutValues :: X.Rectangle -> T.XPosition -> Int -> [Int]+getStrutValues r@(X.Rectangle x y w h) p rwh = case p of- OnScreen _ p' -> getStrutValues r p' rwh- Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]- TopH _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]- TopP _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]- TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]- TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]- Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]- BottomH _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]- BottomP _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]- BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]- BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]- Static {} -> getStaticStrutValues p rwh+ T.OnScreen _ p' -> getStrutValues r p' rwh+ T.Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]+ T.TopH _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]+ T.TopP _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]+ T.TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]+ T.TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]+ T.Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]+ T.BottomH _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]+ T.BottomP _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]+ T.BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]+ T.BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]+ T.Static {} -> getStaticStrutValues p rwh where st = fi y + fi h sb = rwh - fi y nx = fi x nw = fi (x + fi w - 1) -- get some reaonable strut values for static placement.-getStaticStrutValues :: XPosition -> Int -> [Int]-getStaticStrutValues (Static cx cy cw ch) rwh+getStaticStrutValues :: T.XPosition -> Int -> [Int]+getStaticStrutValues (T.Static cx cy cw ch) rwh -- if the yPos is in the top half of the screen, then assume a Top -- placement, otherwise, it's a Bottom placement | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0]@@ -183,51 +190,17 @@ xe = xs + cw - 1 getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] -drawBorder :: Border -> Int -> Display -> Drawable -> GC -> Pixel- -> Dimension -> Dimension -> IO ()-drawBorder b lw d p gc c wi ht = case b of- NoBorder -> return ()- TopB -> drawBorder (TopBM 0) lw d p gc c wi ht- BottomB -> drawBorder (BottomBM 0) lw d p gc c wi ht- FullB -> drawBorder (FullBM 0) lw d p gc c wi ht- TopBM m -> sf >> sla >>- drawLine d p gc 0 (fi m + boff) (fi wi) (fi m + boff)- BottomBM m -> let rw = fi ht - fi m + boff in- sf >> sla >> drawLine d p gc 0 rw (fi wi) rw- FullBM m -> let mp = fi m- pad = 2 * fi mp + fi lw- in sf >> sla >>- drawRectangle d p gc mp mp (wi - pad) (ht - pad)- where sf = setForeground d gc c- sla = setLineAttributes d gc (fi lw) lineSolid capNotLast joinMiter- boff = borderOffset b lw--- boff' = calcBorderOffset lw :: Int--hideWindow :: Display -> Window -> IO ()+hideWindow :: X.Display -> X.Window -> IO () hideWindow d w = do setStruts' d w (replicate 12 0)- unmapWindow d w >> sync d False+ Xx.unmapWindow d w >> X.sync d False -showWindow :: Rectangle -> Config -> Display -> Window -> IO ()+showWindow :: X.Rectangle -> T.Config -> X.Display -> X.Window -> IO () showWindow r c d w = do- mapWindow d w- getScreenInfo d >>= setStruts r c d w- sync d False--isMapped :: Display -> Window -> IO Bool-isMapped d w = ism <$> getWindowAttributes d w- where ism WindowAttributes { wa_map_state = wms } = wms /= waIsUnmapped--borderOffset :: (Integral a) => Border -> Int -> a-borderOffset b lw =- case b of- BottomB -> negate boffs- BottomBM _ -> negate boffs- TopB -> boffs- TopBM _ -> boffs- _ -> 0- where boffs = calcBorderOffset lw+ X.mapWindow d w+ Xi.getScreenInfo d >>= setStruts r c d w+ X.sync d False -calcBorderOffset :: (Integral a) => Int -> a-calcBorderOffset = ceiling . (/2) . toDouble- where toDouble = fi :: (Integral a) => a -> Double+isMapped :: X.Display -> X.Window -> IO Bool+isMapped d w = ism <$> Xx.getWindowAttributes d w+ where ism Xx.WindowAttributes { Xx.wa_map_state = wms } = wms /= Xx.waIsUnmapped
+ src/Xmobar/X11/XRender.hsc view
@@ -0,0 +1,138 @@+------------------------------------------------------------------------------+-- |+-- Module: Xmobar.X11.XRender+-- Copyright: (c) 2012, 2014, 2015, 2017, 2022 Jose Antonio Ortega Ruiz+-- (c) Clemens Fruhwirth <clemens@endorphin.org> 2007+-- License: BSD3-style (see LICENSE)+--+-- Maintainer: jao@gnu.org+-- Stability: unstable+-- Portability: unportable+-- Created: Sun Sep 11, 2022 01:27+--+--+-- A couple of utilities imported from libxrender to allow alpha blending of+-- an image backgrond.+--+------------------------------------------------------------------------------++{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}++module Xmobar.X11.XRender (drawBackground) where++import Graphics.X11+import Graphics.X11.Xrender+import Graphics.X11.Xlib.Extras (xGetWindowProperty, xFree)+import Control.Monad (when)++import Foreign+import Foreign.C.Types++#include <X11/extensions/Xrender.h>++type Picture = XID+type PictOp = CInt++data XRenderPictFormat+data XRenderPictureAttributes = XRenderPictureAttributes++-- foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFillRectangle"+-- xRenderFillRectangle :: Display -> PictOp -> Picture -> Ptr XRenderColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderComposite"+ xRenderComposite :: Display -> PictOp -> Picture -> Picture -> Picture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CUInt -> CUInt -> IO ()+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreateSolidFill"+ xRenderCreateSolidFill :: Display -> Ptr XRenderColor -> IO Picture+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFreePicture"+ xRenderFreePicture :: Display -> Picture -> IO ()+foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO ()+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFindStandardFormat"+ xRenderFindStandardFormat :: Display -> CInt -> IO (Ptr XRenderPictFormat)+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreatePicture"+ xRenderCreatePicture :: Display -> Drawable -> Ptr XRenderPictFormat -> CULong -> Ptr XRenderPictureAttributes -> IO Picture++-- Attributes not supported+instance Storable XRenderPictureAttributes where+ sizeOf _ = #{size XRenderPictureAttributes}+ alignment _ = alignment (undefined :: CInt)+ peek _ = return XRenderPictureAttributes+ poke p XRenderPictureAttributes =+ memset p 0 #{size XRenderPictureAttributes}++-- | Convenience function, gives us an XRender handle to a traditional+-- Pixmap. Don't let it escape.+withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO ()+withRenderPicture d p f = do+ format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24+ alloca $ \attr -> do+ pic <- xRenderCreatePicture d p format 0 attr+ f pic+ xRenderFreePicture d pic++-- | Convenience function, gives us an XRender picture that is a solid+-- fill of color 'c'. Don't let it escape.+withRenderFill :: Display -> XRenderColor -> (Picture -> IO a) -> IO ()+withRenderFill d c f = do+ pic <- with c (xRenderCreateSolidFill d)+ f pic+ xRenderFreePicture d pic++-- | Drawing the background to a pixmap and taking into account+-- transparency+drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO ()+drawBackground d p bgc alpha (Rectangle x y wid ht) = do+ let render opt bg pic m =+ xRenderComposite d opt bg m pic+ (fromIntegral x) (fromIntegral y) 0 0+ 0 0 (fromIntegral wid) (fromIntegral ht)+ withRenderPicture d p $ \pic -> do+ -- Handle background color+ bgcolor <- parseRenderColor d bgc+ withRenderFill d bgcolor $ \bgfill ->+ withRenderFill d+ (XRenderColor 0 0 0 (257 * alpha))+ (render pictOpSrc bgfill pic)+ -- Handle transparency+ internAtom d "_XROOTPMAP_ID" False >>= \xid ->+ let xroot = defaultRootWindow d in+ alloca $ \x1 ->+ alloca $ \x2 ->+ alloca $ \x3 ->+ alloca $ \x4 ->+ alloca $ \pprop -> do+ xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop+ prop <- peek pprop+ when (prop /= nullPtr) $ do+ rootbg <- peek (castPtr prop) :: IO Pixmap+ xFree prop+ withRenderPicture d rootbg $ \bgpic ->+ withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha))+ (render pictOpAdd bgpic pic)++-- | Parses color into XRender color (allocation not necessary!)+parseRenderColor :: Display -> String -> IO XRenderColor+parseRenderColor d c = do+ let colormap = defaultColormap d (defaultScreen d)+ Color _ red green blue _ <- parseColor d colormap c+ return $ XRenderColor (fromIntegral red)+ (fromIntegral green)+ (fromIntegral blue)+ 0xFFFF++pictOpSrc, pictOpAdd :: PictOp+pictOpSrc = 1+pictOpAdd = 12++-- pictOpMinimum = 0+-- pictOpClear = 0+-- pictOpDst = 2+-- pictOpOver = 3+-- pictOpOverReverse = 4+-- pictOpIn = 5+-- pictOpInReverse = 6+-- pictOpOut = 7+-- pictOpOutReverse = 8+-- pictOpAtop = 9+-- pictOpAtopReverse = 10+-- pictOpXor = 11+-- pictOpSaturate = 13+-- pictOpMaximum = 13
xmobar.cabal view
@@ -1,5 +1,5 @@ name: xmobar-version: 0.44.2+version: 0.45 homepage: https://codeberg.org/xmobar/xmobar synopsis: A Minimalistic Text Based Status Bar description: Xmobar is a minimalistic text based status bar.@@ -32,9 +32,9 @@ location: git://codeberg.org/xmobar/xmobar.git branch: master -flag with_xft- description: Use Xft to render text. UTF-8 support included.- default: False+flag with_xrender+ description: Use XRender for alpha background pseudo-transparency.+ default: True flag with_inotify description: inotify support (modern Linux only). Required for the Mail and MBox plugins.@@ -84,14 +84,14 @@ description: Use -with-rtsopts=-V0 to reduce wakeups. default: True -flag with_uvmeter- description: UVMeter only useful to australians.- default: False- flag with_weather description: Enable weather plugin. default: True +flag with_uvmeter+ description: UVMeter only useful to australians.+ default: False+ flag with_kraken description: Enable Kraken plugin. default: False@@ -109,14 +109,17 @@ other-modules: Paths_xmobar, Xmobar.Config.Types, Xmobar.Config.Parse,+ Xmobar.Config.Template, Xmobar.Run.Types, Xmobar.Run.Timer, Xmobar.Run.Template, Xmobar.Run.Exec, Xmobar.Run.Runnable Xmobar.Run.Actions,- Xmobar.Run.Parsers, Xmobar.Run.Loop,+ Xmobar.Draw.Boxes,+ Xmobar.Draw.Cairo,+ Xmobar.Draw.Types, Xmobar.App.Config, Xmobar.App.Main, Xmobar.App.Opts,@@ -133,14 +136,15 @@ Xmobar.Text.Swaybar, Xmobar.Text.SwaybarClicks, Xmobar.Text.Output,+ Xmobar.X11.Bitmap,+ Xmobar.X11.CairoSurface,+ Xmobar.X11.ColorCache,+ Xmobar.X11.Draw, Xmobar.X11.Events, Xmobar.X11.Loop,- Xmobar.X11.Types, Xmobar.X11.Text,- Xmobar.X11.Bitmap,- Xmobar.X11.ColorCache,+ Xmobar.X11.Types, Xmobar.X11.Window,- Xmobar.X11.Draw, Xmobar.Plugins.Command, Xmobar.Plugins.BufferedPipeReader, Xmobar.Plugins.CommandReader,@@ -188,17 +192,19 @@ ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind build-depends:- X11 >= 1.6.1, aeson >= 1.4.7.1, async, base >= 4.11.0 && < 4.17, bytestring >= 0.10.8.2,+ cairo >= 0.13,+ colour >= 2.3.6, containers, directory, extensible-exceptions == 0.1.*, filepath, mtl >= 2.1 && < 2.3, old-locale,+ pango >= 0.13, parsec == 3.1.*, parsec-numbers >= 0.1.0, process,@@ -207,7 +213,8 @@ time, transformers, unix,- utf8-string >= 0.3 && < 1.1+ utf8-string >= 0.3 && < 1.1,+ X11 >= 1.6.1 if impl(ghc < 8.0.2) -- Disable building with GHC before 8.0.2.@@ -225,10 +232,10 @@ if flag(with_rtsopts) cpp-options: -DRTSOPTS - if flag(with_xft) || flag(all_extensions)- build-depends: utf8-string >= 0.3 && < 1.1, X11-xft >= 0.2 && < 0.4- other-modules: Xmobar.X11.MinXft- cpp-options: -DXFT+ if flag(with_xrender)+ build-depends: X11-xft >= 0.2+ other-modules: Xmobar.X11.XRender+ cpp-options: -DXRENDER if flag(with_inotify) || flag(all_extensions) build-depends: hinotify >= 0.3 && < 0.5@@ -347,9 +354,6 @@ ghc-options: -with-rtsopts=-V0 if flag(with_threaded)- -- -threaded is a workaround for 100% CPU busy loop- -- (http://hackage.haskell.org/trac/ghc/ticket/4934).- -- See also comments in https://codeberg.org/xmobar/xmobar/pulls/36 ghc-options: -threaded cpp-options: -DTHREADED_RUNTIME @@ -413,8 +417,7 @@ benchmark xmobarbench type: exitcode-stdio-1.0 main-is: main.hs- hs-source-dirs:- bench+ hs-source-dirs: bench ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind -O2 build-depends: base, gauge, mtl, time, xmobar default-language: Haskell2010