fltkhs-themes (empty) → 0.1.0.0
raw patch · 56 files changed
+4808/−0 lines, 56 filesdep +basedep +bytestringdep +fltkhsbuild-type:Customsetup-changedbinary-added
Dependencies added: base, bytestring, fltkhs, load-font, text, vector
Files
- LICENSE +30/−0
- README.org +15/−0
- Setup.hs +2/−0
- doc/images/cancel-button-example.png binary
- doc/images/forward-image-example.png binary
- doc/images/left-image-example.png binary
- doc/images/ok-button-example.png binary
- doc/images/return-image-example.png binary
- doc/images/rewind-image-example.png binary
- doc/images/right-image-example.png binary
- doc/images/small-up-down-arrow-example.png binary
- fltkhs-themes.cabal +102/−0
- fonts/DejaVuSans.ttf binary
- fonts/Fineliner_Script.ttf binary
- fonts/JosefinSlab-SemiBold.ttf binary
- fonts/YanoneKaffeesatz-Regular.ttf binary
- fonts/fineliner_script-webfont.ttf binary
- fonts/fontawesome-webfont.ttf binary
- fonts/iosevka-ss08-regular.ttf binary
- fonts/tobec___-webfont.ttf binary
- images/brightness-field.png binary
- images/dialog-apply.png binary
- images/dialog-cancel.png binary
- images/dialog-ok.png binary
- images/down-small.png binary
- images/forward.png binary
- images/left.png binary
- images/rewind.png binary
- images/right.png binary
- images/up-small.png binary
- src/Graphics/UI/FLTK/Theme/Light.hs +285/−0
- src/Graphics/UI/FLTK/Theme/Light/Assets.hs +240/−0
- src/Graphics/UI/FLTK/Theme/Light/Browser.hs +60/−0
- src/Graphics/UI/FLTK/Theme/Light/Button.hs +499/−0
- src/Graphics/UI/FLTK/Theme/Light/Clock.hs +149/−0
- src/Graphics/UI/FLTK/Theme/Light/ColorChooser.hs +830/−0
- src/Graphics/UI/FLTK/Theme/Light/Common.hs +497/−0
- src/Graphics/UI/FLTK/Theme/Light/Counter.hs +143/−0
- src/Graphics/UI/FLTK/Theme/Light/Dial.hs +230/−0
- src/Graphics/UI/FLTK/Theme/Light/Group.hs +34/−0
- src/Graphics/UI/FLTK/Theme/Light/Input.hs +98/−0
- src/Graphics/UI/FLTK/Theme/Light/Menu.hs +88/−0
- src/Graphics/UI/FLTK/Theme/Light/Misc.hs +57/−0
- src/Graphics/UI/FLTK/Theme/Light/Positioner.hs +31/−0
- src/Graphics/UI/FLTK/Theme/Light/Progress.hs +52/−0
- src/Graphics/UI/FLTK/Theme/Light/SimpleTerminal.hs +22/−0
- src/Graphics/UI/FLTK/Theme/Light/Slider.hs +419/−0
- src/Graphics/UI/FLTK/Theme/Light/Spinner.hs +189/−0
- src/Graphics/UI/FLTK/Theme/Light/Table.hs +131/−0
- src/Graphics/UI/FLTK/Theme/Light/Tabs.hs +402/−0
- src/Graphics/UI/FLTK/Theme/Light/TextDisplay.hs +22/−0
- src/Graphics/UI/FLTK/Theme/Light/TextEditor.hs +22/−0
- src/Graphics/UI/FLTK/Theme/Light/Tree.hs +37/−0
- src/Graphics/UI/FLTK/Theme/Light/Valuator.hs +72/−0
- src/Graphics/UI/FLTK/Theme/Light/Window.hs +30/−0
- src/Graphics/UI/FLTK/Theme/Light/Wizard.hs +20/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Aditya Siram (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Aditya Siram nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.org view
@@ -0,0 +1,15 @@+#+TITLE: README++* fltkhs-themes+`fltkhs-themes` tries to make it easy to write nice consistent-looking+[FLTKHS](http://hackage.haskell.org/package/fltkhs-0.5.4.5/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html)+applications by providing drop-in light themed replacement widgets to the+standard ones with minimal performance and memory overhead.++Please see the [Hackage+docs](https://hackage.haskell.org/package/fltkhs-themes/docs/Graphics-UI-FLTK-Theme-Light.html) for much more information on installation and getting started with this package.++* Screenshots+There is a small but growing [showcase+app](https://github.com/deech/fltkhs-themes-demo) with screenshots that gives a+better idea of look-and-feel.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ doc/images/cancel-button-example.png view
binary file changed (absent → 1306 bytes)
+ doc/images/forward-image-example.png view
binary file changed (absent → 278 bytes)
+ doc/images/left-image-example.png view
binary file changed (absent → 241 bytes)
+ doc/images/ok-button-example.png view
binary file changed (absent → 929 bytes)
+ doc/images/return-image-example.png view
binary file changed (absent → 1072 bytes)
+ doc/images/rewind-image-example.png view
binary file changed (absent → 284 bytes)
+ doc/images/right-image-example.png view
binary file changed (absent → 260 bytes)
+ doc/images/small-up-down-arrow-example.png view
binary file changed (absent → 322 bytes)
+ fltkhs-themes.cabal view
@@ -0,0 +1,102 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: f817c1c2536810ecf9a6191153cc35ce69408e6bc81c4fa6f7c60e94b4ca672d++name: fltkhs-themes+version: 0.1.0.0+description: Please see the README on Github at <https://github.com/deech/fltkhs-themes#readme>+homepage: https://github.com/deech/fltkhs-themes#readme+bug-reports: https://github.com/deech/fltkhs-themes/issues+author: Aditya Siram+maintainer: aditya.siram@gmail.com+copyright: 2018 Aditya Siram+license: BSD3+license-file: LICENSE+build-type: Custom+cabal-version: >= 1.24+extra-source-files:+ README.org+extra-doc-files:+ doc/images/cancel-button-example.png+ doc/images/forward-image-example.png+ doc/images/left-image-example.png+ doc/images/ok-button-example.png+ doc/images/return-image-example.png+ doc/images/rewind-image-example.png+ doc/images/right-image-example.png+ doc/images/small-up-down-arrow-example.png+data-files:+ fonts/DejaVuSans.ttf+ fonts/fineliner_script-webfont.ttf+ fonts/Fineliner_Script.ttf+ fonts/fontawesome-webfont.ttf+ fonts/iosevka-ss08-regular.ttf+ fonts/JosefinSlab-SemiBold.ttf+ fonts/tobec___-webfont.ttf+ fonts/YanoneKaffeesatz-Regular.ttf+ images/brightness-field.png+ images/dialog-apply.png+ images/dialog-cancel.png+ images/dialog-ok.png+ images/down-small.png+ images/forward.png+ images/left.png+ images/rewind.png+ images/right.png+ images/up-small.png++source-repository head+ type: git+ location: https://github.com/deech/fltkhs-themes++custom-setup+ setup-depends:+ Cabal >=2.2.0.0 && <3+ , base >=4.4++library+ exposed-modules:+ Graphics.UI.FLTK.Theme.Light+ Graphics.UI.FLTK.Theme.Light.Assets+ Graphics.UI.FLTK.Theme.Light.Browser+ Graphics.UI.FLTK.Theme.Light.Button+ Graphics.UI.FLTK.Theme.Light.Clock+ Graphics.UI.FLTK.Theme.Light.ColorChooser+ Graphics.UI.FLTK.Theme.Light.Common+ Graphics.UI.FLTK.Theme.Light.Counter+ Graphics.UI.FLTK.Theme.Light.Dial+ Graphics.UI.FLTK.Theme.Light.Group+ Graphics.UI.FLTK.Theme.Light.Input+ Graphics.UI.FLTK.Theme.Light.Menu+ Graphics.UI.FLTK.Theme.Light.Misc+ Graphics.UI.FLTK.Theme.Light.Positioner+ Graphics.UI.FLTK.Theme.Light.Progress+ Graphics.UI.FLTK.Theme.Light.SimpleTerminal+ Graphics.UI.FLTK.Theme.Light.Slider+ Graphics.UI.FLTK.Theme.Light.Spinner+ Graphics.UI.FLTK.Theme.Light.Table+ Graphics.UI.FLTK.Theme.Light.Tabs+ Graphics.UI.FLTK.Theme.Light.TextDisplay+ Graphics.UI.FLTK.Theme.Light.TextEditor+ Graphics.UI.FLTK.Theme.Light.Tree+ Graphics.UI.FLTK.Theme.Light.Valuator+ Graphics.UI.FLTK.Theme.Light.Window+ Graphics.UI.FLTK.Theme.Light.Wizard+ other-modules:+ Paths_fltkhs_themes+ hs-source-dirs:+ src+ ghc-options: -Wall -fno-warn-name-shadowing+ build-depends:+ base >=4.7 && <5+ , bytestring+ , fltkhs >=0.6.0.0+ , load-font >=0.1.0.2+ , text >=1.2.2.0+ , vector >=0.12.0.1+ if os(linux)+ extra-libraries:+ fontconfig+ default-language: Haskell2010
+ fonts/DejaVuSans.ttf view
binary file changed (absent → 756072 bytes)
+ fonts/Fineliner_Script.ttf view
binary file changed (absent → 58492 bytes)
+ fonts/JosefinSlab-SemiBold.ttf view
binary file changed (absent → 46112 bytes)
+ fonts/YanoneKaffeesatz-Regular.ttf view
binary file changed (absent → 86864 bytes)
+ fonts/fineliner_script-webfont.ttf view
binary file changed (absent → 71020 bytes)
+ fonts/fontawesome-webfont.ttf view
binary file changed (absent → 152796 bytes)
+ fonts/iosevka-ss08-regular.ttf view
binary file changed (absent → 369396 bytes)
+ fonts/tobec___-webfont.ttf view
binary file changed (absent → 30032 bytes)
+ images/brightness-field.png view
binary file changed (absent → 206 bytes)
+ images/dialog-apply.png view
binary file changed (absent → 1387 bytes)
+ images/dialog-cancel.png view
binary file changed (absent → 1488 bytes)
+ images/dialog-ok.png view
binary file changed (absent → 2360 bytes)
+ images/down-small.png view
binary file changed (absent → 168 bytes)
+ images/forward.png view
binary file changed (absent → 144 bytes)
+ images/left.png view
binary file changed (absent → 125 bytes)
+ images/rewind.png view
binary file changed (absent → 146 bytes)
+ images/right.png view
binary file changed (absent → 121 bytes)
+ images/up-small.png view
binary file changed (absent → 166 bytes)
+ src/Graphics/UI/FLTK/Theme/Light.hs view
@@ -0,0 +1,285 @@+{-|+Module: Graphics.UI.FLTK.Theme.Light++A `Light` theme for [FLTKHS](http://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html).+-}+module Graphics.UI.FLTK.Theme.Light+ (+ -- * Motivation+ --+ -- $Motivation++ -- * Inspiration+ --+ -- $Inspiration++ -- * Installation #Installation#+ --+ -- $Installation++ -- * Getting Started #GettingStarted#+ --+ -- $GettingStarted++ -- * Running In the REPL+ --+ -- $RunningInTheREPL++ -- * Deployment #Deployment#+ --+ -- $Deployment++ -- * Demo #Demo#+ --+ -- $Demo++ -- * What's Missing+ --+ -- $WhatsMissing++ -- * Assets+ --+ -- $ThemeAssets+ module Graphics.UI.FLTK.Theme.Light.Assets,++ -- * Banners+ --+ -- | Some banners+ module Graphics.UI.FLTK.Theme.Light.Misc,++ -- * Themed Widgets+ module Graphics.UI.FLTK.Theme.Light.Browser,+ module Graphics.UI.FLTK.Theme.Light.Button,+ module Graphics.UI.FLTK.Theme.Light.Clock,+ module Graphics.UI.FLTK.Theme.Light.ColorChooser,+ module Graphics.UI.FLTK.Theme.Light.Common,+ module Graphics.UI.FLTK.Theme.Light.Counter,+ module Graphics.UI.FLTK.Theme.Light.Dial,+ module Graphics.UI.FLTK.Theme.Light.Group,+ module Graphics.UI.FLTK.Theme.Light.Input,+ module Graphics.UI.FLTK.Theme.Light.Menu,+ module Graphics.UI.FLTK.Theme.Light.Positioner,+ module Graphics.UI.FLTK.Theme.Light.Progress,+ module Graphics.UI.FLTK.Theme.Light.Slider,+ module Graphics.UI.FLTK.Theme.Light.Spinner,+ module Graphics.UI.FLTK.Theme.Light.Tabs,+ module Graphics.UI.FLTK.Theme.Light.Table,+ module Graphics.UI.FLTK.Theme.Light.TextDisplay,+ module Graphics.UI.FLTK.Theme.Light.TextEditor,+ module Graphics.UI.FLTK.Theme.Light.Tree,+ module Graphics.UI.FLTK.Theme.Light.Valuator,+ module Graphics.UI.FLTK.Theme.Light.Window,+ module Graphics.UI.FLTK.Theme.Light.Wizard,+ -- * Haddock barf+ --+ -- $HaddockBarf+ module Graphics.UI.FLTK.LowLevel.FLTKHS+ )+where+import Graphics.UI.FLTK.LowLevel.FLTKHS hiding+ (+ adjusterNew+ , browserNew+ , buttonNew+ , checkButtonNew+ , choiceNew+ , clockNew+ , colorChooserNew+ , counterNew+ , dialNew+ , doubleWindowNew+ , fileInputNew+ , fileBrowserNew+ , fillDialNew+ , fillSliderNew+ , flcColorChooser+ , groupNew+ , horFillSliderNew+ , horNiceSliderNew+ , horSliderNew+ , horValueSliderNew+ , inputNew+ , lightButtonNew+ , lineDialNew+ , menuButtonNew+ , outputNew+ , positionerNew+ , progressNew+ , returnButtonNew+ , roundButtonNew+ , selectBrowserNew+ , scrolledNew+ , singleWindowNew+ , sliderNew+ , spinnerNew+ , sysMenuBarNew+ , tabsNew+ , tableCustom+ , tableRowNew+ , textDisplayNew+ , textEditorNew+ , toggleButtonNew+ , treeNew+ , valueInputNew+ , valueOutputNew+ , valueSliderNew+ , windowNew+ , wizardNew+ )+import Graphics.UI.FLTK.Theme.Light.Assets+import Graphics.UI.FLTK.Theme.Light.Browser+import Graphics.UI.FLTK.Theme.Light.Button+import Graphics.UI.FLTK.Theme.Light.Clock+import Graphics.UI.FLTK.Theme.Light.ColorChooser+import Graphics.UI.FLTK.Theme.Light.Common+import Graphics.UI.FLTK.Theme.Light.Counter+import Graphics.UI.FLTK.Theme.Light.Dial+import Graphics.UI.FLTK.Theme.Light.Group+import Graphics.UI.FLTK.Theme.Light.Input+import Graphics.UI.FLTK.Theme.Light.Menu+import Graphics.UI.FLTK.Theme.Light.Misc+import Graphics.UI.FLTK.Theme.Light.Positioner+import Graphics.UI.FLTK.Theme.Light.Progress+import Graphics.UI.FLTK.Theme.Light.Slider+import Graphics.UI.FLTK.Theme.Light.Spinner+import Graphics.UI.FLTK.Theme.Light.Tabs+import Graphics.UI.FLTK.Theme.Light.Table+import Graphics.UI.FLTK.Theme.Light.TextDisplay+import Graphics.UI.FLTK.Theme.Light.TextEditor+import Graphics.UI.FLTK.Theme.Light.Tree+import Graphics.UI.FLTK.Theme.Light.Valuator+import Graphics.UI.FLTK.Theme.Light.Window+import Graphics.UI.FLTK.Theme.Light.Wizard++-- $Motivation+-- This package tries to make it easy to write nice consistent-looking+-- [FLTKHS](http://hackage.haskell.org/package/fltkhs-0.5.4.5/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html)+-- applications by providing drop-in light themed replacement widgets to the+-- standard ones with minimal performance and memory overhead. While+-- [FLTK](http://fltk.org) itself has very good performance and memory usage the+-- default look of the widgets is quite dated; this package aims to bridge that+-- gap by providing a more modern interface while retaining the responsiveness.+--+-- NOTE: This is not a theme in the same sense as CSS; the look is achieved+-- simply providing a custom drawing routine for each widget.++-- $Inspiration+-- The Light theme is massively indebted to and steals shamelessly from the+-- excellent [Qooxdoo](http://qooxdoo.org) project which manages to create a+-- [very slick](http://www.qooxdoo.org/current/widgetbrowser/) interface which+-- is at the same time production-grade /and/ easy to understand and use.++-- $GettingStarted+-- The underlying widget API has not been touched so all of the existing+-- [FLTK](http://www.fltk.org/doc-1.4/index.html) and+-- [FLTKHS](http://hackage.haskell.org/package/fltkhs-0.5.4.5/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html)+-- documentation still applies which makes switching over from an existing+-- codebase, not entirely but mostly, frictionless.+--+-- The simplest app skeleton to get started with this theme is as follows:+--+-- @+-- {-\# LANGUAGE ImplicitParams \#-} -- (1)+-- module Main where+-- ...+-- import Graphics.UI.FLTK.Theme.Light -- (2)+-- ...+-- main :: IO ()+-- main = do+-- assets <- configureTheme -- (3)+-- let ?assets = assets -- (3)+-- ui+-- FL.run+-- FL.flush+--+-- ui :: (?assets :: Assets) => IO () -- (4)+-- ui = ...+-- @+--+-- It involves only (1) enabling the /ImplicitParams/ extension, (2) importing+-- this module (3) doing some minor setup before the actual app code and (4)+-- threading the implicit constraint to whatever function uses this theme.+-- "Graphics.UI.FLTK.Theme.Light.Assets#AssetsDescriptionAndUsage" has more information.+--+-- The /ImplicitParams/ requirement is so that widgets have access to the+-- resources needed by this theme (icons, images, fonts etc.). See+-- "Graphics.UI.FLTK.Theme.Light.Assets#WhyImplicitParams" for more information.++-- $WhatsMissing+-- While most of the widgets and functionality in+-- [FLTKHS](hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html#g:21)+-- have and themed analogs but some do not mostly because, in my view, they don't fit into app+-- development much nowadays and so weren't worth porting. If there's a+-- pressing need let me know.+--+-- * Fill and "Nice" Sliders - here they fallback to the slider provided by the theme.+-- * [FLTK's Pre-Made Modal Dialogs](https://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-Ask.html)+-- * [FLTK's Square Clock](https://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-Clock.html)+-- * Fluid integration - FLTK ships with [FLUID](https://en.wikipedia.org/wiki/FLUID) GUI builder and the default FLTKHS integrates ("Graphics.UI.FLTK.LowLevel.FLTKHS#FluidSupport") with it quite well but currently there is no support for using it+-- to create themed apps. This is definitely on the roadmap and should be resolved in the near future.++-- $HaddockBarf+-- There is no reason to read anything below, this module hides the default+-- widgets it overrides and then re-exports what it doesn't. The re-exported+-- module from+-- [FLTKHS](http://hackage.haskell.org/package/fltkhs-0.5.4.5/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html)+-- in turn re-exports modules from that package. Instead of just showing the+-- exported module as a link Haddock insists on flattening and barfing out all+-- of its contents here. Sorry, didn't know how to get around it.+--++-- $ThemeAssets+-- The resources bundled with the theme, see the module documentation for more information.++-- $Installation+-- Installation follows the same basic procedure as+-- "Graphics.UI.FLTK.LowLevel.FLTKHS#Installation". The only difference is that+-- those instructions use the default [hello world+-- skeleton](https://github.com/deech/fltkhs-hello-world) whereas for themed UIs+-- you'll want the [themed+-- skeleton](https://github.com/deech/fltkhs-light-theme-skeleton), so wherever+-- the original instructions tell you to use the default skeleton use the latter+-- instead. And to run it, instead of:+--+-- @+-- > stack exec fltkhs-hello-world+-- @+--+-- do+--+-- @+-- > stack exec fltkhs-light-theme-skeleton+-- @+--++-- $Deployment+-- This package bundles a lot of local assets, images and especially fonts so+-- deploying a themed application is not as simple as just adding an executable+-- file to your path. To help with this the [skeleton+-- project](https://github.com/deech/fltkhs-light-theme-skeleton) uses the+-- [asset-bundle](http://hackage.haskell.org/package/asset-bundle) package to+-- create a ZIP archive of all the assets the application needs at runtime. The+-- [package+-- docs](http://hackage.haskell.org/package/asset-bundle/docs/Distribution-Simple-AssetBundle.html)+-- have a lot more info but in a nutshell when you build the skeletop app a ZIP+-- archive, @fltkhs-light-theme-skeleton_bundled.zip@, is generated for you+-- and placed deep inside your @.stack-work@ (or @dist-new@ if you're using+-- Cabal) directory. It contains all the assets and a runner script (@run.sh@ on+-- Linux and OSX and @run.bat@ on Windows) which invokes the executable, passes+-- along all command line arguments and sets up the environment so it+-- can find the assets at runtime.++-- $Demo+-- In addition to the [skeleton+-- project](https://github.com/deech/fltkhs-light-theme-skeleton) there is a+-- also a small but steadily growing [showcase+-- app](https://github.com/deech/fltkhs-themes-demo) that gives a better idea of+-- the look-and-feel of this theme. More will be added as time permits.++-- $RunningInTheREPL+-- Assuming you're using the [skeleton project](https://github.com/deech/fltkhs-light-theme-skeleton) getting a GUI running in+-- GHCi is pretty much the same "Graphics.UI.FLTK.LowLevel.FLTKHS#RunningInTheREPL" except the command to run the REPL is:+--+-- @+-- stack ghci --flag fltkhs:bundled fltkhs-light-theme-skeleton:exe:fltkhs-light-theme-skeleton+-- @
+ src/Graphics/UI/FLTK/Theme/Light/Assets.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings #-}+{-|+Module: Graphics.UI.FLTK.Theme.Assets++A module that allows access to the resources (fonts, images, etc.) bundled with this theme. Clients of this package should not need to directly include this module since @Graphics.UI.FLTK.Theme.Light@ re-exports it.+-}+module Graphics.UI.FLTK.Theme.Light.Assets+ (+ -- * Assets+ -- ** Description & Usage #AssetsDescriptionAndUsage#+ -- $Assets+ --++ -- ** Why ImplicitParams? #WhyImplicitParams#+ --+ -- $WhyImplicitParams+ Assets+ , loadAssets++ -- * Fonts+ --+ -- $Fonts+ , dejaVuSans+ , josefinSlabSemiBold+ , yanoneKaffesatz++ -- * Images+ --+ -- $Images+ , cancelButtonImage+ , downSmallImage+ , forwardImage+ , leftImage+ , okButtonImage+ , returnButtonImage+ , rewindImage+ , rightImage+ , upSmallImage+ )+where+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.FLTKHS+import qualified Data.Text as T+import Data.List+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Data.ByteString as B+import Control.Exception+import Graphics.UI.Font.Load+import Data.Maybe+import Control.Monad+import Paths_fltkhs_themes++-- | An opaque type that contains all of the resources needed by this theme.+-- Getting to the resources requires threading something of the type as an implicit+-- parameter to the accessors below, eg. 'dejaVuSans'.+data Assets =+ Assets+ {+ _dejaVuSans :: Font+ , _yanoneKaffesatz :: Font+ , _josefinSlabSemiBold :: Font+ , _returnButtonImage :: Ref PNGImage+ , _okButtonImage :: Ref PNGImage+ , _cancelButtonImage :: Ref PNGImage+ , _downSmallImage :: Ref PNGImage+ , _upSmallImage :: Ref PNGImage+ , _forwardImage :: Ref PNGImage+ , _rewindImage :: Ref PNGImage+ , _leftImage :: Ref PNGImage+ , _rightImage :: Ref PNGImage+ } deriving Show++-- | The [standard font](https://www.fontsquirrel.com/fonts/dejavu-sans) used for most labels, titles, output etc.+dejaVuSans :: (?assets :: Assets) => Font+dejaVuSans = _dejaVuSans ?assets++-- | Currently unused but a [nice font](https://www.yanone.de/fonts/kaffeesatz/) around for the future ...+yanoneKaffesatz :: (?assets :: Assets) => Font+yanoneKaffesatz = _yanoneKaffesatz ?assets++-- | A nice [banner font](https://www.fontsquirrel.com/fonts/josefin-slab).+josefinSlabSemiBold :: (?assets :: Assets) => Font+josefinSlabSemiBold = _josefinSlabSemiBold ?assets++-- | <<doc/images/return-image-example.png>>+returnButtonImage :: (?assets :: Assets) => Ref PNGImage+returnButtonImage = _returnButtonImage ?assets++-- | <<doc/images/ok-button-example.png>>+okButtonImage :: (?assets :: Assets) => Ref PNGImage+okButtonImage = _okButtonImage ?assets+-- | <<doc/images/cancel-button-example.png>>+cancelButtonImage :: (?assets :: Assets) => Ref PNGImage+cancelButtonImage = _cancelButtonImage ?assets+-- | The down arrow.+--+-- <<doc/images/small-up-down-arrow-example.png>>+downSmallImage :: (?assets :: Assets) => Ref PNGImage+downSmallImage = _downSmallImage ?assets+-- | The up arrow.+--+-- <<doc/images/small-up-down-arrow-example.png>>+upSmallImage :: (?assets :: Assets) => Ref PNGImage+upSmallImage = _upSmallImage ?assets+-- | <<doc/images/forward-image-example.png>>+forwardImage :: (?assets :: Assets) => Ref PNGImage+forwardImage = _forwardImage ?assets+-- | <<doc/images/rewind-image-example.png>>+rewindImage :: (?assets :: Assets) => Ref PNGImage+rewindImage = _rewindImage ?assets+-- | <<doc/images/left-image-example.png>>+leftImage :: (?assets :: Assets) => Ref PNGImage+leftImage = _leftImage ?assets+-- | <<doc/images/right-image-example.png>>+rightImage :: (?assets :: Assets) => Ref PNGImage+rightImage = _rightImage ?assets++fonts :: [FilePath]+fonts =+ [+ "fonts/DejaVuSans.ttf"+ , "fonts/YanoneKaffeesatz-Regular.ttf"+ , "fonts/JosefinSlab-SemiBold.ttf"+ ]++fontNames :: [T.Text]+fontNames =+ [+ "DejaVu Sans"+ , "Yanone Kaffeesatz Regular"+ , "Josefin Slab"+ ]++imagePaths :: [FilePath]+imagePaths =+ [+ "images/dialog-ok.png"+ , "images/dialog-apply.png"+ , "images/dialog-cancel.png"+ , "images/down-small.png"+ , "images/up-small.png"+ , "images/forward.png"+ , "images/rewind.png"+ , "images/left.png"+ , "images/right.png"+ ]++-- | Used at app start time to load the resources of this theme into memory.+-- This should never be called directly, but through+-- 'Graphics.UI.FLTK.Theme.Light.Common.configureTheme' which does some other+-- setup.+loadAssets :: IO Assets+loadAssets = do+ fontPaths <- mapM getDataFileName fonts+ loaded <- mapM loadFont fontPaths+ let errors = catMaybes (Data.List.map (\p -> case p of { Left err -> Just err; _ -> Nothing}) loaded)+ when (not (Data.List.null errors))+ (ioError (userError ("loadAssets (fatal error): unable to load font assets for the Light theme:\n" +++ (Data.List.concat (Data.List.intersperse "\n" errors)))))+ ips <- mapM getDataFileName imagePaths+ images <- mapM+ (\p -> do+ bytes <- B.readFile p `catch`+ (\(e :: SomeException) -> ioError+ (userError ("loadAssets (fatal error): image does not exist at path: " ++ p)))+ iE <- pngImageNewWithData (T.pack "") bytes+ case iE of+ Left _ -> ioError (userError ("loadAssets (fatal error): unable to read image data into a PNGImage:\n" ++ p))+ Right i -> return i)+ ips+ numFaces <- FL.setFonts Nothing+ let fonts = Prelude.map Font [0 .. numFaces - 1 ]+ withFaces <- mapM+ (+ \f -> do+ (face,_) <- FL.getFontName f+ return (face,f)+ )+ fonts+ let fontNumbers = catMaybes (Data.List.map (\fName -> Prelude.lookup fName withFaces) fontNames)+ _ <- FL.setScheme "gtk+"+ let addImages as = as (images !! 0)+ (images !! 1)+ (images !! 2)+ (images !! 3)+ (images !! 4)+ (images !! 5)+ (images !! 6)+ (images !! 7)+ (images !! 8)+ assets =+ if (Data.List.length fontNumbers /= Data.List.length fontNames)+ then addImages (Assets helvetica helvetica helvetica )+ else addImages (Assets (fontNumbers !! 0) (fontNumbers !! 1) (fontNumbers !! 2))+ return assets++-- $Assets+-- This module mediates access to fonts, images and whatever other data is needed+-- by this theme. To provide a consistent look-and-feel across platforms the theme+-- bundles whatever it needs and loads them when a user's app is started. The+-- loaded assets should not interfere with any other process thread. For example,+-- when a user's application starts up the 'dejaVuSansMono' font is loaded into the+-- font cache, but it should be isolated to the app's process.+--+--+-- To use the assets in an FLTK app you need to enable the @ImplicitParams@+-- pragma and then pass the 'Assets' implicit constraint to every function that+-- needs the resources:+--+-- @+-- {-\# LANGUAGE ImplicitParams ...\#-}+-- ...+-- myAwesomeUI :: (?assets :: Assets) => ...+-- myAwesomeUI = do+-- ...+-- b <- buttonNew ...+-- setLabelFont b dejaVuSansMono+-- ...+-- @+--+-- For more extensive documentation on how to use assets in the context of a+-- full application see "Graphics.UI.FLTK.Theme.Light#GettingStarted".++-- $WhyImplicitParams+-- [ImplicitParams](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#implicit-parameters)+-- is a fairly contentious extension because of how it interacts with+-- [recursion](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#implicit-parameters-and-polymorphic-recursion)+-- and the dangers of accidental name-shadowing. The two alternatives are+-- [Reader](http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader.html)+-- and [reflection](http://hackage.haskell.org/package/reflection). While both+-- are more principled the first requires all UI functions have a 'MonadReader'+-- constraint which makes the API way uglier and harder to use, and the second+-- incurs a dependency on+-- [template-haskell](http://hackage.haskell.org/package/template-haskell) which+-- I also did not want. /ImplicitParams/ are easier to use and have been in GHC+-- since 6.8.1 and since we're just threading through some fonts and images+-- hopefully the downsides won't become a big deal in practice.++-- $Fonts+-- The fonts required by this theme, all are TTF.
+ src/Graphics/UI/FLTK/Theme/Light/Browser.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Browser+ (+ browserNew,+ selectBrowserNew,+ fileBrowserNew,+ browserDraw,+ browserSetup+ )+where+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.Theme.Light.Assets++-- | The custom 'draw' function for creating the themed browser+browserDraw :: Ref LowLevel.Browser -> IO ()+browserDraw b = do+ (color :: Color) <- LowLevel.getColor b+ let slightlyDarker = colorAverage color blackColor 0.85+ withCustomBoxDraw+ BorderBox+ (\rect _ -> do+ LowLevel.flcRectfWithColor rect color+ LowLevel.flcRectWithColor rect slightlyDarker)+ (LowLevel.drawSuper b)++-- | Setting the theme's color, fonts etc+browserSetup :: (?assets :: Assets) => Ref LowLevel.Browser -> IO ()+browserSetup b = do+ LowLevel.setColor b lightBackground+ LowLevel.setBox b BorderBox+ LowLevel.setLabelfont b commonFont+ LowLevel.setLabelsize b commonFontSize+ LowLevel.setTextfont b commonFont+ c <- commonSelectionColor+ LowLevel.setScrollbarSize b 10+ LowLevel.setSelectionColor b c+ LowLevel.setTextsize b commonFontSize++browserNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Browser)+browserNew rect l = do+ b <- LowLevel.browserCustom rect l (Just browserDraw) Nothing+ browserSetup b+ return b++selectBrowserNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.SelectBrowser)+selectBrowserNew rect l = do+ b <- browserNew rect l+ LowLevel.setType b SelectBrowserType+ return (castTo b)++fileBrowserNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FileBrowser)+fileBrowserNew rect l = do+ b <- LowLevel.fileBrowserCustom rect l (Just (browserDraw . safeCast)) Nothing+ browserSetup (safeCast b)+ return b
+ src/Graphics/UI/FLTK/Theme/Light/Button.hs view
@@ -0,0 +1,499 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Button+ (+ FillSpec(..),+ buttonFillSpec,+ buttonIsHidden,+ buttonNew,+ buttonSetup,+ cancelButtonNew,+ checkButtonNew,+ drawCheck,+ drawIndicatorButton,+ drawLight,+ drawMenuButton,+ drawRegularButton,+ drawRound,+ fillRectangle,+ lightButtonNew,+ menuButtonNew,+ okButtonNew,+ returnButtonNew,+ roundButtonNew,+ toggleButtonNew+ )+where+import Control.Exception+import Control.Monad+import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import Text.Printf+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import qualified Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.Theme.Light.Assets++-- | Check of the given button is 'HiddenButtonType'+buttonIsHidden :: Ref LowLevel.Button -> IO Bool+buttonIsHidden b = do+ t <- LowLevel.getType_ b+ case t of+ HiddenButtonType -> return True+ _ -> return False++-- | Draw a regular button, i.e not a radio button, toggle button, etc.+drawRegularButton :: FillSpec -> Ref LowLevel.Button -> IO ()+drawRegularButton spec b = do+ buttonType <- LowLevel.getType_ b+ case buttonType of+ HiddenButtonType -> return ()+ _ -> do+ pressed <- LowLevel.getValue b+ fillRectangle spec pressed+ focused <- isWidget b FL.focus+ hovering <- isWidget b FL.belowmouse+ borderRectangle spec focused hovering+ LowLevel.drawLabel b Nothing++-- | Radio and light buttons are examples of an "indicator" button, some visual indicator that the+-- button is enabled. It takes a function that draws the indicator and 'Bool' flags specifying+-- whether it is pressed, transparent or entirely hidden respectively, the 'FontSize' of the+-- label so the indicator can properly position itself next to the label and the widget itself.+drawIndicatorButton ::+ (+ Parent orig LowLevel.Widget,+ Match b ~ FindOp orig orig (LowLevel.ActiveR ()),+ Op (LowLevel.ActiveR ()) b orig (IO Bool),+ Match c ~ FindOp orig orig (LowLevel.GetAlign ()),+ Op (LowLevel.GetAlign ()) c orig (IO Alignments),+ Match d ~ FindOp orig orig (LowLevel.GetImage ()),+ Op (LowLevel.GetImage ()) d orig (IO (Maybe (Ref LowLevel.Image))),+ Match e ~ FindOp orig orig (LowLevel.GetSelectionColor ()),+ Op (LowLevel.GetSelectionColor ()) e orig (IO Color),+ Match g ~ FindOp orig orig (LowLevel.GetRectangle ()),+ Op (LowLevel.GetRectangle ()) g orig (IO Rectangle),+ Match h ~ FindOp orig orig (LowLevel.GetColor ()),+ Op (LowLevel.GetColor ()) h orig (IO Color),+ Match i ~ FindOp orig orig (LowLevel.GetLabelsize ()),+ Op (LowLevel.GetLabelsize ()) i orig (IO FontSize),+ Match j ~ FindOp orig orig (LowLevel.DrawLabel ()),+ Op (LowLevel.DrawLabel ()) j orig (Maybe (Rectangle,Alignments) -> IO ()),+ Match k ~ FindOp orig orig (LowLevel.GetBox ()),+ Op (LowLevel.GetBox ()) k orig (IO (Boxtype)),+ Match l ~ FindOp orig orig (LowLevel.GetParent ()),+ Op (LowLevel.GetParent ()) l orig (IO (Maybe (Ref LowLevel.Group))),+ Match m ~ FindOp orig orig (LowLevel.GetColor ()),+ Op (LowLevel.GetColor ()) m orig (IO (Color)),+ Match n ~ FindOp orig orig (LowLevel.SetColor ()),+ Op (LowLevel.SetColor ()) n orig (Color -> IO ())+ ) => (FillSpec -> Bool -> Color -> FontSize -> IO Rectangle) -> Bool -> Bool -> Bool -> FontSize -> Ref orig -> IO ()+drawIndicatorButton indicator pressed transparent hidden fs b =+ if hidden then return ()+ else do+ spec <- buttonFillSpec b+ boxType <- LowLevel.getBox b+ active <- LowLevel.activeR b+ if (not transparent)+ then case boxType of+ NoBox -> return ()+ _ -> do+ fillRectangle spec pressed+ focused <- isWidget b FL.focus+ hovering <- isWidget b FL.belowmouse+ borderRectangle spec focused hovering+ else do+ maybeParent <- LowLevel.getParent b+ case maybeParent of+ Just (p :: Ref LowLevel.Group) -> do+ c <- LowLevel.getColor p+ () <- LowLevel.setColor b c+ focused <- isWidget b FL.focus+ hovering <- isWidget b FL.belowmouse+ borderRectangle (spec { fillBorderColor = lightBackground }) focused hovering+ Nothing -> return ()+ let (x,y,w,h) = fromRectangle (fillBounds spec)+ color <- LowLevel.getSelectionColor b+ indicatorBounds <- indicator spec (pressed && active) color fs+ let (indicatorX, _, indicatorW, _) = fromRectangle indicatorBounds+ (alignments :: Alignments) <- LowLevel.getAlign b+ (imageM :: Maybe (Ref LowLevel.Image)) <- LowLevel.getImage b+ let labelBounds = case imageM of+ Nothing -> toRectangle (x + fillCornerRadius spec, y, w - (fillCornerRadius spec * 2), h)+ Just _ ->+ let widthLeftCut = indicatorX + indicatorW - x+ widthRightCut = fillCornerRadius spec+ in toRectangle (indicatorX + indicatorW, y, w - (widthLeftCut + widthRightCut),h)+ LowLevel.drawLabel b (Just (labelBounds, alignments))++-- | Draw a down arrow on the right side of the given 'Rectangle' and return it's bounds+drawDownArrow :: Rectangle -> Color -> FontSize -> IO Rectangle+drawDownArrow bounds arrowColor (FontSize size)=+ let arrowSize :: Int+ arrowSize = (fromIntegral size) `intDiv` 2+ (x,y,w,h) = fromRectangle bounds+ arrowX = x + w - arrowSize - arrowSize+ arrowY :: Int+ arrowY = y + (h `intDiv` 2) - (arrowSize `intDiv` 2)+ arrowBoundingBox = toRectangle (arrowX, arrowY, arrowSize, arrowSize)+ in do+ oldColor <- LowLevel.flcColor+ LowLevel.flcSetColor arrowColor+ LowLevel.flcBeginPolygon+ LowLevel.flcVertex (PrecisePosition (PreciseX (fromIntegral arrowX)) (PreciseY (fromIntegral arrowY)))+ LowLevel.flcVertex (PrecisePosition (PreciseX (fromIntegral (arrowX+arrowSize))) (PreciseY (fromIntegral arrowY)))+ LowLevel.flcVertex (PrecisePosition (PreciseX ((fromIntegral arrowX) + (fromIntegral arrowSize)/2)) (PreciseY (fromIntegral (arrowY + arrowSize))))+ LowLevel.flcVertex (PrecisePosition (PreciseX (fromIntegral arrowX)) (PreciseY (fromIntegral arrowY)))+ LowLevel.flcEndPolygon+ return arrowBoundingBox++-- | Draw a themed menu button+drawMenuButton :: Ref LowLevel.MenuButton -> IO ()+drawMenuButton m = do+ t <- LowLevel.getType_ m+ b <- LowLevel.getBox m+ let noBox = case b of { NoBox -> True; _ -> False }+ if (t /= 0 || noBox) then return ()+ else do+ fillSpec <- buttonFillSpec m+ itemIndex <- LowLevel.getValue m+ fontSize <- LowLevel.getLabelsize m+ drawIndicatorButton (\spec _ color fs -> drawDownArrow (fillBounds spec) color fs) (maybe False (const True) itemIndex) False False fontSize m++-- | Draw the light part of a LightButton. The 'Bool' indicates whether the light is on.+drawLight :: FillSpec -> Bool -> Color -> FontSize -> IO Rectangle+drawLight spec lightOn lightColor (FontSize lightDiameter) =+ let (x,y,w,h) = fromRectangle (fillBounds spec)+ lightX = x + 3+ lightY = y + (h `intDiv` 2)+ lightRadius = (fromIntegral lightDiameter / 2.0)+ lightBoundingBox = toRectangle (lightX, (lightY - truncate lightRadius), fromIntegral lightDiameter, fromIntegral lightDiameter)+ in do+ oldColor <- LowLevel.flcColor+ when lightOn+ (do+ LowLevel.flcSetColor lightColor+ LowLevel.flcPie lightBoundingBox (PreciseAngle 0.0) (PreciseAngle 360.0)+ )+ LowLevel.flcSetColor (fillBorderColor spec)+ LowLevel.flcCircle (PrecisePosition (PreciseX (fromIntegral (lightX + truncate lightRadius))) (PreciseY (fromIntegral lightY))) lightRadius+ LowLevel.flcSetColor oldColor+ return lightBoundingBox++-- | Draw the radio part of a RoundButton. The 'Bool' indicates whether it is enabled.+drawRound :: FillSpec -> Bool -> Color -> FontSize -> IO Rectangle+drawRound spec radioOn radioColor (FontSize fs) =+ let (x,y,w,h) = fromRectangle (fillBounds spec)+ radioBoxX = x + 3+ radioBoxY = fromIntegral y + (fromIntegral h / 2.0)+ radioBoxWidth :: Int+ radioBoxWidth = fromIntegral fs+ radioBoxHalfway :: Double+ radioBoxHalfway = (fromIntegral radioBoxWidth) / 2.0+ radioBoundingBox =+ toRectangle (radioBoxX, truncate (radioBoxY - radioBoxHalfway), radioBoxWidth, radioBoxWidth)+ circleSvg =+ "<svg width=\"%d\" height=\"%d\" viewBox=\" %f %f %d %d\">\n" +++ "<circle cx=\"0\" cy=\"0\" r=\"%f\" fill=\"%s\" stroke=\"%s\"/>" +++ "</svg>\n"+ radioRadius = (fromIntegral radioBoxWidth) / 4.5+ radioDiameter = radioRadius * 2+ radioX = fromIntegral radioBoxX + radioBoxHalfway - radioRadius+ radioY = radioBoxY - radioRadius+ in do+ (borderColorR, borderColorG, borderColorB) <- FL.getColorRgb (fillBorderColor spec)+ (radioColorR, radioColorG, radioColorB) <- FL.getColorRgb (if radioOn then radioColor else (fillTopColor spec))+ let svg =+ "<svg>\n" +++ (printf circleSvg+ radioBoxWidth radioBoxWidth (-radioBoxHalfway) (-radioBoxHalfway) radioBoxWidth radioBoxWidth+ (radioBoxHalfway-1.0) ("none" :: String) ("rgb(" ++ show borderColorR ++ "," ++ show borderColorG ++ "," ++ show borderColorB ++ ")")) +++ (printf circleSvg+ radioBoxWidth radioBoxWidth (-radioBoxHalfway) (-radioBoxHalfway) radioBoxWidth radioBoxWidth+ (radioRadius-1.0) ("rgb(" ++ show radioColorR ++ "," ++ show radioColorG ++ "," ++ show radioColorB ++ ")") ("rgb(" ++ show radioColorR ++ "," ++ show radioColorG ++ "," ++ show radioColorB ++ ")")) +++ "</svg>\n"+ iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg)+ case iE of+ Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg))+ Right i -> do+ LowLevel.draw i (toPosition (radioBoxX,truncate (radioBoxY - radioBoxHalfway)))+ LowLevel.destroy i+ return radioBoundingBox++-- | Draw the check part of a CheckButton. The 'Bool' indicated whether to draw the check or not.+drawCheck :: FillSpec -> Bool -> Color -> FontSize -> IO Rectangle+drawCheck spec checked checkColor (FontSize fontSize) =+ let (x,y,w,h) = fromRectangle (fillBounds spec)+ checkBoxWidth :: Int = fromIntegral fontSize+ checkBoxHeight = checkBoxWidth+ checkBoxX = x + 3+ checkBoxMiddle = fromIntegral checkBoxHeight / 2.0+ checkBoxFourth = fromIntegral checkBoxHeight / 4.0+ yOffset = (h - fromIntegral checkBoxHeight) `intDiv` 2+ pad = 1+ checkThickness = 2+ checkBoxY = y + yOffset+ checkBoxRectangle = toRectangle (checkBoxX, checkBoxY, checkBoxWidth, checkBoxHeight)+ in do+ when checked+ (let+ downstrokeStart = Position (X (checkBoxX + pad)) (Y (checkBoxY + truncate checkBoxMiddle))+ upstrokeStart = Position (X (checkBoxX + pad + truncate checkBoxFourth)) (Y (checkBoxY - pad + checkBoxHeight))+ in do+ LowLevel.flcSetColor checkColor+ LowLevel.flcPolygonWith4Sides+ downstrokeStart+ (Position (X (checkBoxX + pad + checkThickness)) (Y (checkBoxY + truncate checkBoxMiddle)))+ (Position (X (checkBoxX + pad + truncate checkBoxFourth + checkThickness)) (Y (checkBoxY - pad + checkBoxHeight)))+ (Position (X (checkBoxX + pad + truncate checkBoxFourth)) (Y (checkBoxY - pad + checkBoxHeight)))+ LowLevel.flcPolygonWith4Sides+ upstrokeStart+ (Position (X (checkBoxX + checkBoxWidth - pad - checkThickness)) (Y (checkBoxY + pad)))+ (Position (X (checkBoxX + checkBoxWidth - pad)) (Y (checkBoxY + pad)))+ (Position (X (checkBoxX + pad + truncate checkBoxFourth + checkThickness)) (Y (checkBoxY - pad + checkBoxHeight)))+ )+ oldColor <- LowLevel.flcColor+ LowLevel.flcSetColor (fillBorderColor spec)+ LowLevel.flcRect checkBoxRectangle+ LowLevel.flcSetColor oldColor+ return checkBoxRectangle++-- | Create a 'FillSpec' for the given button based on its color, bounds etc.+buttonFillSpec ::+ (+ Match w ~ FindOp orig orig (LowLevel.GetRectangle ()),+ Op (LowLevel.GetRectangle ()) w orig (IO Rectangle),+ Match x ~ FindOp orig orig (LowLevel.GetColor ()),+ Op (LowLevel.GetColor ()) x orig (IO Color),+ Match y ~ FindOp orig orig (LowLevel.GetLabelsize ()),+ Op (LowLevel.GetLabelsize ()) y orig (IO FontSize),+ Match z ~ FindOp orig orig (LowLevel.GetSelectionColor ()),+ Op (LowLevel.GetSelectionColor ()) z orig (IO Color)+ ) => Ref orig -> IO FillSpec+buttonFillSpec b = do+ rect <- LowLevel.getRectangle b+ color <- LowLevel.getColor b+ selectionColor <- LowLevel.getSelectionColor b+ makeFillSpec rect color selectionColor++-- | Common setup for all buttons, setting the label fonts, background color etc.+buttonSetup ::+ (+ ?assets :: Assets,+ Match w ~ FindOp orig orig (LowLevel.SetColor ()),+ Op (LowLevel.SetColor ()) w orig (Color -> IO ()),+ Match x ~ FindOp orig orig (LowLevel.SetLabelfont ()),+ Op (LowLevel.SetLabelfont ()) x orig (Font -> IO ()),+ Match y ~ FindOp orig orig (LowLevel.SetLabelsize ()),+ Op (LowLevel.SetLabelsize ()) y orig (FontSize -> IO ()),+ Match z ~ FindOp orig orig (LowLevel.SetAlign ()),+ Op (LowLevel.SetAlign ()) z orig (Alignments -> IO ())+ ) => Ref orig -> IO ()+buttonSetup b = do+ color <- commonColor+ () <- LowLevel.setColor b color+ () <- LowLevel.setLabelfont b commonFont+ () <- LowLevel.setLabelsize b commonFontSize+ LowLevel.setAlign b (Alignments [AlignTypeInside, AlignTypeCenter , AlignTypeImageNextToText])++buttonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Button)+buttonNew rectangle label = do+ b <- LowLevel.buttonCustom+ rectangle+ label+ (Just (\b -> do+ spec <- buttonFillSpec b+ drawRegularButton spec b))+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = Just handleHover }))+ buttonSetup b+ return b++toggleButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ToggleButton)+toggleButtonNew rectangle label = do+ b <- LowLevel.buttonCustom+ rectangle+ label+ (Just (\b -> do+ spec <- buttonFillSpec b+ drawRegularButton spec b))+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover ) }))+ LowLevel.setType b ToggleButtonType+ buttonSetup b+ return (LowLevel.castTo b)++lightButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.LightButton)+lightButtonNew rectangle label = do+ b <- LowLevel.lightButtonCustom+ rectangle+ label+ (Just (\b -> do+ pressed <- LowLevel.getValue b+ hidden <- buttonIsHidden (safeCast b)+ fontSize <- LowLevel.getLabelsize b+ drawIndicatorButton drawLight pressed False hidden fontSize b))+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))+ buttonSetup b+ LowLevel.setSelectionColor b yellowColor+ LowLevel.setAlign b (Alignments [AlignTypeInside, AlignTypeCenter, AlignTypeImageNextToText])+ return b++checkButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.CheckButton)+checkButtonNew rectangle label = do+ b <- LowLevel.checkButtonCustom+ rectangle+ label+ (Just (\b -> do+ hidden <- buttonIsHidden (safeCast b)+ when (not hidden)+ (do+ (x,y,w,h) <- fmap fromRectangle (LowLevel.getRectangle b)+ bx <- FL.boxDx BorderBox+ c <- LowLevel.getColor b+ (FontSize labelWCInt) <- LowLevel.getLabelsize b+ let labelW = fromIntegral labelWCInt+ let dx = bx + 2+ dy = (h-labelW) `intDiv` 2+ LowLevel.flcDrawBox BorderBox (toRectangle (x+dx,y+dy,labelW,labelW)) c+ v <- LowLevel.getValue b+ when v+ (do+ let tx = x+dx+1+ tw = labelW-1+ d1 = tw `intDiv` 3+ d2 = tw-d1+ ty = y+dy+((labelW+d2) `intDiv` 2)-d1-2+ oldC <- LowLevel.flcColor+ LowLevel.flcSetColor blackColor+ mapM_+ (\i -> do+ let ty' = ty+i+ LowLevel.flcLine (toPosition (tx,ty')) (toPosition (tx+d1,ty'+d1))+ LowLevel.flcLine (toPosition (tx+d1,ty'+d1)) (toPosition (tx+tw-1,ty'+d1-d2+1)))+ [0 .. 2]+ LowLevel.flcSetColor oldC+ )+ let lx = dx+labelW+2+ alignments <- LowLevel.getAlign b+ LowLevel.drawLabel b (Just (toRectangle (x+lx,y,w-lx-bx,h), alignments)))))+ Nothing+ color <- commonColor+ () <- LowLevel.setColor b color+ () <- LowLevel.setLabelfont b commonFont+ () <- LowLevel.setLabelsize b commonFontSize+ LowLevel.setSelectionColor b color+ return b++roundButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.RoundButton)+roundButtonNew rectangle label = do+ b <- LowLevel.roundButtonCustom+ rectangle+ label+ (Just (\b -> do+ hidden <- buttonIsHidden (safeCast b)+ when (not hidden)+ (do+ (x,y,w,h) <- fmap fromRectangle (LowLevel.getRectangle b)+ bx <- FL.boxDx BorderBox+ c <- LowLevel.getColor b+ (FontSize labelWCInt) <- LowLevel.getLabelsize b+ v <- LowLevel.getValue b+ let labelW :: Int+ labelW = fromIntegral labelWCInt+ dx = bx + 2+ dy = (h-labelW) `intDiv` 2+ circleSvg =+ "<svg width=\"%d\" height=\"%d\" viewBox=\" %f %f %d %d\">\n" +++ "<circle cx=\"0\" cy=\"0\" r=\"%f\" fill=\"%s\" stroke=\"%d\"/>" +++ "</svg>\n"+ halfway :: Double+ halfway = (fromIntegral labelW)/2+ radius :: Double+ radius = (fromIntegral labelW)/4.5+ (Color black') = blackColor+ black :: Int+ black = fromIntegral black'+ svg =+ "<svg>\n" +++ (printf circleSvg+ labelW labelW (-halfway) (-halfway) labelW labelW+ (halfway-1.0) ("none" :: String) black) +++ (if v+ then+ printf circleSvg+ labelW labelW (-halfway) (-halfway) labelW labelW+ (radius-1.0) ("black" :: String) black+ else "")+ +++ "</svg>\n"+ iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg)+ case iE of+ Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg))+ Right i -> do+ LowLevel.draw i (toPosition (x+dx,y+dy))+ LowLevel.destroy i+ let lx = dx+labelW+2+ alignments <- LowLevel.getAlign b+ LowLevel.drawLabel b (Just (toRectangle (x+lx,y,w-lx-bx,h), alignments)))))+ Nothing+ color <- commonColor+ () <- LowLevel.setColor b color+ () <- LowLevel.setLabelfont b commonFont+ () <- LowLevel.setLabelsize b commonFontSize+ LowLevel.setSelectionColor b color+ return b++menuButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.MenuButton)+menuButtonNew rect l = do+ m <- LowLevel.menuButtonCustom rect l (Just drawMenuButton) Nothing+ buttonSetup m+ LowLevel.setBox m BorderBox+ LowLevel.setTextfont m commonFont+ LowLevel.setTextsize m commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor m color+ return m++returnButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ReturnButton)+returnButtonNew rect l = do+ b <- LowLevel.returnButtonCustom rect l+ (Just ((\b -> do+ spec <- buttonFillSpec b+ drawRegularButton spec b) . safeCast))+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = Just handleHover }))+ buttonSetup b+ let (_,_,w',h') = fromRectangle rect+ LowLevel.setAlign b (Alignments [AlignTypeTextNextToImage])+ iM <- LowLevel.copy returnButtonImage Nothing+ case iM of+ Nothing -> return ()+ Just i -> do+ LowLevel.scale i (Size (Width (w' `intDiv` 3)) (Height (h' `intDiv` 2))) Nothing Nothing+ LowLevel.setImage b iM+ return b++okButtonNew :: (?assets :: Assets) => Rectangle -> IO (Ref LowLevel.Button)+okButtonNew rect = do+ b <- buttonNew rect (Just "OK")+ iM <- LowLevel.copy okButtonImage Nothing+ let (_,_,w',h') = fromRectangle rect+ case iM of+ Nothing -> return ()+ Just i -> do+ LowLevel.scale i (Size (Width (w' `intDiv` 3)) (Height (h' `intDiv` 2))) Nothing Nothing+ LowLevel.setImage b iM+ return b++cancelButtonNew :: (?assets :: Assets) => Rectangle -> IO (Ref LowLevel.Button)+cancelButtonNew rect = do+ b <- buttonNew rect (Just "Cancel")+ iM <- LowLevel.copy cancelButtonImage Nothing+ let (_,_,w',h') = fromRectangle rect+ case iM of+ Nothing -> return ()+ Just i -> do+ LowLevel.scale i (Size (Width (w' `intDiv` 3)) (Height (h' `intDiv` 2))) Nothing Nothing+ LowLevel.setImage b iM+ return b
+ src/Graphics/UI/FLTK/Theme/Light/Clock.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Clock+ (+ clockNew,+ drawClock+ )+where+import Control.Exception+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Text.Printf+import Graphics.UI.FLTK.Theme.Light.Assets++clockSvg :: Width -> Height -> RGB -> RGB -> LowLevel.ClockByTime -> String+clockSvg (Width w) (Height h) colorRgb selectionColorRgb (LowLevel.ClockByTime (LowLevel.Hour hours) (LowLevel.Minute minutes) (LowLevel.Second seconds)) =+ let widthRadius :: Double+ widthRadius = (fromIntegral w)/2+ heightRadius :: Double+ heightRadius = (fromIntegral h)/2+ ellipseRadius :: PreciseSize+ ellipseRadius = PreciseSize (PreciseWidth widthRadius) (PreciseHeight heightRadius)+ withinSvg :: String -> String+ withinSvg innards =+ (printf+ ("<svg width=\"%d\" height=\"%d\" viewBox=\"%f %f %d %d\">\n")+ w h (-widthRadius) (-heightRadius) w h)+ ++ innards ++ "</svg>\n"+ strokeWidth = percentOfSmallerEllipseRadius 10 ellipseRadius+ tickPadding = percentOfSmallerEllipseRadius 15 ellipseRadius+ tickHeight = percentOfSmallerEllipseRadius 10 ellipseRadius+ centerRadius = percentOfSmallerEllipseRadius 5 ellipseRadius+ secondHandWidth = percentOfSmallerEllipseRadius 3 ellipseRadius+ minuteHandWidth = percentOfSmallerEllipseRadius 3 ellipseRadius+ minuteHandHeight = percentOfSmallerEllipseRadius 80 ellipseRadius+ hourHandWidth = percentOfSmallerEllipseRadius 3 ellipseRadius+ hourHandHeight = percentOfSmallerEllipseRadius 70 ellipseRadius+ outline (colorR,colorG,colorB) =+ printf "<ellipse cx=\"0\" cy=\"0\" rx=\"%d\" ry=\"%d\" fill=\"none\" stroke=\"%s\" stroke-width=\"%f\" />\n"+ (truncate (widthRadius-strokeWidth/2) :: Int)+ (truncate (heightRadius-strokeWidth/2) :: Int)+ ("rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")")+ strokeWidth+ ticks (colorR,colorG,colorB) =+ map+ (\tickNumber ->+ let tickAngle :: Int+ tickAngle = tickNumber * 30+ PrecisePosition (PreciseX unitX) (PreciseY unitY) = angleToCoordinate (PreciseAngle (fromIntegral tickAngle))+ quarterHourTick = tickNumber == 0 || tickNumber == 3 || tickNumber == 6 || tickNumber == 9+ tickSvg =+ printf "<path d=\"M%f,%f L%f,%f\" fill=\"none\" stroke=\"%s\">\n"+ (unitX * (widthRadius-tickPadding-tickHeight)) (unitY * (widthRadius-tickPadding-tickHeight))+ (unitX * (widthRadius-tickPadding)) (unitY * (widthRadius-tickPadding))+ (if quarterHourTick then "black"+ else ("rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")"))+ in withinSvg tickSvg)+ [0 .. 11]+ center (colorR,colorG,colorB) =+ let centerColor = "rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")"+ in+ printf "<circle cx=\"0\" cy=\"0\" r=\"%f\" fill=\"%s\" stroke=\"%s\"/>"+ centerRadius+ centerColor+ centerColor+ hourHand :: String+ hourHand =+ let fromMilitary :: Int+ fromMilitary = hours `mod` 12+ hourPart :: Double+ hourPart = (fromIntegral fromMilitary) * 30+ minutePart :: Double+ minutePart = 30.0 * (fromIntegral minutes / 60)+ hourAngle :: Double+ hourAngle = hourPart+minutePart-90.0+ PrecisePosition (PreciseX unitX) (PreciseY unitY) = angleToCoordinate (PreciseAngle hourAngle)+ in+ printf "<path d=\"M 0,0 L%f,%f\" stroke=\"%s\" stroke-width=\"%f\""+ (unitX * (hourHandHeight-tickPadding)) (unitY * (hourHandHeight-tickPadding))+ ("black" :: String)+ hourHandWidth+ minuteHand :: String+ minuteHand =+ let minuteAngle :: Int+ minuteAngle = minutes*6-90+ PrecisePosition (PreciseX unitX) (PreciseY unitY) = angleToCoordinate (PreciseAngle (fromIntegral minuteAngle))+ in+ printf "<path d=\"M 0,0 L%f,%f\" stroke=\"%s\" stroke-width=\"%f\""+ (unitX * (minuteHandHeight-tickPadding)) (unitY * (minuteHandHeight-tickPadding))+ ("black" :: String)+ minuteHandWidth+ secondHand :: RGB -> String+ secondHand (colorR,colorG,colorB) =+ let secondAngle :: Int+ secondAngle = seconds*6-90+ PrecisePosition (PreciseX unitX) (PreciseY unitY) = angleToCoordinate (PreciseAngle (fromIntegral secondAngle))+ in+ withinSvg+ (printf "<path d=\"M 0,0 L%f,%f\" stroke=\"%s\" stroke-width=\"%f\""+ (unitX * (widthRadius-tickPadding)) (unitY * (widthRadius-tickPadding))+ ("rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")")+ secondHandWidth)+ in+ "<svg>\n"+ ++ (withinSvg (outline colorRgb))+ ++ (concat (ticks colorRgb))+ ++ (withinSvg hourHand)+ ++ (withinSvg minuteHand)+ ++ (withinSvg (center selectionColorRgb))+ ++ (withinSvg (secondHand selectionColorRgb))+ ++ "</svg>"++-- | Custom clock drawing function+drawClock :: Ref LowLevel.Clock -> IO ()+drawClock clock = do+ bounds@(Rectangle clockPos (Size w' h')) <- LowLevel.getRectangle clock+ color <- LowLevel.getColor clock+ oldColor <- LowLevel.flcColor+ colorRgb <- FL.getColorRgb (colorAverage color blackColor 0.80)+ LowLevel.flcSetColor color+ LowLevel.flcRectfWithColor bounds whiteColor+ LowLevel.flcSetColor oldColor+ selectionColorRgb <- LowLevel.getSelectionColor clock >>= FL.getColorRgb+ time <- LowLevel.getValue clock+ let svg = clockSvg w' h' colorRgb selectionColorRgb time+ iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg)+ case iE of+ Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg))+ Right i -> do+ LowLevel.draw i clockPos+ LowLevel.destroy i+ LowLevel.drawLabel clock Nothing++clockNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Clock)+clockNew rectangle l' = do+ c <- LowLevel.clockCustom rectangle l' (Just drawClock) Nothing+ color <- commonColor+ LowLevel.setColor c color+ LowLevel.setBox c BorderBox+ LowLevel.setLabelfont c commonFont+ LowLevel.setLabelsize c commonFontSize+ color <- commonFillColor+ LowLevel.setSelectionColor c color+ LowLevel.setShadow c False+ return c
+ src/Graphics/UI/FLTK/Theme/Light/ColorChooser.hs view
@@ -0,0 +1,830 @@+{-# LANGUAGE ImplicitParams, FlexibleContexts, TypeFamilies, RecursiveDo, ScopedTypeVariables, OverloadedStrings #-}+module Graphics.UI.FLTK.Theme.Light.ColorChooser+ (+ colorChooserNew,+ flcColorChooser,++ -- * Drawing routines+ ColorChooserComponentBounds(..),+ ColorChooserComponentLayout(..),+ ColorChooserState(..),+ colorDialCallback,+ drawCurrentColor,+ drawHueBox,+ drawPreviewColor,+ drawSaturationSlider,+ gaugeImageRectangle,+ generateImage,+ generateVImage,+ handleHueBox,+ hueBoxBounds,+ makeColorChooserComponentBounds,+ makeColorChooserComponentLayout,+ maxSliderWidth,+ modeMenuCallback,+ setValuators,+ sliderCallback,+ updateHsv,+ updateRgb+ )+where+import Control.Exception+import Control.Monad+import Control.Monad.ST+import Data.Fixed+import Data.IORef+import Data.Ratio+import Data.STRef+import Foreign.C.Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations as Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.Theme.Light.Common+import Graphics.UI.FLTK.Theme.Light.Dial+import Graphics.UI.FLTK.Theme.Light.Group+import Graphics.UI.FLTK.Theme.Light.Menu+import Graphics.UI.FLTK.Theme.Light.Slider+import Graphics.UI.FLTK.Theme.Light.Window+import Graphics.UI.FLTK.Theme.Light.Group+import Graphics.UI.FLTK.Theme.Light.Button+import Numeric+import Text.Printf as Printf+import qualified Data.ByteString.Char8 as BChar+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Vector.Storable as DVS+import qualified Data.Vector.Storable.Mutable as DVSM+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++-- | Bounds of the color chooser subcomponents+data ColorChooserComponentBounds =+ ColorChooserComponentBounds+ {+ colorChooserHueBoxBounds :: Rectangle -- ^ The bounds of the hue box+ , colorChooserSliderBounds :: Rectangle -- ^ The bounds of the saturation slider+ , colorChooserPreviewPaneBounds :: Rectangle -- ^ The bounds of the byte\/hex\/decimal color readout and color swatch preview pane.+ } deriving Show+++-- | Layout of color chooser subcomponents+data ColorChooserComponentLayout =+ ColorChooserComponentLayout+ {+ paddingWidthPercentage :: Double -- ^ Left\/right padding+ , paddingHeightPercentage :: Double -- ^ Top\/bottom padding+ , betweenPaddingPercent :: Double -- ^ % of color chooser width to set as padding /between/ subcomponents+ , hueBoxWidthPercentage :: Double -- ^ % of color chooser width dedicated to the hue box+ , sliderWidthPercentage :: Double -- ^ % of color chooser width dedicated to the saturation slider+ , hueBoxHandleRadius :: Double -- ^ Radius of the indicator you drag around the hue box to change color+ , previewPanePercentage :: Double -- ^ % of color chooser width dedicated to the preview pane+ } deriving Show+++-- | The state of color chooser, passed around as in 'IORef' and updated in callbacks, etc.+data ColorChooserState =+ ColorChooserState+ {+ colorChooserValue :: Between0And1+ , colorChooserR :: Between0And1+ , colorChooserG :: Between0And1+ , colorChooserB :: Between0And1+ , colorChooserHue :: Between0And6+ , colorChooserSaturation :: Between0And1+ , colorChooserHueImage :: Ref LowLevel.RGBImage+ , colorChooserMode :: ColorChooserMode+ } deriving Show++-- | Max width of the saturation slider if the color chooser is resized+maxSliderWidth :: Width+maxSliderWidth = Width 30++-- | The default layout of color chooser subcomponents+makeColorChooserComponentLayout :: Size -> Width -> Int -> ColorChooserComponentLayout+makeColorChooserComponentLayout (Size (Width w) (Height h)) (Width maxSliderWidth) gaugeHeight =+ let calculatedSliderWidth = 0.15 `percentOf` w+ gaugeStart = gaugeHeight `intDiv` 2+ maxSliderWidthPercentage :: Double+ maxSliderWidthPercentage = (fromIntegral maxSliderWidth) / (fromIntegral w)+ _sliderWidthPercentage :: Double+ _sliderWidthPercentage =+ if calculatedSliderWidth > maxSliderWidth+ then maxSliderWidthPercentage+ else 0.15+ _betweenPaddingPercent = 0.02+ hueBoxHandleRadius =+ let r = (fromIntegral (if (w<h) then w else h))*0.03+ in if (r>(fromIntegral gaugeStart)) then (fromIntegral gaugeStart) else r+ _previewPanePercentage = 0.25+ in+ ColorChooserComponentLayout+ {+ paddingWidthPercentage = 0.01+ , paddingHeightPercentage = 0.01+ , betweenPaddingPercent = _betweenPaddingPercent+ , hueBoxWidthPercentage = 1.0 - (_betweenPaddingPercent + _sliderWidthPercentage + _previewPanePercentage)+ , sliderWidthPercentage = _sliderWidthPercentage+ , hueBoxHandleRadius = hueBoxHandleRadius+ , previewPanePercentage = _previewPanePercentage+ }++hueBoxHandleSvg :: String+hueBoxHandleSvg =+ "<svg width=\"%f\" height=\"%f\" viewBox=\"%f %f %f %f\" >"+ ++ "<circle cx=\"0\" cy=\"0\" r=\"%f\" fill-opacity=\"0.0\" stroke=\"black\" />"+ ++ "</svg>"++-- | Draw the hue box subcomponent in the given 'Box', takes the 'Double'+-- indicator handle radius, the 'Int' slider gauge height so it can align itself+-- with it.+drawHueBox :: Double -> Int -> IORef ColorChooserState -> Ref LowLevel.ColorChooser -> Ref LowLevel.Box ->IO ()+drawHueBox handleRadius gaugeHeight stateRef c b = do+ state <- readIORef stateRef+ bounds <- LowLevel.getRectangle b+ let hueBox = hueBoxBounds bounds handleRadius gaugeHeight+ color <- commonColor+ let slightlyDarker = Enumerations.colorAverage color blackColor 0.80+ let spec =+ BorderBoxSpec+ {+ borderBoxHoveringColor = slightlyDarker+ , borderBoxColor = slightlyDarker+ , borderBoxFocusedColor = slightlyDarker+ , borderBoxFillColor = lightBackground+ , borderBoxBounds = hueBox+ }+ let (x',y',w',h') = fromRectangle hueBox+ LowLevel.flcRectfWithColor bounds (borderBoxFillColor spec)+ drawBorderBox b spec True+ iM <- LowLevel.copy (colorChooserHueImage state) (Just (Size (Width (w'-2)) (Height (h'-2))))+ maybe+ (return ())+ (\i -> do+ LowLevel.draw i (Position (X (x'+1)) (Y (y'+1)))+ LowLevel.destroy i)+ iM+ damages <- LowLevel.getDamage b+ let svg =+ Printf.printf hueBoxHandleSvg+ (handleRadius*2) (handleRadius*2) (-handleRadius) (-handleRadius) (handleRadius*2) (handleRadius*2)+ handleRadius+ iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg)+ case iE of+ Left _ -> throwIO (userError ("drawHueBox: the generated SVG is invalid: \n" ++ svg))+ Right i -> do+ hue <- LowLevel.getHue c+ saturation <- LowLevel.getSaturation c+ case hue of+ Left _ -> throwIO (userError ("drawHueBox: hue out of range, must be between 0 and 6."))+ Right (Between0And6 hue) ->+ case saturation of+ Left _ -> throwIO (userError ("drawHueBox: saturation out of range, must be between 0 and 1."))+ Right (Between0And1 saturation) ->+ let (PrecisePosition (PreciseX xp') (PreciseY yp')) =+ fromHs (hue, saturation) (PreciseSize (PreciseWidth (fromIntegral w')) (PreciseHeight (fromIntegral h')))+ pos = (Position (X (x'+(truncate (xp'-handleRadius)))) (Y (y'+(truncate (yp'-handleRadius)))))+ in do+ LowLevel.draw i pos+ LowLevel.destroy i+ LowLevel.drawLabel b Nothing++-- | Calculate the bounds of the hue box based on the overall 'Rectangle'+-- bounds, the 'Double' radius of the indicator circle (half the indicator+-- circle can be outside the box so the center is always within it), and the+-- 'Int' saturation slider height so the hue box can position itself+-- accordingly.+hueBoxBounds :: Rectangle -> Double -> Int -> Rectangle+hueBoxBounds hueBoxOuterRect handleRadius gaugeHeight =+ let (x',y',w',h') = fromRectangle hueBoxOuterRect+ in+ toRectangle+ (+ x'+(truncate handleRadius)+ , y'+ (gaugeHeight `intDiv` 2)+ , w'-(truncate (handleRadius*2.0))+ , h'-gaugeHeight+ )++-- | Calculate the overall bounds of all the subcomponents+makeColorChooserComponentBounds :: ColorChooserComponentLayout -> Rectangle -> Int -> ColorChooserComponentBounds+makeColorChooserComponentBounds layout rect gaugeHeight =+ let (x',y',w',h') = fromRectangle rect+ paddingWidth = (paddingWidthPercentage layout) `percentOf` w'+ paddingHeight = (paddingHeightPercentage layout) `percentOf` h'+ gaugeStart = gaugeHeight `intDiv` 2+ innerRectWidth = w'-(paddingWidth*2)+ innerRectHeight = h'-(paddingHeight*2)+ betweenPadding = (betweenPaddingPercent layout) `percentOf` innerRectWidth+ outerHueBoxWidth = (hueBoxWidthPercentage layout) `percentOf` innerRectWidth+ hueBoxWidth = outerHueBoxWidth - (truncate (hueBoxHandleRadius layout*2.0))+ hueBoxHeight = innerRectHeight-gaugeHeight+ sliderWidth = (sliderWidthPercentage layout) `percentOf` innerRectWidth+ innerRect = (x'+paddingWidth,y'+paddingHeight,innerRectWidth,innerRectHeight)+ previewPaneWidth = (previewPanePercentage layout) `percentOf` innerRectWidth+ in+ ColorChooserComponentBounds+ {+ colorChooserSliderBounds =+ toRectangle (x'+paddingWidth+outerHueBoxWidth,y'+paddingHeight,sliderWidth,innerRectHeight)+ , colorChooserHueBoxBounds =+ toRectangle (x'+paddingWidth,y'+paddingHeight,outerHueBoxWidth,innerRectHeight)+ , colorChooserPreviewPaneBounds =+ toRectangle (x'+paddingWidth+outerHueBoxWidth+sliderWidth+betweenPadding, y'+(if (gaugeStart > paddingHeight) then gaugeStart else paddingHeight), previewPaneWidth, innerRectHeight)+ }++-- | From (hue,saturation) and the size of the hue box calculate corresponding position in the hue box.+fromHs :: (Double,Double) -> PreciseSize -> PrecisePosition+fromHs (hue,saturation) (PreciseSize (PreciseWidth w) (PreciseHeight h)) =+ let x = hue/6.0*w+ y = (1.0-saturation)*h+ in+ (PrecisePosition+ (PreciseX (if (x<0) then 0.0 else if (x>w) then w else x))+ (PreciseY (if (y<0) then 0.0 else if (y>h) then h else y)))++-- | Calculate the (hue,saturation) from a point in the hue box+toHs :: PrecisePosition -> (Double,Double)+toHs (PrecisePosition (PreciseX x) (PreciseY y)) =+ let h = 6.0*x `mod'` 6.0+ s = 1.0 - y+ in+ (+ if (h < 0.0)+ then 0.0+ else h+ ,+ if (s < 0.0)+ then 0.0+ else+ if (s > 1.0)+ then 1.0+ else s+ )++-- | Generate the hue box image+generateImage :: Size -> IO (Ref LowLevel.RGBImage)+generateImage size@(Size (Width w') (Height h')) =+ let toRgb :: Double -> CUChar+ toRgb v = toEnum (truncate (255*v+0.5))+ in do+ m <- DVSM.replicate (w'*h'*3) ((toEnum 0) :: CUChar)+ mapM_ (\r ->+ let yIncrement :: Double+ yIncrement = (fromIntegral r / (fromIntegral h'))+ in+ mapM_+ (\i ->+ let offset = (w'*r+i)*3+ xIncrement :: Double+ xIncrement = ((fromIntegral i) / (fromIntegral w'))+ (h,s) = toHs (PrecisePosition (PreciseX xIncrement) (PreciseY yIncrement))+ in do+ rgbM <- LowLevel.hsv2Rgb (Between0And6 h, Between0And1 s, Between0And1 1.0)+ case rgbM of+ Nothing -> throwIO (userError (Printf.printf "Could not convert hsv (%d,%d,%d) to rgb." h s (1.0 :: Double)))+ Just (Between0And1 r, Between0And1 g, Between0And1 b) -> do+ DVSM.write m offset (toRgb r)+ DVSM.write m (offset+1) (toRgb g)+ DVSM.write m (offset+2) (toRgb b)+ )+ [0 .. w'-1])+ [0 .. h'-1]+ im <- DVS.unsafeFreeze m+ LowLevel.rgbImageNew im size Nothing Nothing++-- | Generate the background of the saturation slider+generateVImage :: RGB -> Size -> IO (Ref LowLevel.SVGImage)+generateVImage (r',g',b') size@(Size (Width w') (Height h')) =+ let svgString :: String+ svgString =+ "<svg width=\"" ++ (show w') ++ "\" height=\"" ++ (show h') ++ "\"/>\n" +++ "<defs>\n" +++ "<linearGradient id=\"saturationGradient\" x1=\"25\" y1=\"180\" x2=\"25\" >\n" +++ "<stop offset=\"0\" stop-color=\"black\" />\n" +++ "<stop offset=\"1\" stop-color=\"" ++ "rgb(" ++ (show r') ++ "," ++ (show g') ++ "," ++ (show b') ++ ")\"/>\n" +++ "</linearGradient>\n" +++ "</defs>\n" +++ "<rect width=\"" ++ (show w') ++ "\" height=\"" ++ (show h') ++ "\" fill=\"url(#saturationGradient)\"/>\n" +++ "</svg>"+ in do+ iE <- LowLevel.svgImageNew (BChar.pack svgString)+ case iE of+ Left _ -> throwIO (userError ("generateVImage': the generated SVG is invalid: \n" ++ svgString))+ Right i -> return i++-- | Handle all events inside the hue box given the 'Double' indicator radius and the 'Int' gauge height.+handleHueBox :: Double -> Int -> Ref LowLevel.ColorChooser -> Ref LowLevel.Box -> Event -> IO (Either UnknownEvent ())+handleHueBox handleRadius gaugeHeight c b e = do+ rect <- LowLevel.getRectangle b+ (Right (Between0And6 currH)) <- LowLevel.getHue c+ (Right (Between0And1 currS)) <- LowLevel.getSaturation c+ (Right (Between0And1 v)) <- LowLevel.getValue c+ let focusMe = do+ vf <- FL.visibleFocus+ when vf (LowLevel.redraw b)+ hueBoxRect = hueBoxBounds rect handleRadius gaugeHeight+ updateHsv =+ let (x',y',w',h') = fromRectangle hueBoxRect+ in do+ vf <- FL.visibleFocus+ when vf ((FL.setFocus b) >> LowLevel.redraw b)+ eventPos@(Position (X ex)(Y ey)) <- FL.eventPosition+ let xDiff = ex-x'+ xIncrement =+ if (xDiff <= 0) then 0.0+ else+ fromIntegral (if (xDiff > w'-1) then w'-1 else xDiff) / fromIntegral w'+ yIncrement = fromIntegral (ey-y') / fromIntegral h'+ (h,s) = toHs (PrecisePosition (PreciseX xIncrement) (PreciseY yIncrement))+ ctrlPressed <- FL.containsEventState Kb_CtrlState+ r <- LowLevel.setHsv c+ (+ Between0And6 (if ctrlPressed then currH else h)+ , Between0And1 s+ , Between0And1 v+ )+ case r of+ Left NoChange -> return ()+ Right _ -> LowLevel.doCallback c+ case e of+ Push -> updateHsv >> return (Right ())+ Drag -> updateHsv >> return (Right ())+ Focus -> focusMe >> return (Right ())+ Unfocus -> focusMe >> return (Right ())+ Keydown ->+ let (PrecisePosition (PreciseX x) (PreciseY y)) = fromHs (currH,currS) (toPreciseSize (rectangleSize rect))+ in do+ key <- FL.eventKey+ let newXY = case key of+ SpecialKeyType Kb_Up -> Just (x,y-3)+ SpecialKeyType Kb_Down -> Just (x,y+3)+ SpecialKeyType Kb_Left -> Just (x-3,y)+ SpecialKeyType Kb_Right -> Just (x+3,y)+ _ -> Nothing+ case newXY of+ Nothing -> return (Left UnknownEvent)+ Just (newX,newY) ->+ let (_,_,w',h') = fromRectangle hueBoxRect+ (h,s) = toHs (PrecisePosition (PreciseX (newX/(fromIntegral w'))) (PreciseY (newY/(fromIntegral h'))))+ in do+ r <- LowLevel.setHsv c (Between0And6 h, Between0And1 s, Between0And1 v)+ case r of+ Left NoChange -> return ()+ Right _ -> LowLevel.doCallback c+ return (Right ())+ _ -> return (Left UnknownEvent)++-- | Draw the saturation slider using the current color to fill in the background image+drawSaturationSlider :: IORef ColorChooserState -> Ref LowLevel.Slider -> IO ()+drawSaturationSlider stateRef s = do+ bounds <- LowLevel.getRectangle s+ state <- readIORef stateRef+ damages <- LowLevel.getDamage s+ let gaugeImageBounds = gaugeImageRectangle mkGaugeSliderSpec bounds+ when True -- (DamageExpose `elem` damages)+ (do+ c <- LowLevel.getColor s+ LowLevel.flcRectfWithColor gaugeImageBounds c+ rgbM <- LowLevel.hsv2Rgb (colorChooserHue state, colorChooserSaturation state, Between0And1 1.0)+ maybe (return ())+ (\rgb -> do+ i <- generateVImage (extractRgb rgb) (rectangleSize gaugeImageBounds)+ LowLevel.draw i (rectanglePosition gaugeImageBounds)+ LowLevel.destroy i)+ rgbM)+ when ((DamageAll `elem` damages) || (DamageExpose `elem` damages))+ (drawSlider s (Just mkGaugeSliderSpec) bounds)++-- | Calculate the bounds of the saturation slider+gaugeImageRectangle :: GaugeSliderSpec -> Rectangle -> Rectangle+gaugeImageRectangle spec bounds =+ let (gX,gY,gW,gH) = fromRectangle (gaugeBoxBounds False spec bounds)+ imageSize = Size (Width (gW-2)) (Height (gH-2))+ imagePosition = (Position (X (gX+1)) (Y (gY+1)))+ in (Rectangle imagePosition imageSize)++extractRgb :: (Between0And1, Between0And1, Between0And1) -> RGB+extractRgb (Between0And1 _r, Between0And1 _g, Between0And1 _b) = (truncate (_r*255.0), truncate (_g*255.0), truncate (_b*255.0))++-- | Update all the controls based on the dial selected HSV+updateHsv :: IORef ColorChooserState -> Ref LowLevel.Slider -> Ref LowLevel.Box -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.Group -> Ref LowLevel.ColorChooser -> (Between0And6, Between0And1, Between0And1) -> IO Int+updateHsv stateRef slider hueBox rInput gInput bInput previewGroup colorChooser (Between0And6 _h, Between0And1 _s, Between0And1 _v) =+ let h =+ let __h = _h `mod'` 6.0+ in if (__h<0) then __h+6.0 else __h+ s =+ if (_s<0) then 0.0 else if (_s>1.0) then 1.0 else _s+ v =+ if (_v<0) then 0.0 else if (_v>1.0) then 1.0 else _v+ in do+ state <- readIORef stateRef+ let (Between0And6 currH) = colorChooserHue state+ (Between0And1 currS) = colorChooserSaturation state+ (Between0And1 currV) = colorChooserValue state+ changed :: Int+ changed = runST (do+ ref <- newSTRef 0+ when (h /= currH) (writeSTRef ref 1)+ when (s /= currS) (writeSTRef ref 1)+ when (v /= currV) (writeSTRef ref 1)+ readSTRef ref)+ when (h /= currH)+ (do+ LowLevel.setDamage hueBox [DamageScroll]+ LowLevel.setDamage slider [DamageExpose]+ LowLevel.setDamage previewGroup [DamageExpose]+ ds <- LowLevel.getDamage slider+ modifyIORef stateRef (\state -> state { colorChooserHue = Between0And6 h }))+ when (s /= currS)+ (do+ LowLevel.setDamage hueBox [DamageScroll]+ LowLevel.setDamage slider [DamageExpose]+ LowLevel.setDamage previewGroup [DamageExpose]+ modifyIORef stateRef (\state -> state { colorChooserSaturation = Between0And1 s }))+ when (v /= currV)+ (do+ LowLevel.setValue slider (1-v)+ LowLevel.setDamage previewGroup [DamageExpose]+ modifyIORef stateRef (\state -> state { colorChooserValue = Between0And1 v }))+ when (changed == 1)+ (do+ rgb <- LowLevel.hsv2Rgb (Between0And6 h, Between0And1 s, Between0And1 v)+ LowLevel.setChanged colorChooser+ case rgb of+ Just (r,g,b) -> modifyIORef stateRef (\s -> s { colorChooserR = r, colorChooserG = g, colorChooserB = b })+ Nothing -> return ()+ setValuators rInput gInput bInput colorChooser)+ setValuators rInput gInput bInput colorChooser+ return changed++-- | Update all the controls based on the dial selected RGB value+updateRgb :: IORef ColorChooserState -> Ref LowLevel.Slider -> Ref LowLevel.Box -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.Group -> Ref LowLevel.ColorChooser -> (Between0And1, Between0And1, Between0And1) -> IO Int+updateRgb stateRef slider hueBox rValue gValue bValue previewGroup c rgb@(Between0And1 r, Between0And1 g, Between0And1 b) = do+ state <- readIORef stateRef+ let (Between0And1 currR) = colorChooserR state+ (Between0And1 currG) = colorChooserG state+ (Between0And1 currB) = colorChooserB state+ changed = runST (do+ ref <- newSTRef 0+ when (r /= currR) (writeSTRef ref 1)+ when (g /= currG) (writeSTRef ref 1)+ when (b /= currB) (writeSTRef ref 1)+ readSTRef ref)+ when (r /= currR)+ (do+ LowLevel.setDamage hueBox [DamageScroll]+ LowLevel.setDamage slider [DamageExpose]+ LowLevel.setDamage previewGroup [DamageExpose]+ modifyIORef stateRef (\state -> state { colorChooserR = Between0And1 r }))+ when (g /= currG)+ (do+ LowLevel.setDamage hueBox [DamageScroll]+ LowLevel.setDamage slider [DamageExpose]+ LowLevel.setDamage previewGroup [DamageExpose]+ modifyIORef stateRef (\state -> state { colorChooserG = Between0And1 g }))+ when (b /= currB)+ (do+ LowLevel.setDamage hueBox [DamageScroll]+ LowLevel.setDamage slider [DamageExpose]+ LowLevel.setDamage previewGroup [DamageExpose]+ modifyIORef stateRef (\state -> state { colorChooserB = Between0And1 b }))+ when (changed == 1)+ (do+ rgb <- LowLevel.rgb2Hsv rgb+ LowLevel.setChanged c+ case rgb of+ Just (h,s,v) -> modifyIORef stateRef (\state -> state { colorChooserHue = h, colorChooserSaturation = s, colorChooserValue = v })+ Nothing -> return ())+ setValuators rValue gValue bValue c+ return changed++-- | Update the dials if the preview mode is changed from RGB->Hex->HSV->Byte mode+modeMenuCallback :: IORef ColorChooserState -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.ColorChooser -> Ref LowLevel.Choice -> IO ()+modeMenuCallback stateRef rValue gValue bValue chooser choice = do+ (AtIndex i) <- LowLevel.getValue choice+ case i of+ 0 -> modifyIORef stateRef (\state -> state { colorChooserMode = RgbMode })+ 1 -> modifyIORef stateRef (\state -> state { colorChooserMode = ByteMode })+ 2 -> modifyIORef stateRef (\state -> state { colorChooserMode = HexMode })+ 3 -> modifyIORef stateRef (\state -> state { colorChooserMode = HsvMode })+ _ -> throwIO (userError "modeMenuCallback: Only RGB, Byte, Hex and Hsv are valid modes.")+ setValuators rValue gValue bValue chooser++-- | React to changes the dials in the preview pane+colorDialCallback :: Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.ColorChooser -> IO ()+colorDialCallback rValue gValue bValue c = do+ rV <- LowLevel.getValue rValue+ gV <- LowLevel.getValue gValue+ bV <- LowLevel.getValue bValue+ m <- LowLevel.getMode c+ case m of+ HsvMode -> LowLevel.setHsv c (Between0And6 rV, Between0And1 gV, Between0And1 bV)+ _ -> LowLevel.setRgb c (Between0And1 rV, Between0And1 gV, Between0And1 bV)+ LowLevel.doCallback c++-- | React to changes in the saturation slider+sliderCallback :: IORef ColorChooserState -> Ref LowLevel.ColorChooser -> Ref LowLevel.Slider -> IO ()+sliderCallback stateRef c slider = do+ state <- readIORef stateRef+ v <- LowLevel.getValue slider+ LowLevel.setHsv c (colorChooserHue state, colorChooserSaturation state, Between0And1 (1.0-v))+ LowLevel.doCallback c++-- | Set the dials according the selected color+setValuators :: Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.ColorChooser -> IO ()+setValuators rInput gInput bInput c = do+ let toThreeDecimals v = fromIntegral (truncate (v*1000)) / 1000+ m <- LowLevel.getMode c+ case m of+ RgbMode -> do+ rgbE <- LowLevel.getRgb c+ case rgbE of+ Left _ -> return ()+ Right (Between0And1 r, Between0And1 g, Between0And1 b) -> do+ mapM_ (\i -> do+ LowLevel.range i 0 1+ LowLevel.setStep i (1%1000)+ LowLevel.precision i 3)+ [rInput,gInput,bInput]+ LowLevel.setValue rInput r+ LowLevel.setValue gInput g+ LowLevel.setValue bInput b+ LowLevel.setSelectionColor rInput redColor+ LowLevel.setSelectionColor gInput greenColor+ LowLevel.setSelectionColor bInput blueColor+ LowLevel.setLabel rInput (T.pack (show (toThreeDecimals r)))+ LowLevel.setLabel gInput (T.pack (show (toThreeDecimals g)))+ LowLevel.setLabel bInput (T.pack (show (toThreeDecimals b)))+ return ()+ HsvMode -> do+ hsvE <- LowLevel.getHsv c+ case hsvE of+ Left _ -> return ()+ Right (Between0And6 h, Between0And1 s, Between0And1 v) -> do+ LowLevel.range rInput 0 6+ LowLevel.setStep rInput (1%1000)+ mapM_ (\i -> do+ LowLevel.range i 0 1+ LowLevel.setStep i (1%1000))+ [gInput,bInput]+ LowLevel.setValue rInput h+ LowLevel.setValue gInput s+ LowLevel.setValue bInput v+ color <- commonFillColor+ LowLevel.setSelectionColor rInput color+ LowLevel.setSelectionColor gInput color+ LowLevel.setSelectionColor bInput color+ LowLevel.setLabel rInput (T.pack (show (toThreeDecimals h)))+ LowLevel.setLabel gInput (T.pack (show (toThreeDecimals s)))+ LowLevel.setLabel bInput (T.pack (show (toThreeDecimals v)))+ return ()+ HexMode -> do+ rgbE <- LowLevel.getRgb c+ case rgbE of+ Left _ -> return ()+ Right (Between0And1 r, Between0And1 g, Between0And1 b) -> do+ mapM_ (\i -> do+ LowLevel.range i 0 1+ LowLevel.setStep i 1+ LowLevel.precision i 3)+ [rInput,gInput,bInput]+ LowLevel.setValue rInput r+ LowLevel.setValue gInput g+ LowLevel.setValue bInput b+ LowLevel.setSelectionColor rInput redColor+ LowLevel.setSelectionColor gInput greenColor+ LowLevel.setSelectionColor bInput blueColor+ LowLevel.setLabel rInput (T.pack ("0x" ++ (showHex (truncate (255*r+0.5)) "")))+ LowLevel.setLabel gInput (T.pack ("0x" ++ (showHex (truncate (255*g+0.5)) "")))+ LowLevel.setLabel bInput (T.pack ("0x" ++ (showHex (truncate (255*b+0.5)) "")))+ return ()+ ByteMode -> do+ rgbE <- LowLevel.getRgb c+ case rgbE of+ Left _ -> return ()+ Right (Between0And1 r, Between0And1 g, Between0And1 b) -> do+ mapM_ (\i -> do+ LowLevel.range i 0 1+ LowLevel.setStep i 1+ LowLevel.precision i 3)+ [rInput,gInput,bInput]+ LowLevel.setValue rInput r+ LowLevel.setValue gInput g+ LowLevel.setValue bInput b+ LowLevel.setSelectionColor rInput redColor+ LowLevel.setSelectionColor gInput greenColor+ LowLevel.setSelectionColor bInput blueColor+ LowLevel.setLabel rInput (T.pack (show (truncate (255*r+0.5))))+ LowLevel.setLabel gInput (T.pack (show (truncate (255*g+0.5))))+ LowLevel.setLabel bInput (T.pack (show (truncate (255*b+0.5))))+ return ()+ LowLevel.getParent rInput >>= maybe (return ()) LowLevel.redrawLabel++fillBoxWithColor :: Ref LowLevel.Box -> Color -> IO ()+fillBoxWithColor b color = do+ bounds <- LowLevel.getRectangle b+ let slightlyDarker = Enumerations.colorAverage color blackColor 0.80+ let spec =+ BorderBoxSpec+ {+ borderBoxHoveringColor = slightlyDarker+ , borderBoxColor = slightlyDarker+ , borderBoxFocusedColor = slightlyDarker+ , borderBoxFillColor = color+ , borderBoxBounds = bounds+ }+ drawBorderBox b spec True++drawPreviewColor :: Ref LowLevel.ColorChooser -> Ref LowLevel.Box -> IO ()+drawPreviewColor c b = do+ rgbE <- LowLevel.getRgb c+ either+ (\_ -> return ())+ (\rgb -> do+ color <- rgbColorWithRgb (extractRgb rgb)+ fillBoxWithColor b color)+ rgbE++drawCurrentColor :: Color -> Ref LowLevel.Box -> IO ()+drawCurrentColor c b = fillBoxWithColor b c++drawColorDials :: (?assets :: Assets) => Ref LowLevel.ColorChooser -> IORef ColorChooserState -> Rectangle -> Maybe Color -> IO (Ref LowLevel.FillDial,Ref LowLevel.FillDial,Ref LowLevel.FillDial,Ref LowLevel.Group)+drawColorDials c stateRef rect initialColor =+ let modeMenuHeight = 20+ colorDialHeight = 40+ modeMenuPadding = 3+ (x',y',w',h') = fromRectangle rect+ dialSize = Size (Width colorDialHeight) (Height colorDialHeight)+ in do+ modeMenu <- choiceNew (toRectangle (x',y',w',modeMenuHeight)) Nothing+ rgbI <- LowLevel.add modeMenu "RGB" Nothing (Nothing :: Maybe (Ref LowLevel.MenuItem -> IO ())) (MenuItemFlags [])+ _ <- LowLevel.add modeMenu "Byte" Nothing (Nothing :: Maybe (Ref LowLevel.MenuItem -> IO ())) (MenuItemFlags [])+ _ <- LowLevel.add modeMenu "Hex" Nothing (Nothing :: Maybe (Ref LowLevel.MenuItem -> IO ())) (MenuItemFlags [])+ _ <- LowLevel.add modeMenu "HSV" Nothing (Nothing :: Maybe (Ref LowLevel.MenuItem -> IO ())) (MenuItemFlags [])+ _ <- LowLevel.setValue modeMenu (LowLevel.MenuItemByIndex rgbI)+ let colorDialGroupY = y'+modeMenuHeight+modeMenuPadding+ colorDialGroupH = 3*colorDialHeight+ colorDialGroup <- groupNew (toRectangle (x',colorDialGroupY,w',colorDialGroupH)) Nothing+ LowLevel.begin colorDialGroup+ let rValuePosition = Position (X x') (Y (y'+modeMenuHeight+modeMenuPadding))+ gValuePosition = Position (X x') (Y (y'+modeMenuHeight+modeMenuPadding+colorDialHeight))+ bValuePosition = Position (X x') (Y (y'+modeMenuHeight+modeMenuPadding+(2*colorDialHeight)))+ rValue <- fillDialNew (Rectangle rValuePosition dialSize) Nothing+ gValue <- fillDialNew (Rectangle gValuePosition dialSize) Nothing+ bValue <- fillDialNew (Rectangle bValuePosition dialSize) Nothing+ mapM_ (\w -> do+ LowLevel.setAlign w (Alignments [AlignTypeRight])+ LowLevel.setCallback w (\_ -> colorDialCallback rValue gValue bValue c))+ [rValue,gValue,bValue]+ LowLevel.end colorDialGroup+ previewGroup <- groupNew (toRectangle (x',colorDialGroupY+colorDialGroupH,w',colorDialGroupY-y')) Nothing+ let previewBoxHeight = 20 -- (h'-colorDialGroupH-modeMenuHeight-modeMenuPadding) `intDiv` 2+ LowLevel.begin previewGroup+ LowLevel.boxCustom (toRectangle (x',colorDialGroupY+colorDialGroupH+modeMenuPadding,w',previewBoxHeight-modeMenuPadding)) Nothing+ (Just (drawPreviewColor c))+ Nothing+ case initialColor of+ Just initialColor' -> do+ LowLevel.boxCustom (toRectangle (x',colorDialGroupY+colorDialGroupH+modeMenuPadding+previewBoxHeight,w',previewBoxHeight-modeMenuPadding)) Nothing+ (Just (drawCurrentColor initialColor'))+ Nothing+ return ()+ Nothing -> return ()+ LowLevel.end previewGroup+ LowLevel.setResizable previewGroup (Nothing :: Maybe (Ref LowLevel.Widget))+ LowLevel.setCallback modeMenu (modeMenuCallback stateRef rValue gValue bValue c)+ return (rValue, gValue, bValue,previewGroup)++colorChooserNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> Maybe Color -> IO (Ref LowLevel.ColorChooser)+colorChooserNew rect l' initialColor =+ let layout = makeColorChooserComponentLayout (rectangleSize rect) maxSliderWidth defaultGaugeHeight+ componentBounds = makeColorChooserComponentBounds layout rect defaultGaugeHeight+ in mdo+ let initialState =+ ColorChooserState+ {+ colorChooserR = Between0And1 1.0+ , colorChooserG = Between0And1 1.0+ , colorChooserB = Between0And1 1.0+ , colorChooserHue = Between0And6 0.0+ , colorChooserSaturation = Between0And1 0.0+ , colorChooserValue = Between0And1 1.0+ , colorChooserHueImage = hueImage+ , colorChooserMode = RgbMode+ }+ stateRef <- newIORef initialState+ c <- LowLevel.colorChooserCustom rect l' Nothing+ (Just+ (LowLevel.CustomColorChooserFuncs+ {+ LowLevel.getModeCustom = \_ -> fmap colorChooserMode (readIORef stateRef)+ , LowLevel.setModeCustom = \_ m -> modifyIORef stateRef (\state -> state { colorChooserMode = m })+ , LowLevel.hueCustom = \_ -> fmap colorChooserHue (readIORef stateRef)+ , LowLevel.saturationCustom = \_ -> fmap colorChooserSaturation (readIORef stateRef)+ , LowLevel.valueCustom = \_ -> fmap colorChooserValue (readIORef stateRef)+ , LowLevel.rCustom = \_ -> fmap colorChooserR (readIORef stateRef)+ , LowLevel.gCustom = \_ -> fmap colorChooserG (readIORef stateRef)+ , LowLevel.bCustom = \_ -> fmap colorChooserB (readIORef stateRef)+ , LowLevel.hsvCustom = updateHsv stateRef g b rValue gValue bValue previewGroup+ , LowLevel.rgbCustom = updateRgb stateRef g b rValue gValue bValue previewGroup+ }))+ Nothing+ cs <- LowLevel.getArray c+ mapM_ LowLevel.hide cs+ numChildren <- LowLevel.children c+ mapM_ (LowLevel.removeIndex c . AtIndex) [0 .. numChildren-1]+ let color = lightBackground+ LowLevel.setColor c color+ LowLevel.begin c+ hueImage <- generateImage (rectangleSize (colorChooserHueBoxBounds componentBounds))+ b <- LowLevel.boxCustom (colorChooserHueBoxBounds componentBounds) Nothing+ (Just (drawHueBox (hueBoxHandleRadius layout) defaultGaugeHeight stateRef c))+ (Just (LowLevel.defaultCustomWidgetFuncs {LowLevel.handleCustom = (Just (handleHueBox (hueBoxHandleRadius layout) defaultGaugeHeight c))}))+ g <- LowLevel.sliderCustom+ (colorChooserSliderBounds componentBounds)+ Nothing+ (Just (drawSaturationSlider stateRef))+ (Just (LowLevel.defaultCustomWidgetFuncs {LowLevel.handleCustom = Just handleHover}))+ sliderSetup g+ LowLevel.setCallback g (sliderCallback stateRef c)+ let (paneX, paneY, paneW, paneH) = fromRectangle (colorChooserPreviewPaneBounds componentBounds)+ (Rectangle (Position _ (Y hueBoxY)) (Size _ (Height hueBoxHeight))) = hueBoxBounds (colorChooserHueBoxBounds componentBounds)(hueBoxHandleRadius layout) defaultGaugeHeight+ rgbE <- LowLevel.getRgb c+ let previewPaneDialBounds = toRectangle (paneX,hueBoxY,paneW,hueBoxHeight)+ previewPaneDialGroup <- groupNew previewPaneDialBounds Nothing+ LowLevel.begin previewPaneDialGroup+ (rValue,gValue,bValue,previewGroup) <- drawColorDials c stateRef (toRectangle (paneX,hueBoxY,paneW,hueBoxHeight)) initialColor+ LowLevel.end previewPaneDialGroup+ LowLevel.setResizable previewPaneDialGroup (Nothing :: (Maybe (Ref LowLevel.Widget)))+ either+ (\_ -> return ())+ (\rgb@(Between0And1 r,Between0And1 g,Between0And1 b) -> do+ LowLevel.setValue rValue r+ LowLevel.setValue gValue g+ LowLevel.setValue bValue b+ setValuators rValue gValue bValue c+ return ())+ rgbE+ LowLevel.end c+ LowLevel.setResizable c (Just b)+ LowLevel.setColor c color+ LowLevel.setBox c BorderBox+ LowLevel.setLabelfont c commonFont+ LowLevel.setLabelsize c commonFontSize+ commonSelectionColor >>= LowLevel.setSelectionColor c+ return c++flcColorChooser :: (?assets :: Assets) => Maybe T.Text -> Maybe Rectangle -> Maybe Color -> Maybe ColorChooserMode -> IO (Maybe Color)+flcColorChooser name rectM initialColor mode =+ let buttonBarHeight = 50+ colorChooserPadding = 5+ windowBounds = maybe ((Rectangle (Position (X 215) (Y 200)) (Size (Width 400) (Height (200 + buttonBarHeight))))) id rectM+ colorChooserBounds =+ let (x',y',w',h') = fromRectangle windowBounds+ in toRectangle(colorChooserPadding,0,w'-(colorChooserPadding*2),h'-buttonBarHeight)+ buttonBarBounds =+ let (x',y',w',h') = fromRectangle windowBounds+ in toRectangle (colorChooserPadding,h'-buttonBarHeight,w'-(colorChooserPadding*2),buttonBarHeight)+ buttonWidth = 65+ buttonHeight = 30+ cancelButtonBounds =+ let (buttonGroupX, buttonGroupY, buttonGroupW, buttonGroupH) = fromRectangle buttonBarBounds+ in toRectangle (buttonGroupX+buttonGroupW-buttonWidth, buttonGroupY+((buttonGroupH-buttonHeight) `intDiv` 2),buttonWidth,buttonHeight)+ okButtonBounds =+ let (buttonGroupX, buttonGroupY, buttonGroupW, buttonGroupH) = fromRectangle buttonBarBounds+ in toRectangle (buttonGroupX+buttonGroupW-buttonWidth-5-buttonWidth,buttonGroupY+((buttonGroupH-buttonHeight) `intDiv` 2),buttonWidth,buttonHeight)+ showUntilHidden w = do+ isShown <- LowLevel.shown w+ if isShown then FL.wait >> showUntilHidden w+ else return ()+ buttonCallback :: IORef Bool -> Ref LowLevel.DoubleWindow -> Bool -> Ref LowLevel.Button -> IO ()+ buttonCallback selectedRef w v _ = do+ LowLevel.hide w+ writeIORef selectedRef v+ in do+ okSelectedRef <- newIORef False+ window <- doubleWindowNew (rectangleSize windowBounds) (Just (rectanglePosition windowBounds)) name+ LowLevel.begin window+ cc <- colorChooserNew colorChooserBounds Nothing initialColor+ buttonGroup <- groupNew buttonBarBounds Nothing+ LowLevel.begin buttonGroup+ okButton <- okButtonNew okButtonBounds+ cancelButton <- cancelButtonNew cancelButtonBounds+ LowLevel.setCallback okButton (buttonCallback okSelectedRef window True)+ LowLevel.setCallback cancelButton (buttonCallback okSelectedRef window False)+ LowLevel.end buttonGroup+ LowLevel.end window+ LowLevel.setModal window+ LowLevel.hotSpot window (LowLevel.ByWidget window) Nothing+ LowLevel.setResizable window (Just cc)+ LowLevel.showWidget window+ showUntilHidden window+ okSelected <- readIORef okSelectedRef+ if okSelected+ then do+ rgb <- LowLevel.getRgb cc+ case rgb of+ Left OutOfRange -> throwIO (userError "flcColorChooser: RGB value selected is out of range.")+ Right rgb' -> rgbColorWithRgb (extractRgb rgb') >>= return . Just+ else return initialColor
+ src/Graphics/UI/FLTK/Theme/Light/Common.hs view
@@ -0,0 +1,497 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Common+ (+ -- * Theme Loading+ configureTheme,+ -- * Common Colors & Fonts+ commonColor,+ commonDarkGreyColor,+ commonFillColor,+ commonFont,+ commonFontSize,+ commonLargeFontSize,+ commonSelectionColor,+ lightBackground,+ -- * Common Calculations For Drawing Widgets+ angleToCoordinate,+ centerInRectangle,+ centerInRectangleByRelativePosition,+ degreesPerRadian,+ fromFltkAngle,+ insideRectangle,+ intDiv,+ isWidget,+ percentOf,+ percentOfSmallerEllipseRadius,+ positionInside,+ splitVertically,+ splitVerticallyByPixels,+ splitHorizontally,+ splitHorizontallyByPixels,+ withPositionX,+ withPositionY,+ withSizeHeight,+ withSizeWidth,+ -- * Common Widget Drawing Helpers+ withCustomBoxDraw,+ BorderBoxSpec(..),+ drawBorderBox,+ FillSpec(..),+ makeFillSpec,+ borderRectangle,+ fillRectangle,+ handleHover,+ OpenBorder(..),+ roundedBoxPoints+ )+where+import Control.Monad+import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.LowLevel.FLTKHS hiding (colorAverage, isHorizontal, inactive, tabPositionsCustom, tabHeightCustom, tabDrawCustom, find, tabWhichCustom, tabRedrawTabs)+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.Theme.Light.Assets+import qualified Graphics.UI.FLTK.LowLevel.FL as FL++-- | For drawing a rectangular widget that is borderless on the top or bottom. Guess+-- it could be passed into a function as yet another Bool but we have too many of those+-- as it is.+data OpenBorder =+ OpenBorderTop -- ^ Signifies a bordered rectangle with the top side. Useful, for example, for a bottom tab+ | OpenBorderBottom -- ^ Signifies a bordered rectangle without a bottom side. Useful, for example, for a top tab++-- | Specifies how to draw a border around a 'Rectangle'.+data BorderBoxSpec =+ BorderBoxSpec+ {+ borderBoxBounds :: Rectangle, -- ^ The bounds of the rectangle to border+ borderBoxFocusedColor :: Color, -- ^ The color of the border if the widget is focused+ borderBoxHoveringColor :: Color, -- ^ The color of the border if the mouse pointer is over the widget+ borderBoxColor :: Color, -- ^ The default color of the border+ borderBoxFillColor :: Color -- ^ The fill color of the rectangle. Even though 'FillSpec' exists this is useful if you want a simple solid color and don't care about gradients.+ } deriving Show+++-- | Specifies how a 'Rectangle' should be filled. Allows for a vertical color gradient.+data FillSpec =+ FillSpec+ {+ fillBounds :: Rectangle -- ^ The bounds of the rectangle to be filled+ , fillTopColor :: Color -- ^ The color at the top of the rectangle+ , fillTopSelectionColor :: Color -- ^ The color at the top of the rectangle if this widget is selected (mostly of use to buttons)+ , fillTopFillPercentage :: Int -- ^ The % of the rectangle at that top that is filled with 'fillTopColor' before the gradient begins+ , fillBottomColor :: Color -- ^ The color at the bottom of the rectangle+ , fillBottomSelectionColor :: Color -- ^ The color at the bottom of the rectangle if this widget is selected (mostly of use to buttons)+ , fillBottomFillPercentage :: Int -- ^ The % of the rectangle at the bottom that is filled with 'fillBottomColor' after the gradient ends+ , fillCornerRadius :: Int -- ^ The roundedness of the corners+ , fillBorderColor :: Color -- ^ The border color of this rectangle+ , fillBorderFocusColor :: Color -- ^ The border color of this rectangle if it is focused+ , fillBorderHovered :: Color -- ^ The border color of this rectangle if the mouse is over it+ }++commonFont :: (?assets :: Assets) => Font+commonFont = dejaVuSans++commonFontSize :: FontSize+commonFontSize = FontSize 12++commonLargeFontSize :: FontSize+commonLargeFontSize = FontSize 22++commonColor :: IO Color+commonColor = rgbColorWithRgb (0xF9, 0xF9, 0xF9)++commonDarkGreyColor :: IO Color+commonDarkGreyColor = rgbColorWithRgb (80,81,84)++commonFillColor :: IO Color+commonFillColor = rgbColorWithRgb (0x66, 0x94, 0xE3)++lightBackground :: Color+lightBackground = whiteColor++-- | Converts from an FLTK angle to a unit circle's. FLTK starts its angles counter-clockwise+-- from 270 so, for example, 45 degrees in FLTK is 270-45 = 225 degrees on a unit circle.+-- Angle unit is in degrees.+fromFltkAngle :: PreciseAngle -> PreciseAngle+fromFltkAngle (PreciseAngle a) =+ let unitCircleAngle = (270 - (truncate a)) `mod` 360+ in+ PreciseAngle+ (if (unitCircleAngle < 0)+ then 360.0 - (abs (fromIntegral unitCircleAngle))+ else (fromIntegral unitCircleAngle))++-- | pi/180+degreesPerRadian :: Double+degreesPerRadian = pi/180++-- | Given a 'PreciseAngle' /in degrees/ return the corresponding location on the unit circle+angleToCoordinate :: PreciseAngle -> PrecisePosition+angleToCoordinate (PreciseAngle a) =+ case a of+ _ | a == 360 -> PrecisePosition (PreciseX (cos 0)) (PreciseY (sin 0))+ | otherwise ->+ let radians = a * degreesPerRadian+ in PrecisePosition (PreciseX (cos radians)) (PreciseY (sin radians))++-- | Straightfoward % of the given 'Int', the 'Double' % must be between 0.0 and 1.0+percentOf :: Double -> Int -> Int+percentOf p a = truncate ((fromIntegral a) * p)++-- | Given the width and height of an ellipse via 'PreciseSize', return+-- the 'Double' % of the smaller radius. % must be between 0.0 and 1.0.+-- Used in 'Dial's and 'Clock's to measure the length of hands.+percentOfSmallerEllipseRadius :: Double -> PreciseSize -> Double+percentOfSmallerEllipseRadius percent (PreciseSize (PreciseWidth rW) (PreciseHeight rH)) = ((if (rW < rH) then rW else rH) * percent) / 100.0++commonSelectionColor :: IO Color+commonSelectionColor = rgbColorWithRgb (50, 100, 201)++-- | Check if the given references point to the same 'Widget'.+isWidget :: (Parent a Widget) => Ref a -> IO (Maybe (Ref b)) -> IO Bool+isWidget this thatM = thatM >>= maybe (return False) (refPtrEquals this)++-- | Check if the given 'Position' is inside the 'Rectangle'. Useful for+-- checking if an event happened within some bounds.+insideRectangle :: Position -> Rectangle -> Bool+insideRectangle (Position (X x) (Y y)) rect =+ let (rx,ry,rw,rh) = fromRectangle rect+ in x >= rx && x <= rx+rw && y >= ry && y <= ry+rh++-- | Return a set of vertices that circumscribe a region bounded by 'Rectangle'.+-- The 'Maybe' 'Int' when provided means the rectangle has rounded corners of+-- 'Int' radius. In a rounded rectangle the vertices don't meet stopping short+-- of the corners, the client is responsible for filling in the arcs.+--+-- 'Maybe' 'OpenBorder' determines whether the rectangle is whole (if not+-- provided) or has an open top or bottom.+roundedBoxPoints :: Rectangle -> Maybe Int -> Maybe OpenBorder -> [Position]+roundedBoxPoints (Rectangle (Position (X x) (Y y)) (Size (Width w) (Height h))) maybeRadius maybeOpen =+ let insideW = w-1+ insideH = h-1+ in+ map toPosition+ (case (maybeRadius,maybeOpen) of+ (Just radius, Nothing) ->+ [+ (x+radius,y)+ , (x+insideW-radius,y)+ , (x+insideW,y+radius)+ , (x+insideW,y+insideH-radius)+ , (x+insideW-radius,y+insideH)+ , (x+radius,y+insideH)+ , (x,y+insideH-radius)+ , (x,y+radius)+ , (x+radius,y)+ ]+ (Just radius, Just OpenBorderBottom) ->+ [+ (x,y+h)+ , (x,y+radius)+ , (x+radius,y)+ , (x+insideW-radius,y)+ , (x+insideW,y+radius)+ , (x+insideW,y+h)+ ]+ (Just radius, Just OpenBorderTop) ->+ [+ (x+insideW,y)+ , (x+insideW,y+insideH-radius)+ , (x+insideW-radius,y+insideH)+ , (x+radius,y+insideH)+ , (x,y+insideH-radius)+ , (x,y)+ ]+ (Nothing, Just OpenBorderBottom) ->+ [+ (x,y+insideH)+ , (x,y)+ , (x+insideW,y)+ , (x+insideW,y+insideH)+ ]+ (Nothing, Just OpenBorderTop) ->+ [+ (x,y)+ , (x,y+insideH)+ , (x+insideW,y+insideH)+ , (x+insideW,y)+ ]+ (Nothing, Nothing) ->+ [+ (x,y)+ , (x+insideW,y)+ , (x+insideW,y+insideH)+ , (x,y+insideH)+ , (x,y)+ ])++-- | Draw a bordered rectangle for the given widget according to 'BorderBoxSpec', the 'Bool'+-- determines if it should be filled with 'borderBoxFillColor'.+drawBorderBox :: (Parent a Widget) => Ref a -> BorderBoxSpec -> Bool -> IO ()+drawBorderBox w spec shouldFill = do+ oldColor <- flcColor+ focused <- isWidget w FL.focus+ hovering <- isWidget w FL.belowmouse+ when shouldFill (flcRectfWithColor (borderBoxBounds spec) (borderBoxFillColor spec))+ if focused+ then flcSetColor (borderBoxFocusedColor spec)+ else if hovering+ then flcSetColor (borderBoxHoveringColor spec)+ else flcSetColor (borderBoxColor spec)+ flcBeginLine+ mapM_ (flcVertex . toPrecisePosition) (roundedBoxPoints (borderBoxBounds spec) Nothing Nothing)+ flcEndLine+ flcSetColor oldColor++-- | The default FLTK widgets don't react to a mouse pointer hovering over them.+-- This handler when applied to a customized widget initiates a 'redraw' when the+-- mouse enters and leaves the widget area.+handleHover ::+ (+ Parent orig Widget,+ Match x ~ FindOp orig orig (Redraw ()),+ Op (Redraw ()) x orig (IO ()),+ Match y ~ FindOp orig orig (HandleSuper ()),+ Op (HandleSuper ()) y orig (Event -> IO (Either UnknownEvent ()))+ )+ => Ref orig -> Event -> IO (Either UnknownEvent ())+handleHover b e = do+ case e of+ Enter -> do+ () <- redraw b+ return (Right())+ Leave -> do+ () <- redraw b+ return (Right ())+ _ -> handleSuper b e++-- | Temporarily swap out the FLTK's box drawing function for a given 'Boxtype'+-- with 'BoxDrawF'. The 'IO' '()' action will typically use the custom function+-- that was just swapped in some kind custom drawing routine. For example, if a+-- custom widget used a 'BorderBox' on the FLTK side but you don't like the+-- default 'BorderBox' look, you can override the 'draw' function of the widget+-- with this one where the 'IO' '()' action calls 'drawSuper'. For an example+-- use-case see 'Graphics.UI.FLTK.Theme.Light.Input.inputDraw'.+--+-- NOTE: The 'IO' '()' action is /not/ exception safe.+withCustomBoxDraw :: Boxtype -> BoxDrawF -> IO () -> IO ()+withCustomBoxDraw boxtype customBoxDrawF action = do+ fptr <- FL.getBoxtypePrim boxtype+ dx <- FL.boxDx boxtype+ dy <- FL.boxDy boxtype+ dw <- FL.boxDw boxtype+ dh <- FL.boxDh boxtype+ FL.setBoxtype boxtype (FL.FromSpec customBoxDrawF 0 0 0 0)+ action+ FL.setBoxtype boxtype (FL.FromFunPtr fptr (fromIntegral dx) (fromIntegral dy) (fromIntegral dw) (fromIntegral dh))++-- | Make the default 'FillSpec' used by most of the theme color graded with the initial 'Color'. The second 'Color'+-- is used to determine the border color.+makeFillSpec :: Rectangle -> Color -> Color -> IO FillSpec+makeFillSpec rect color selectionColor = do+ (colorR, colorG, colorB) <- FL.getColorRgb color+ pressedColor <- rgbColorWithRgb (colorR - 21, colorG - 21, colorB - 21)+ let slightlyDarker = colorAverage color blackColor 0.93+ let slightlyLighter = colorAverage whiteColor pressedColor 0.93+ hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB)+ let darkerSelectionColor = darker selectionColor+ return+ FillSpec+ {+ fillBounds = rect,+ fillTopColor = color,+ fillTopSelectionColor = pressedColor,+ fillTopFillPercentage = 30,+ fillBottomColor = slightlyDarker,+ fillBottomSelectionColor = slightlyLighter,+ fillBottomFillPercentage = 70,+ fillCornerRadius = 2,+ fillBorderColor = slightlyDarker,+ fillBorderFocusColor = darkerSelectionColor,+ fillBorderHovered = hoverColor+ }++-- | Draw the border around the 'Rectangle' specified by 'FillSpec' possibly changing the border color+-- if the widget (usually a Button) is currently focused or if the mouse pointer is hovering over it.+borderRectangle :: FillSpec -> Bool -> Bool -> IO ()+borderRectangle spec focused hovering = do+ oldColor <- flcColor+ if focused+ then flcSetColor (fillBorderFocusColor spec)+ else if hovering+ then flcSetColor (fillBorderHovered spec)+ else flcSetColor (fillBorderColor spec)+ flcBeginLine+ mapM_ (flcVertex . toPrecisePosition) (roundedBoxPoints (fillBounds spec) (Just (fillCornerRadius spec)) Nothing)+ flcEndLine+ flcLineStyle (LineDrawStyle (Just LineStyleSolid) Nothing Nothing) Nothing Nothing+ flcSetColor oldColor++-- | Draw a box according to the 'FillSpec'. It was originally intended for custom "Graphics.UI.FLTK.Theme.Light.Button"+-- which is why it takes a 'Bool' specifies if the button is pressed but is used widely in the theme for any rounded+-- rectangular area.+fillRectangle :: FillSpec -> Bool -> IO ()+fillRectangle spec pressed = do+ if pressed+ then drawButton (fillTopSelectionColor spec) (fillBottomSelectionColor spec)+ else drawButton (fillTopColor spec) (fillBottomColor spec)+ where+ drawButton topColor bottomColor = do+ let diameter = (fillCornerRadius spec) * 2+ quarterCircle x y a1 a2 = do+ fillColor <- flcColor+ flcPie (toRectangle (x,y,diameter,diameter)) a1 a2+ flcSetColor fillColor+ oldColor <- flcColor+ -- top left/right+ let (x,y,w,h) = fromRectangle (fillBounds spec)+ insideW = w+ insideH = h+ topFillFraction :: Double+ topFillFraction = (fromIntegral (fillTopFillPercentage spec)) / 100.0+ topHeight = truncate (fromIntegral insideH * topFillFraction)+ flcSetColor topColor+ flcRectf (toRectangle (x + (fillCornerRadius spec), y, insideW - diameter, (fillCornerRadius spec)))+ flcRectf (toRectangle (x, y + (fillCornerRadius spec), insideW , topHeight - (fillCornerRadius spec)))+ -- bottom left/right+ let bottomFillFraction :: Double+ bottomFillFraction = (fromIntegral (fillBottomFillPercentage spec)) / 100.0+ bottomHeight = truncate (fromIntegral insideH * bottomFillFraction)+ flcSetColor bottomColor+ when (diameter > 0)+ (do+ quarterCircle x y (PreciseAngle 90.0) (PreciseAngle 180.0)+ quarterCircle (x + (insideW - diameter)) y (PreciseAngle 0) (PreciseAngle 90.0)+ quarterCircle x (y + (insideH - diameter)) (PreciseAngle 180.0) (PreciseAngle 270.0)+ quarterCircle (x + (insideW - diameter)) (y + (insideH - diameter)) (PreciseAngle 270.0) (PreciseAngle 360.0)+ flcRectf (toRectangle (x + (fillCornerRadius spec), y + h - (fillCornerRadius spec), insideW - (diameter), (fillCornerRadius spec))))+ flcRectf (toRectangle (x, y + bottomHeight, insideW, h - bottomHeight - (fillCornerRadius spec)))+ -- middle gradient+ let middleFraction = fromIntegral (fillBottomFillPercentage spec - fillTopFillPercentage spec) / 100.0+ totalSteps :: Double+ totalSteps = fromIntegral h * middleFraction+ stepSize :: Double+ stepSize = 1.0 / totalSteps+ mapM_+ (+ \step -> do+ let weight = 1.0 - (stepSize * fromIntegral step)+ blendColor =+ colorAverage+ topColor+ bottomColor+ weight+ flcSetColor blendColor+ flcXyline (toPosition (x,y + topHeight + step)) (X (x + insideW - 1))+ )+ [0 .. truncate totalSteps - 1]+ flcSetColor oldColor++-- | Return the 'Position' which centers the given 'Size' in 'Rectangle'.+centerInRectangle :: Rectangle -> Size -> Position+centerInRectangle r (Size (Width sW) (Height sH)) =+ let (rX,rY,rW,rH) = fromRectangle r+ posX = rX + ((rW-sW) `intDiv` 2)+ posY = rY + ((rH-sH) `intDiv` 2)+ in toPosition (posX,posY)++-- | Return the 'Rectangle' that is centered in the given 'Rectangle' by the+-- 'X' and 'Y' /offset/ , so for example, (X 20) (Y 20) returns+-- a 'Rectangle' with a top left coordinate which is 20 pixels over and 20+-- pixels below the top left of the given 'Rectangle'.+centerInRectangleByRelativePosition :: Rectangle -> X -> Y -> Rectangle+centerInRectangleByRelativePosition r (X xOff) (Y yOff) =+ let (rX,rY,rW,rH) = fromRectangle r+ r2W = rW - (2*xOff)+ r2H = rH - (2*yOff)+ in toRectangle (rX+xOff,rY+yOff,r2W,r2H)++-- | Return a 'Rectangle' of 'Size' positioned at 'X' and 'Y' inside the given+-- 'Rectangle'. It's on the caller to make sure that the resulting 'Rectangle'+-- actually fits inside the one passed in. 'Size', 'X' and 'Y' are+-- not checked.+positionInside :: Rectangle -> Size -> X -> Y -> Rectangle+positionInside r (Size (Width sW) (Height sH)) (X xOff) (Y yOff) =+ let (rX,rY,rW,rH) = fromRectangle r+ in toRectangle (rX+xOff,rY+yOff,sW,sH)++-- | Transform the height.+withSizeHeight :: Size -> (Height -> Height) -> Size+withSizeHeight (Size w h) f = Size w (f h)++-- | Transform the width.+withSizeWidth :: Size -> (Width -> Width) -> Size+withSizeWidth (Size w h) f = Size (f w) h++-- | Transform the X coordinate of a location+withPositionX :: Position -> (X -> X) -> Position+withPositionX (Position x y) f = Position (f x) y++-- | Transform the Y coordinate of a location+withPositionY :: Position -> (Y -> Y) -> Position+withPositionY (Position x y) f = Position x (f y)++-- | Split the width of the 'Rectangle' into two side-by-side+-- ('Rectangle','Rectangle') by the 'Double' %. % must be between 0.0 and 1.0.+-- The width of the 2 returned rectangles will always sum to the width of the+-- one passed in.+splitVertically :: Rectangle -> Double -> (Rectangle, Rectangle)+splitVertically r percent =+ let (rx,ry,rw,rh) = fromRectangle r+ r1w = truncate ((fromIntegral rw) * percent)+ r2w = rw-r1w+ r2x = rx+r1w+ in (toRectangle (rx,ry,r1w,rh), toRectangle (r2x,ry,r2w,rh))++-- | Like 'splitVertically' but takes a 'Int' pixel width instead of a %. If the+-- width is greater than the 'Rectangle' the first of the pair will be the+-- 'Rectangle' passed in and the second will have the same dimensions but a 0+-- width.+splitVerticallyByPixels :: Rectangle -> Int -> (Rectangle, Rectangle)+splitVerticallyByPixels r ps =+ let (rx,ry,rw,rh) = fromRectangle r+ r1w = if (ps >= rw) then rw else ps+ r2w = rw-r1w+ r2x = rx+r1w+ in (toRectangle (rx,ry,r1w,rh), toRectangle (r2x,ry,r2w,rh))++-- | Split the height of the 'Rectangle' into two stacked+-- ('Rectangle','Rectangle') by the 'Double' %. % must be between 0.0 and 1.0.+-- The height of the 2 returned rectangles will always sum to the height of the+-- one passed in.+splitHorizontally :: Rectangle -> Double -> (Rectangle, Rectangle)+splitHorizontally r percent =+ let (rx,ry,rw,rh) = fromRectangle r+ r1h = truncate ((fromIntegral rh) * percent)+ r2h = rh-r1h+ r2y = ry+r1h+ in (toRectangle (rx,ry,rw,r1h), toRectangle (rx,r2y,rw,r2h))++-- | Like 'splitHorizontally' but takes a 'Int' pixel height instead of a %. If the+-- height is greater than the 'Rectangle' the first of the pair will be the+-- 'Rectangle' passed in and the second will have the same dimensions but a 0+-- height.+splitHorizontallyByPixels :: Rectangle -> Int -> (Rectangle,Rectangle)+splitHorizontallyByPixels r ps =+ let (rx,ry,rw,rh) = fromRectangle r+ r1h = if (ps >= rh) then rh else ps+ r2h = rh-r1h+ r2y = ry+r1h+ in (toRectangle (rx,ry,rw,r1h), toRectangle (rx,r2y,rw,r2h))++-- | A lossy division of 'Int'/'Int'. The result is 'truncate'd but it's good+-- enough for widget dimensions which is the primary use-case.+intDiv :: Int -> Int -> Int+intDiv num denom = truncate (((fromIntegral num) / (fromIntegral denom)) :: Double)++-- | Needs to be called by every app to load the themes's resources and do some+-- minor setup See "Graphics.UI.FLTK.Theme.Light#GettingStarted" for more+-- information.+configureTheme :: IO Assets+configureTheme = do+ assets <- loadAssets+ let ?assets = assets+ FL.setColor background2Color lightBackground+ tooltipSetFont commonFont+ tooltipSetSize commonFontSize+ return assets
+ src/Graphics/UI/FLTK/Theme/Light/Counter.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings #-}+module Graphics.UI.FLTK.Theme.Light.Counter+ (+ counterNew,+ -- * Counter drawing and handling helpers+ counterComponentsBounds,+ drawCounter,+ handleCounter+ )+where+import Control.Exception+import Control.Monad+import Data.IORef+import Data.List+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Button+import Graphics.UI.FLTK.Theme.Light.Common+import Graphics.UI.FLTK.Theme.Light.Input+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++data CounterButton = NormalLL | NormalL | NormalR | NormalRR | SimpleL | SimpleR deriving (Eq,Show)++counterComponentsBounds :: LowLevel.CounterType -> Rectangle -> [Rectangle]+counterComponentsBounds c rect =+ let (x',y',w',h') = fromRectangle rect+ in+ case c of+ LowLevel.SimpleCounterType ->+ let arrowButtonWidth = (w'*20) `intDiv` 100+ inputWidth = w' - ((w'*40) `intDiv` 100)+ in+ [+ toRectangle (x',y',arrowButtonWidth,h')+ , toRectangle (x'+arrowButtonWidth+inputWidth,y',arrowButtonWidth,h')+ , toRectangle (x'+arrowButtonWidth,y',w'-(arrowButtonWidth*2),h')+ ]+ LowLevel.NormalCounterType ->+ let arrowButtonWidth = (w'*15) `intDiv` 100+ in+ [+ toRectangle (x',y',arrowButtonWidth,h')+ , toRectangle (x'+arrowButtonWidth,y',arrowButtonWidth,h')+ , toRectangle (x'+w'-arrowButtonWidth-arrowButtonWidth,y',arrowButtonWidth,h')+ , toRectangle (x'+w'-arrowButtonWidth,y',arrowButtonWidth,h')+ , toRectangle (x'+arrowButtonWidth+arrowButtonWidth,y',w'-(arrowButtonWidth*4),h')+ ]++calculatePressedButton :: Position -> Ref LowLevel.Counter -> IO (Either () (Maybe CounterButton))+calculatePressedButton pos c = do+ r <- LowLevel.getRectangle c+ ct <- LowLevel.getType_ c+ let cl = counterComponentsBounds ct r+ normalComponenets = [NormalLL,NormalL,NormalR,NormalRR]+ simpleComponents = [SimpleL,SimpleR]+ case cl of+ (dl:l:r:rr:_:[]) -> do+ let events = map (\r -> insideRectangle pos r) [dl,l,r,rr]+ return (maybe (Right Nothing) (\i -> (Right (Just (normalComponenets !! i)))) (Data.List.elemIndex True events))+ (l:r:_:[]) -> do+ let events = map (\r -> insideRectangle pos r) [l,r]+ return (maybe (Right Nothing) (\i -> (Right (Just (simpleComponents !! i)))) (Data.List.elemIndex True events))+ _ -> throwIO (userError "A Counter can only have 3 or 5 widget components.")++drawCounter :: (?assets :: Assets) => IORef (Either () (Maybe CounterButton)) -> Ref LowLevel.Counter -> IO ()+drawCounter pressedRef c =+ let arrowBox :: Color -> Rectangle -> Bool -> Ref LowLevel.PNGImage -> IO ()+ arrowBox color rect pressed logo = do+ selectionColor <- LowLevel.getSelectionColor c+ fontSize <- LowLevel.getLabelsize c+ spec <- makeFillSpec rect color selectionColor+ fillRectangle (spec { fillCornerRadius = 0 }) pressed+ LowLevel.flcBeginLine+ mapM_ (LowLevel.flcVertex . toPrecisePosition) (roundedBoxPoints rect Nothing Nothing)+ LowLevel.flcEndLine+ logoSize <- LowLevel.getDataSize logo+ LowLevel.draw logo (centerInRectangle rect logoSize)+ in do+ pressed <- readIORef pressedRef+ color <- LowLevel.getColor c+ ct <- LowLevel.getType_ c+ r <- LowLevel.getRectangle c+ let cl = counterComponentsBounds ct r+ numButtons = length cl - 1+ valueBoxRect = last cl+ mapM_ (\(a,b,c)-> arrowBox color a b c)+ (zip3 (take (length cl - 1) cl)+ (case pressed of+ Left _ -> [False,False,False,False]+ Right Nothing -> [False,False,False,False]+ Right (Just NormalLL) -> [True,False,False,False]+ Right (Just NormalL) -> [False,True,False,False]+ Right (Just NormalR) -> [False,False,True,False]+ Right (Just NormalRR) -> [False,False,False,True]+ Right (Just SimpleL) -> [True,False]+ Right (Just SimpleR) -> [False,True])+ (if (numButtons == 4)+ then [rewindImage,leftImage,rightImage,forwardImage]+ else [leftImage,rightImage]))+ str <- LowLevel.format c+ LowLevel.flcRectfWithColor valueBoxRect color+ inputBox False valueBoxRect color+ case str of+ Left _ -> LowLevel.flcDrawInBox "" valueBoxRect (Alignments [AlignTypeCenter]) Nothing Nothing+ Right s -> LowLevel.flcDrawInBox s valueBoxRect (Alignments [AlignTypeCenter]) Nothing Nothing++handleCounter :: IORef (Either () (Maybe CounterButton )) -> Ref LowLevel.Counter -> Event -> IO (Either UnknownEvent ())+handleCounter pressedRef c e = do+ pressed <- readIORef pressedRef+ let setPressed = do+ pos <- FL.eventPosition+ i <- calculatePressedButton pos c+ when (i /= pressed) (writeIORef pressedRef i)+ case e of+ Release -> do+ case pressed of+ Right _ -> writeIORef pressedRef (Left ())+ Left _ -> return ()+ Push -> setPressed+ Drag -> setPressed+ _ -> return ()+ LowLevel.handleSuper c e++counterNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Counter)+counterNew rect l = do+ i <- newIORef (Left ())+ c <- LowLevel.counterCustom rect l (Just (drawCounter i))+ (Just (LowLevel.defaultCustomWidgetFuncs+ {+ LowLevel.handleCustom = Just (handleCounter i)+ }))+ LowLevel.setColor c lightBackground+ LowLevel.setBox c BorderBox+ LowLevel.setTextfont c commonFont+ LowLevel.setTextsize c commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor c color+ LowLevel.setLabelfont c commonFont+ LowLevel.setLabelsize c commonFontSize+ return c
+ src/Graphics/UI/FLTK/Theme/Light/Dial.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Dial+ (+ dialNew,+ fillDialNew,+ lineDialNew,+ drawDial+ )+where+import Control.Exception+import Control.Monad+import Data.List+import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import Text.Printf+import qualified Data.ByteString.Char8 as BC+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++dialOutline w h rW rH a1X a1Y rWWithStroke rHWithStroke bigCircle a2X a2Y sw colorString =+ "<svg width=\"" ++ (show w) ++ "\" height=\"" ++ (show h) ++ "\" viewBox=\"" ++ (show (-rW)) ++ " " ++ (show (-rH)) ++ " " ++ (show w) ++ " " ++ (show h) ++ "\" >"+ ++ "<path "+ ++ "d=\"M" ++ (show a1X) ++ " " ++ (show a1Y) ++ ""+ ++ "A " ++ (show rWWithStroke) ++ " " ++ (show rHWithStroke) ++ " 0 1 " ++ (show bigCircle) ++ " " ++ (show a2X) ++ " " ++ (show a2Y) ++ ""+ ++ "\""+ ++ "stroke-width=\"" ++ (show sw) ++ "\""+ ++ "stroke=\"" ++ colorString ++ "\""+ ++ "fill=\"none\""+ ++ "stroke-linecap=\"round\""+ ++ "/>"+ ++ "</svg>"++meter w h rW rH meterCenter meterX meterY mw =+ "<svg width=\"" ++ (show w) ++ "\" height=\"" ++ (show h) ++ "\" viewBox=\"" ++ (show (-rW)) ++ " " ++ (show (-rH)) ++ " " ++ (show w) ++ " " ++ (show h) ++ "\">"+ ++ "<circle cx=\"0.0\" cy=\"0.0\" r=\"" ++ (show meterCenter) ++ "\" />"+ ++ "<path "+ ++ "d=\"M0.0 0.0"+ ++ "l" ++ (show meterX) ++ " " ++ (show meterY) ++ ""+ ++ "\""+ ++ "stroke=\"black\""+ ++ "stroke-width=\"" ++ (show mw) ++ "\""+ ++ "stroke-linecap=\"round\""+ -- ++ "fill=\"none\""+ ++ "/>"+ ++ "</svg>"++fillEllipse w h rW rH startX startY rWWithStroke rHWithStroke bigCircle endX endY colorString =+ "<svg width=\"" ++ (show w) ++ "\" height=\"" ++ (show h) ++ "\" viewBox=\"" ++ (show (-rW)) ++ " " ++ (show (-rH)) ++ " " ++ (show w) ++ " " ++ (show h) ++ "\" >"+ ++ "<path "+ ++ "d=\"M" ++ (show startX) ++ " " ++ (show startY) ++ ""+ ++ "A " ++ (show rWWithStroke) ++ " " ++ (show rHWithStroke) ++ " 0 " ++ (show bigCircle) ++ " 1 " ++ (show endX) ++ " " ++ (show endY) ++ ""+ ++ "L 0.0 0.0 Z"+ ++ "\""+ ++ "fill=\"" ++ colorString ++ "\""+ ++ "/>"+ ++ "</svg>"++arrow =+ [+ "<svg width=\"%d\" height=\"%d\" viewBox=\"%f %f %d %d\" transform=\"rotate(%f)\">"+ , "<circle cx=\"%f\" cy=\"%f\" r=\"%f\" fill=\"none\" stroke=\"black\" stroke-width=\"%f\"/>"+ , "<path "+ , "d=\"M%f %f"+ , "L%f %f"+ , "L%f %f"+ , "Z"+ , "\""+ , "fill=\"black\""+ , "/>"+ , "</svg>"+ ]++makeDialOutline :: Size -> PreciseAngle -> PreciseAngle -> String -> String+makeDialOutline (Size (Width w) (Height h)) a1 a2 colorString =+ let ((rW,rH) :: (Double,Double)) = center w h+ PrecisePosition (PreciseX a1X) (PreciseY a1Y) = angleToCoordinate (fromFltkAngle a1)+ PrecisePosition (PreciseX a2X) (PreciseY a2Y) = angleToCoordinate (fromFltkAngle a2)+ sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ in+ dialOutline w h rW rH (a1X * (rW-(sw/2))) ((-a1Y) * (rH-(sw/2))) (rW-(sw/2)) (rH-(sw/2)) (if (a1 < a2) then (1 :: Int) else (0 :: Int)) (a2X * (rW-(sw/2))) ((-a2Y) * (rH-(sw/2))) sw colorString++center :: Int -> Int -> (Double,Double)+center w h = (fromIntegral w / 2, fromIntegral h / 2)++strokeWidth = percentOfSmallerEllipseRadius 10+meterCenterRadius = percentOfSmallerEllipseRadius 8+meterWidth = percentOfSmallerEllipseRadius 5+knobPadding = percentOfSmallerEllipseRadius 3+arrowBase = percentOfSmallerEllipseRadius 25+arrowHeight = percentOfSmallerEllipseRadius 20+arrowPadding = percentOfSmallerEllipseRadius 15++makeMeter :: PreciseAngle -> Size -> String+makeMeter angle (Size (Width w) (Height h)) =+ let (rW,rH) = center w h+ meterLength = if (rW < rH) then rW else rH+ PrecisePosition (PreciseX x) (PreciseY y) = angleToCoordinate (fromFltkAngle angle)+ sw :: Double+ sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ meterCenter = meterCenterRadius (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ mw = meterWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ in+ meter w h rW rH meterCenter (x * (meterLength - sw - (mw / 2))) ((-y) * (meterLength - sw - (mw / 2))) mw++makeFill :: Size -> PreciseAngle -> PreciseAngle -> String -> String+makeFill (Size (Width w) (Height h)) a1@(PreciseAngle a1') a2@(PreciseAngle a2') colorString =+ let ((rW,rH) :: (Double,Double)) = center w h+ PrecisePosition (PreciseX a1X) (PreciseY a1Y) = angleToCoordinate (fromFltkAngle a1)+ PrecisePosition (PreciseX a2X) (PreciseY a2Y) = angleToCoordinate (fromFltkAngle a2)+ sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ in+ fillEllipse w h rW rH (a1X * (rW-sw)) ((-a1Y) * (rH-sw)) (rW-sw) (rH-sw) (if (abs (a2'-a1') < 180) then (0 :: Int) else (1 :: Int)) (a2X * (rW-sw)) ((-a2Y) * (rH-sw)) colorString++makeArrow :: Size -> PreciseAngle -> String+makeArrow (Size (Width w) (Height h)) a =+ let ((rW,rH) :: (Double,Double)) = center w h+ sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ circleR = if (rW<rH) then rW else rH+ PreciseAngle a' = fromFltkAngle a+ arrH = arrowHeight (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ arrB = arrowBase (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ arrP = arrowPadding (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ knobP = knobPadding (PreciseSize (PreciseWidth rW) (PreciseHeight rH))+ in+ printf (intercalate "\n" arrow)+ w h (-rW) (-rH) w h (-a')+ (0.0 :: Double) (0.0 :: Double) (circleR-sw-knobP) (1.0 :: Double)+ (rW-sw-knobP-arrP) (0.0 :: Double)+ (circleR-sw-arrH-knobP-arrP) (arrH/2)+ (circleR-sw-arrH-knobP-arrP) (-(arrB/2))++wrapSvgs svgs =+ concat (intersperse "\n" (["<svg>"] ++ svgs ++ ["</svg>"]))++-- | Custom dial drawing function+drawDial :: Ref LowLevel.Dial -> IO ()+drawDial d = do+ bounds@(Rectangle dialPos@(Position (X dialX) (Y dialY)) dialSize@(Size (Width dialW) (Height dialH))) <- LowLevel.getRectangle d+ p <- LowLevel.getParent d+ color <- maybe (return lightBackground) LowLevel.getColor p+ drawBorderBox d+ (BorderBoxSpec+ {+ borderBoxBounds = bounds+ , borderBoxFocusedColor = color+ , borderBoxHoveringColor = color+ , borderBoxColor = color+ , borderBoxFillColor = color+ })+ True+ color <- fmap (\c -> colorAverage c blackColor 0.80) (LowLevel.getColor d)+ (colorR,colorG,colorB) <- FL.getColorRgb color+ (Angle a1) <- LowLevel.getAngle1 d+ (Angle a2) <- LowLevel.getAngle2 d+ let dialOutlineSvg = makeDialOutline dialSize (PreciseAngle (fromIntegral a1)) (PreciseAngle (fromIntegral a2)) ("rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")")+ dialMin <- LowLevel.getMinimum d+ dialMax <- LowLevel.getMaximum d+ when (dialMin>dialMax) (throwIO (userError ("Dial minimum cannot be less than maximum:(" ++ (show dialMin) ++ "," ++ (show dialMax) ++ ")")))+ dialV <- LowLevel.getValue d >>= LowLevel.clamp d+ dialType <- LowLevel.getType_ d+ let dialLocation = (dialV-dialMin) / (dialMax-dialMin)+ let meterAngle = PreciseAngle (((fromIntegral (a2-a1)) * dialLocation) + (fromIntegral a1))+ (selectionColorR, selectionColorG, selectionColorB) <- LowLevel.getSelectionColor d >>= FL.getColorRgb+ let svg =+ case dialType of+ LowLevel.FillDialType ->+ wrapSvgs+ [+ dialOutlineSvg+ , if (a1<a2)+ then makeFill dialSize+ (PreciseAngle (fromIntegral a1))+ meterAngle+ ("rgb(" ++ show selectionColorR ++ "," ++ show selectionColorG ++ "," ++ show selectionColorB ++ ")")+ else makeFill dialSize+ meterAngle+ (PreciseAngle (fromIntegral a1))+ ("rgb(" ++ show selectionColorR ++ "," ++ show selectionColorG ++ "," ++ show selectionColorB ++ ")")+ , makeMeter meterAngle dialSize+ ]+ LowLevel.LineDialType ->+ wrapSvgs+ [+ dialOutlineSvg+ , makeMeter meterAngle dialSize+ ]+ LowLevel.NormalDialType ->+ wrapSvgs+ [+ dialOutlineSvg+ , makeArrow dialSize meterAngle+ ]+ iE <- LowLevel.svgImageNew (BC.pack svg)+ case iE of+ Left _ -> throwIO (userError ("drawDial: the generated SVG is invalid: \n" ++ svg))+ Right i -> do+ LowLevel.draw i dialPos+ LowLevel.destroy i+ LowLevel.drawLabel d Nothing++dialNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Dial)+dialNew rectangle label = do+ d <- LowLevel.dialCustom+ rectangle+ label+ (Just drawDial)+ Nothing+ color <- commonColor+ LowLevel.setColor d color+ color <- commonFillColor+ LowLevel.setSelectionColor d color+ LowLevel.setLabelfont d commonFont+ LowLevel.setLabelsize d commonFontSize+ return d++fillDialNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FillDial)+fillDialNew rect l = do+ d <- dialNew rect l+ LowLevel.setType d LowLevel.FillDialType+ return (castTo d)++lineDialNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.LineDial)+lineDialNew rect l = do+ d <- dialNew rect l+ LowLevel.setType d LowLevel.LineDialType+ return (castTo d)
+ src/Graphics/UI/FLTK/Theme/Light/Group.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Group+ (+ groupNew,+ scrolledNew+ )+where+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++scrolledNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Scrolled)+scrolledNew rectangle label = do+ s <- LowLevel.scrolledNew rectangle label+ p <- LowLevel.getParent s+ color <- maybe (return lightBackground) LowLevel.getColor p+ LowLevel.setColor s color+ LowLevel.setLabelfont s commonFont+ LowLevel.setLabelsize s commonFontSize+ return s++groupNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Group)+groupNew rectangle label = do+ g <- LowLevel.groupNew rectangle label+ p <- LowLevel.getParent g+ color <- maybe (return lightBackground) LowLevel.getColor p+ LowLevel.setColor g color+ LowLevel.setLabelfont g commonFont+ LowLevel.setLabelsize g commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor g color+ return g
+ src/Graphics/UI/FLTK/Theme/Light/Input.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Input+ (+ fileInputNew,+ inputBox,+ inputNew,+ outputNew,+ inputSetup,+ inputDraw+ )+where+import Control.Monad+import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++inputBox :: Bool -> Rectangle -> Color -> IO ()+inputBox focused r c =+ if focused+ then do+ color <- commonFillColor+ LowLevel.flcRectWithColor r color+ else+ let slightlyDarker = colorAverage c blackColor 0.75+ (x',y',w',_) = fromRectangle r+ in do+ LowLevel.flcRectWithColor r slightlyDarker+ LowLevel.flcSetColor blackColor+ LowLevel.flcBeginLine+ LowLevel.flcVertex (toPrecisePosition (toPosition (x',y')))+ LowLevel.flcVertex (toPrecisePosition (toPosition (x'+w'-1,y')))+ LowLevel.flcEndLine++inputDraw :: Ref LowLevel.Input -> IO ()+inputDraw i =+ withCustomBoxDraw+ BorderBox+ (\rect color -> do+ LowLevel.flcRectfWithColor rect color+ focused <- isWidget i FL.focus+ inputBox focused rect color)+ (do+ t <- LowLevel.getInputType i+ r <- LowLevel.getRectangle i+ rBox <- FL.adjustBoundsByBoxtype r BorderBox+ case t of+ LowLevel.FlHiddenInput -> return ()+ _ -> do+ ds <- LowLevel.getDamage i+ if (DamageAll `elem` ds)+ then do+ color <- LowLevel.getColor i+ LowLevel.drawBoxWithBoxtype i BorderBox color Nothing+ else+ when (DamageExpose `elem` ds)+ (do+ focused <- isWidget i FL.focus+ color <- LowLevel.getColor i+ inputBox focused rBox color)+ LowLevel.drawText i rBox)++-- | Common setup function for all 'Input' widgets, sets label color, font etc.+inputSetup :: (?assets :: Assets) => Ref LowLevel.Input -> IO ()+inputSetup i = do+ LowLevel.setColor i lightBackground+ LowLevel.setBox i BorderBox+ LowLevel.setTextfont i commonFont+ LowLevel.setTextsize i commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor i color+ LowLevel.setLabelfont i commonFont+ LowLevel.setLabelsize i commonFontSize++inputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> Maybe LowLevel.FlInputType -> IO (Ref LowLevel.Input)+inputNew rect l it = do+ i <- LowLevel.inputCustom rect l it (Just inputDraw) Nothing+ inputSetup i+ return i++fileInputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FileInput)+fileInputNew rect l = do+ i <- LowLevel.fileInputNew rect l+ inputSetup (safeCast i)+ return i++outputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> Maybe LowLevel.FlOutputType -> IO (Ref LowLevel.Output)+outputNew rect l t = do+ o <- LowLevel.outputCustom rect l+ (Just (inputDraw . safeCast))+ Nothing+ inputSetup (safeCast o)+ maybe (return ()) (\t -> LowLevel.setType o t) t+ return o
+ src/Graphics/UI/FLTK/Theme/Light/Menu.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Menu+ (+ choiceNew,+ sysMenuBarNew+ )+where+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++sysMenuBarNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.SysMenuBar)+sysMenuBarNew rectangle label = do+ let customDraw :: Ref LowLevel.SysMenuBar -> IO ()+ customDraw m = do+ (color :: Color) <- LowLevel.getColor m+ let slightlyDarker = colorAverage color blackColor 0.80+ items <- LowLevel.getMenu m+ mapM_+ (\miMaybe ->+ maybe+ (return ())+ (\mi -> do+ LowLevel.setLabelfont mi commonFont+ LowLevel.setLabelsize mi commonFontSize)+ miMaybe)+ items+ withCustomBoxDraw+ BorderBox+ (\rect _ -> do+ let (x',y',w',h') = fromRectangle rect+ LowLevel.flcSetColor slightlyDarker+ LowLevel.flcBeginLine+ LowLevel.flcVertex (toPrecisePosition (toPosition (x',y'+h')))+ LowLevel.flcVertex (toPrecisePosition (toPosition (x'+w',y'+h')))+ LowLevel.flcEndLine+ LowLevel.flcSetColor color+ )+ (LowLevel.drawSuper m)+ m <- LowLevel.sysMenuBarCustom+ rectangle+ label+ (Just customDraw)+ Nothing+ LowLevel.setBox m BorderBox+ LowLevel.setColor m lightBackground+ LowLevel.setTextfont m commonFont+ LowLevel.setTextsize m commonFontSize+ return m++choiceNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Choice)+choiceNew rectangle label = do+ c <- LowLevel.choiceCustom+ rectangle+ label+ (Just drawChoice)+ Nothing+ let color = lightBackground+ LowLevel.setLabelfont c commonFont+ LowLevel.setLabelsize c commonFontSize+ LowLevel.setTextfont c commonFont+ LowLevel.setTextsize c commonFontSize+ LowLevel.setColor c color+ color <- commonSelectionColor+ LowLevel.setSelectionColor c color+ return c++drawChoice :: Ref LowLevel.Choice -> IO ()+drawChoice c = do+ color <- LowLevel.getColor c+ selectionColor <- fmap darker (LowLevel.getSelectionColor c)+ bounds' <- LowLevel.getRectangle c+ let (x,y,w,h) = fromRectangle bounds'+ let slightlyDarker = colorAverage color blackColor 0.85+ hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB)+ let spec =+ BorderBoxSpec+ {+ borderBoxHoveringColor = hoverColor,+ borderBoxColor = slightlyDarker,+ borderBoxFocusedColor = selectionColor,+ borderBoxFillColor = color,+ borderBoxBounds = toRectangle (x,y,w-1,h-1)+ }+ withCustomBoxDraw UpBox (\_ _ -> drawBorderBox c spec True) (LowLevel.drawSuper c)
+ src/Graphics/UI/FLTK/Theme/Light/Misc.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE ImplicitParams #-}+module Graphics.UI.FLTK.Theme.Light.Misc+ (+ header+ , darkHeader+ )+where+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import qualified Data.Text as T+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.Theme.Light.Common+import Graphics.UI.FLTK.Theme.Light.Assets++drawBackground :: (?assets :: Assets) => Color -> FillSpec -> Alignments -> LowLevel.Ref LowLevel.Box -> IO ()+drawBackground c spec alignments b = do+ r <- LowLevel.getRectangle b+ fillRectangle (spec { fillBounds = r }) False+ LowLevel.drawLabel b (Just (r,alignments))++-- | This widget was intended for use as a app header bar, similar to the one provided by+-- [GTK3](https://developer.gnome.org/gtk3/stable/GtkHeaderBar.html) but really+-- it's just a "Graphics.UI.FLTK.LowLevel.Box" labeled with 'T.Text' and with a background vertically graded+-- with the 'Color' provided. You can use it for anything you like. For a more "turn-key" app+-- header that works nicely with the Light theme you probably want 'darkHeader'.+header :: (?assets :: Assets) => Color -> Rectangle -> T.Text -> Alignments -> IO (LowLevel.Ref LowLevel.Box)+header c r l alignments =+ let fillSpec =+ FillSpec+ {+ fillBounds = r+ , fillTopColor = c+ , fillTopSelectionColor = c+ , fillTopFillPercentage = 10+ , fillBottomColor = darker c+ , fillBottomSelectionColor = c+ , fillBottomFillPercentage = 90+ , fillCornerRadius = 0+ , fillBorderColor = c+ , fillBorderFocusColor = c+ , fillBorderHovered = c+ }+ in do+ b <- LowLevel.boxCustom r (Just l) (Just (drawBackground c fillSpec alignments)) Nothing+ LowLevel.setLabel b l+ return b++-- | Same as 'header' except it doesn't take a 'Color' and uses the 'commonDarkGreyColor' and the+-- a large 'josefinSlabSemiBold' font for the label.+darkHeader :: (?assets :: Assets) => Rectangle -> T.Text -> Alignments -> IO (LowLevel.Ref LowLevel.Box)+darkHeader r l alignments = do+ c <- commonDarkGreyColor+ b <- header c r l alignments+ LowLevel.setLabelfont b josefinSlabSemiBold+ LowLevel.setLabelsize b commonLargeFontSize+ LowLevel.setLabelcolor b whiteColor+ return b
+ src/Graphics/UI/FLTK/Theme/Light/Positioner.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ImplicitParams, ScopedTypeVariables #-}+module Graphics.UI.FLTK.Theme.Light.Positioner+ (+ positionerNew+ )+where+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.Theme.Light.Assets++positionerNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.Positioner)+positionerNew rect l = do+ let customDraw :: LowLevel.Ref LowLevel.Positioner -> IO ()+ customDraw p = do+ (color :: Color) <- LowLevel.getColor p+ let slightlyDarker = colorAverage color blackColor 0.85+ withCustomBoxDraw+ BorderBox+ (\rect _ -> do+ LowLevel.flcRectfWithColor rect color+ LowLevel.flcRectWithColor rect slightlyDarker)+ (LowLevel.drawSuper p)+ p <- LowLevel.positionerCustom rect l (Just customDraw) Nothing+ LowLevel.setLabelfont p commonFont+ LowLevel.setLabelsize p commonFontSize+ LowLevel.setColor p lightBackground+ LowLevel.setBox p BorderBox+ LowLevel.setSelectionColor p redColor+ return p
+ src/Graphics/UI/FLTK/Theme/Light/Progress.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings #-}+module Graphics.UI.FLTK.Theme.Light.Progress+ (+ progressNew,+ drawProgress+ )+where+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++-- | Custom progress bar drawing function+drawProgress :: Ref LowLevel.Progress -> IO ()+drawProgress p = do+ rect <- LowLevel.getRectangle p+ progressMin <- LowLevel.getMinimum p+ progressMax <- LowLevel.getMaximum p+ v <- LowLevel.getValue p+ color <- LowLevel.getColor p+ let (x,y,w,h) = fromRectangle rect+ slightlyDarker = colorAverage color blackColor 0.85+ progressW = (truncate ((fromIntegral w) * (v/(progressMax-progressMin))))+ selectionColor <- LowLevel.getSelectionColor p+ let fillColor = darker selectionColor+ hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB)+ let spec =+ BorderBoxSpec+ {+ borderBoxHoveringColor = hoverColor,+ borderBoxColor = slightlyDarker,+ borderBoxFocusedColor = fillColor,+ borderBoxFillColor = color,+ borderBoxBounds = rect+ }+ drawBorderBox p spec True+ LowLevel.flcRectfWithColor (toRectangle (x+1,y+1,progressW,h-2)) selectionColor++progressNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Progress)+progressNew rect l = do+ p <- LowLevel.progressCustom rect l+ (Just drawProgress)+ Nothing+ LowLevel.setColor p lightBackground+ LowLevel.setBox p BorderBox+ LowLevel.setLabelfont p commonFont+ LowLevel.setLabelsize p commonFontSize+ color <- commonFillColor+ LowLevel.setSelectionColor p color+ return p
+ src/Graphics/UI/FLTK/Theme/Light/SimpleTerminal.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings #-}+module Graphics.UI.FLTK.Theme.Light.SimpleTerminal+ (+ simpleTerminalNew+ )+where+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import qualified Data.Text as T+import Graphics.UI.FLTK.Theme.Light.Assets++simpleTerminalNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.SimpleTerminal)+simpleTerminalNew r l = do+ t <- LowLevel.simpleTerminalNew r l+ LowLevel.setColor t lightBackground+ LowLevel.setTextfont t commonFont+ LowLevel.setTextsize t commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor t color+ LowLevel.setLabelfont t commonFont+ LowLevel.setLabelsize t commonFontSize+ return t
+ src/Graphics/UI/FLTK/Theme/Light/Slider.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Slider+ (+ sliderNew,+ fillSliderNew,+ valueSliderNew,+ gaugeSliderNew,+ horFillSliderNew,+ horNiceSliderNew,+ horSliderNew,+ horValueSliderNew,+ -- * Slider drawing helpers+ --+ --+ GaugeSliderSpec(..),+ defaultGaugeHeight,+ drawSlider,+ drawValueSlider,+ gaugeBoxBounds,+ sliderIsHorizontal,+ mkGaugeSliderSpec,+ sliderKnobColor,+ sliderSetup+ )+where+import Control.Exception+import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import Text.Printf+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import qualified Graphics.UI.FLTK.LowLevel.Hierarchy as Hierarchy+import qualified Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.Theme.Light.Assets++sliderKnobColor :: IO Color+sliderKnobColor = rgbColorWithRgb (241,241,241)++sliderIsHorizontal :: SliderType -> Bool+sliderIsHorizontal VertSliderType = False+sliderIsHorizontal HorSliderType = True+sliderIsHorizontal VertFillSliderType = False+sliderIsHorizontal HorFillSliderType = True+sliderIsHorizontal VertNiceSliderType = False+sliderIsHorizontal HorNiceSliderType = True++sliderSetup ::+ (?assets :: Assets) => Ref LowLevel.Slider -> IO ()+sliderSetup s = do+ () <- LowLevel.setColor s lightBackground+ () <- LowLevel.setBox s BorderBox+ () <- LowLevel.setSlider s UpBox+ () <- LowLevel.setSliderSize s 0.15+ () <- LowLevel.setLabelfont s commonFont+ () <- LowLevel.setLabelsize s commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor s color++data GaugeSliderSpec =+ GaugeSliderSpec+ {+ gaugeHeight :: Int+ , gaugeWidth :: Double+ , gaugeOverhang :: Double+ }++defaultGaugeHeight :: Int+defaultGaugeHeight = 10++mkGaugeSliderSpec =+ GaugeSliderSpec+ {+ gaugeHeight = defaultGaugeHeight+ , gaugeWidth = 0.20+ , gaugeOverhang = (fromIntegral defaultGaugeHeight)/2+ }++drawValueSlider :: Ref LowLevel.ValueSlider -> IO ()+drawValueSlider vs = do+ color <- LowLevel.getColor vs+ selectionColor <- fmap darker (LowLevel.getSelectionColor vs)+ let slightlyDarker = Graphics.UI.FLTK.LowLevel.Fl_Enumerations.colorAverage color blackColor 0.85+ hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB)+ (x,y,w,h) <- fmap fromRectangle (LowLevel.getRectangle vs)+ sliderType <- LowLevel.getType_ vs+ let spec =+ BorderBoxSpec+ {+ borderBoxHoveringColor = hoverColor,+ borderBoxColor = slightlyDarker,+ borderBoxFocusedColor = selectionColor,+ borderBoxFillColor = color,+ borderBoxBounds =+ toRectangle+ (if (sliderIsHorizontal sliderType)+ then (x,y,valueBoxWidth-1,h-1)+ else (x,y,w-1, valueBoxHeight-1)+ )+ }+ drawBorderBox vs spec True+ valueFont <- LowLevel.getTextfont vs+ valueFontsize <- LowLevel.getTextsize vs+ valueFontcolor <- LowLevel.getTextcolor vs+ LowLevel.flcSetFont valueFont valueFontsize+ isActive <- LowLevel.activeR vs+ LowLevel.flcSetColor (if isActive then valueFontcolor else (inactive valueFontcolor))+ currentValue <- LowLevel.format vs+ case currentValue of+ Left _ -> return ()+ Right text -> LowLevel.flcDrawInBox text (borderBoxBounds spec) (Alignments [AlignTypeClip]) Nothing Nothing+ drawSlider+ (castTo vs)+ Nothing+ (toRectangle+ (if (sliderIsHorizontal sliderType)+ then (x+valueBoxWidth,y,w-valueBoxWidth,h)+ else (x,y+valueBoxHeight,w,h-valueBoxHeight)+ )+ )+ where+ valueBoxWidth = 35+ valueBoxHeight = 25++gaugeBoxBounds :: Bool -> GaugeSliderSpec -> Rectangle -> Rectangle+gaugeBoxBounds horizontal spec rect =+ let (x,y,w,h) = fromRectangle rect+ horizontalBounds =+ (+ x+(truncate (gaugeOverhang spec))+ , y+(truncate ((gaugeWidth spec)*(fromIntegral h)))+ , w-(2*(truncate (gaugeOverhang spec)))+ , h-(2*(truncate ((gaugeWidth spec)*(fromIntegral h))))+ )+ verticalBounds =+ (+ x+(truncate ((gaugeWidth spec)*(fromIntegral w)))+ , y+(truncate (gaugeOverhang spec))+ , w-(2*(truncate ((gaugeWidth spec)*(fromIntegral w))))+ , h-(2*(truncate (gaugeOverhang spec)))+ )+ in toRectangle (if horizontal then horizontalBounds else verticalBounds)++drawSlider :: Ref LowLevel.Slider -> Maybe GaugeSliderSpec -> Rectangle -> IO ()+drawSlider s gaugeSpec rect = do+ color <- LowLevel.getColor s+ selectionColor <- fmap darker (LowLevel.getSelectionColor s)+ let (x,y,w,h) = fromRectangle rect+ slightlyDarker = colorAverage color blackColor 0.85+ hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB)+ t <- LowLevel.getType_ s+ let spec =+ BorderBoxSpec+ {+ borderBoxHoveringColor = hoverColor,+ borderBoxColor = slightlyDarker,+ borderBoxFocusedColor = selectionColor,+ borderBoxFillColor = color,+ borderBoxBounds =+ case gaugeSpec of+ Nothing -> toRectangle (x,y,w-1,h-1)+ Just spec -> gaugeBoxBounds (sliderIsHorizontal t) spec rect+ }+ (xDiff,yDiff,wDiff,hDiff) = FL.boxDifferences rect (borderBoxBounds spec)+ drawBorderBox s spec (maybe True (\_ -> False) gaugeSpec)+ LowLevel.drawLabel s Nothing+ min' <- LowLevel.getMinimum s+ max' <- LowLevel.getMaximum s+ value' <- fmap (sliderValue min' max') (LowLevel.getValue s)+ oldColor <- LowLevel.flcColor+ case gaugeSpec of+ Nothing -> drawPill rect value' (sliderIsHorizontal t)+ Just gaugeSpec ->+ let (xDiff,yDiff,wDiff,hDiff) = FL.boxDifferences rect (borderBoxBounds spec)+ (xPad,yPad) = (xDiff `intDiv` 2, yDiff `intDiv` 2)+ in do+ LowLevel.flcRectfWithColor (toRectangle (x,y,w,yDiff)) color+ LowLevel.flcRectfWithColor (toRectangle (x,y+yDiff,xDiff,h-(yDiff*2))) color+ LowLevel.flcRectfWithColor (toRectangle (x+w-xDiff,y+yDiff,xDiff,h-(yDiff*2))) color+ LowLevel.flcRectfWithColor (toRectangle (x,y+h-yDiff,w,yDiff)) color+ triangleColor <- FL.getColorRgb (colorAverage slightlyDarker blackColor 0.85)+ drawGauge (borderBoxBounds spec) triangleColor rect value' (sliderIsHorizontal t) gaugeSpec+ where+ gaugeSvg (borderR,borderG,borderB) bounds innerBounds v horizontal spec =+ let (x',y',w',h') = fromRectangle bounds+ (_,_,innerW,innerH) = fromRectangle innerBounds+ (doubleX,doubleY,doubleW,doubleH) = (fromIntegral x',fromIntegral y',fromIntegral w',fromIntegral h')+ svg =+ "<svg width=\"%d\" height=\"%d\" transform=\"translate(%f,%f)\">\n"+ ++ "<g>\n"+ ++ "<path d=\" M%d %d L %d %d L %d %d L %d %d\" stroke=\"%s\" stroke-width=\"%s\" fill=\"none\">\n"+ ++ "<path d=\" M%d %d L %d %d L %d %d L %d %d\" stroke=\"%s\" stroke-width=\"%s\" fill=\"none\">\n"+ ++ "<path d=\" M%d %d L %d %d\" stroke=\"black\" stroke-width=\"%s\" fill=\"none\">\n"+ ++ "<path d=\" M%d %d L %d %d\" stroke=\"black\" stroke-width=\"%s\" fill=\"none\">\n"+ ++ "</g>\n"+ ++ "</svg>"+ xTranslation = (fromIntegral innerW) * v+ yTranslation = (fromIntegral innerH) * v+ in+ if horizontal+ then+ printf svg+ w' h' xTranslation (0 :: Double)+ (0 :: Int) (0 :: Int)+ (gaugeHeight spec) (0 :: Int)+ (((gaugeHeight spec) `intDiv` 2) :: Int) ((truncate ((gaugeWidth spec)*(fromIntegral h'))) :: Int)+ (0 :: Int) (0 :: Int)+ ("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String)+ (0 :: Int) h'+ (gaugeHeight spec) h'+ (((gaugeHeight spec) `intDiv` 2) :: Int) (h'-(truncate ((gaugeWidth spec)*(fromIntegral h'))))+ (0 :: Int) h'+ ("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String)+ (0 :: Int) (0 :: Int)+ (gaugeHeight spec) (0 :: Int)+ ("1px" :: String)+ (0 :: Int) h'+ (gaugeHeight spec) h'+ ("1px" :: String)+ else+ printf svg+ w' h' (0 :: Double) yTranslation+ (0 :: Int) (0 :: Int)+ (0 :: Int) (gaugeHeight spec)+ ((truncate ((gaugeWidth spec)*(fromIntegral w'))) :: Int) (((gaugeHeight spec) `intDiv` 2) :: Int)+ (0 :: Int) (0 :: Int)+ ("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String)+ w' (0 :: Int)+ w' (gaugeHeight spec)+ (w'-(truncate ((gaugeWidth spec)*(fromIntegral w')))) (((gaugeHeight spec) `intDiv` 2) :: Int)+ w' (0 :: Int)+ ("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String)+ (0 :: Int) (0 :: Int)+ (0 :: Int) (gaugeHeight spec)+ ("1px" :: String)+ w' (0 :: Int)+ w' (gaugeHeight spec)+ ("1px" :: String)+ drawGauge innerBounds borderRgb bounds v horizontal spec =+ let svg = gaugeSvg borderRgb bounds innerBounds v horizontal spec+ (x,y,_,_) = fromRectangle bounds+ in do+ iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg)+ case iE of+ Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg))+ Right i -> do+ LowLevel.draw i (toPosition (x,y))+ LowLevel.destroy i+ pillCornerRadius :: Int+ pillCornerRadius = 2+ pillLength :: Double+ pillLength = 20.0+ pillCenter :: Double+ pillCenter = pillLength / 2.0+ pillPadding :: Int+ pillPadding = 3+ pillEndPadding :: Int+ pillEndPadding = 2+ sliderValue :: Double -> Double -> Double -> Double+ sliderValue min' max' curr' =+ if (min' == max') then 0.5+ else+ case (curr' - min') / (max' - min') of+ val | val > 1.0 -> 1.0+ | val < 0.0 -> 0.0+ | otherwise -> val+ pillRectangle :: Bool -> Double -> Rectangle -> Rectangle+ pillRectangle horizontal value' (Rectangle (Position (X x') (Y y')) (Size (Width w') (Height h'))) =+ if horizontal+ then+ Rectangle+ (Position+ (X (truncate (fromIntegral x' + (fromIntegral w' - pillLength) * value')))+ (Y (y'+ pillPadding)))+ (Size+ (Width (truncate pillLength))+ (Height (h' - (pillPadding * 2) - 1)))+ else+ Rectangle+ (Position+ (X (x'+ pillPadding))+ (Y (truncate (fromIntegral y' + ((fromIntegral h' - pillLength) * value')))))+ (Size+ (Width (w' - pillPadding*2 - 1))+ (Height (truncate pillLength)))+ drawPill rect v horizontal =+ let (x,y,w,h) = fromRectangle rect+ pill = pillRectangle+ horizontal+ v+ (toRectangle+ (if horizontal+ then (x+pillEndPadding,y,w-2*pillEndPadding,h)+ else (x,y+pillEndPadding,w,h-2*pillEndPadding)+ )+ )+ in do+ borderColor <- rgbColorWithRgb (0x93,0x93,0x93)+ color <- sliderKnobColor+ let pillVertices = mapM_ (LowLevel.flcVertex . toPrecisePosition) (roundedBoxPoints pill (Just pillCornerRadius) Nothing)+ LowLevel.flcSetColor color+ LowLevel.flcBeginPolygon+ pillVertices+ LowLevel.flcEndPolygon+ LowLevel.flcSetColor borderColor+ LowLevel.flcBeginLine+ pillVertices+ LowLevel.flcEndLine++{-# DEPRECATED fillSliderNew "Fill sliders are not supported in the Light theme. 'fillSliderNew' is the same as 'sliderNew'." #-}+{-# DEPRECATED horFillSliderNew "Fill sliders are not supported in the Light theme. 'horFillSliderNew' is the same as 'sliderNew'." #-}+{-# DEPRECATED horNiceSliderNew "\"Nice\"sliders are not supported in the Light theme. 'horNiceSliderNew' is the same as 'sliderNew'." #-}+++sliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Slider)+sliderNew rectangle label = do+ s <- LowLevel.sliderCustom+ rectangle+ label+ (Just (\s -> do+ bounds <- LowLevel.getRectangle s+ drawSlider s Nothing bounds+ ))+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))+ sliderSetup s+ return s++gaugeSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Slider)+gaugeSliderNew rectangle label = do+ s <- LowLevel.sliderCustom+ rectangle+ label+ (Just (\s -> do+ bounds <- LowLevel.getRectangle s+ drawSlider s (Just mkGaugeSliderSpec) bounds+ ))+ (Just (LowLevel.defaultCustomWidgetFuncs {LowLevel.handleCustom = Just handleHover}))+ sliderSetup (safeCast s)+ return s++valueSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ValueSlider)+valueSliderNew rectangle label = do+ s <- LowLevel.valueSliderCustom+ rectangle+ label+ (Just drawValueSlider)+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))+ sliderSetup (safeCast s)+ return s++horValueSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorValueSlider)+horValueSliderNew rectangle label = do+ s <- LowLevel.valueSliderCustom+ rectangle+ label+ (Just drawValueSlider)+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))+ LowLevel.setType s HorSliderType+ sliderSetup (safeCast s)+ return (LowLevel.castTo s)++horSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorSlider)+horSliderNew rectangle label = do+ s <- LowLevel.sliderCustom+ rectangle+ label+ (Just (\s -> do+ bounds <- LowLevel.getRectangle s+ drawSlider s Nothing bounds+ ))+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))+ LowLevel.setType s HorSliderType+ sliderSetup (safeCast s)+ return (LowLevel.castTo s)++fillSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FillSlider)+fillSliderNew rectangle label = do+ s <- LowLevel.sliderCustom+ rectangle+ label+ (Just (\s -> do+ bounds <- LowLevel.getRectangle s+ drawSlider s Nothing bounds+ ))+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))+ LowLevel.setType s VertFillSliderType+ sliderSetup (safeCast s)+ return (LowLevel.castTo s)++horFillSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorFillSlider)+horFillSliderNew rectangle label = do+ s <- LowLevel.sliderCustom+ rectangle+ label+ (Just (\s -> do+ bounds <- LowLevel.getRectangle s+ drawSlider s Nothing bounds+ ))+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))+ sliderSetup (safeCast s)+ LowLevel.setType s HorFillSliderType+ return (LowLevel.castTo s)++horNiceSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorNiceSlider)+horNiceSliderNew rectangle label = do+ s <- LowLevel.sliderCustom+ rectangle+ label+ (Just (\s -> do+ bounds <- LowLevel.getRectangle s+ drawSlider s Nothing bounds+ ))+ (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))+ sliderSetup (safeCast s)+ LowLevel.setType s HorNiceSliderType+ return (LowLevel.castTo s)
+ src/Graphics/UI/FLTK/Theme/Light/Spinner.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE RecursiveDo, ImplicitParams, ScopedTypeVariables, OverloadedStrings #-}+module Graphics.UI.FLTK.Theme.Light.Spinner+ (+ spinnerNew,+ -- * Spinner drawing and handling helpers+ handleSpinner,+ resizeSpinner,+ spinnerComponentBounds,+ spinnerDownCallback,+ spinnerInputCallback,+ spinnerUpCallback+ )+where+import Control.Exception+import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Button+import Graphics.UI.FLTK.Theme.Light.Common+import Graphics.UI.FLTK.Theme.Light.Input+import qualified Data.Text as T+import qualified Data.Text.Read as T+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++doublePrecisionFormat :: T.Text+doublePrecisionFormat = T.pack "%.*"++spinnerComponentBounds :: Rectangle -> (Rectangle,Rectangle,Rectangle)+spinnerComponentBounds rect =+ let (x',y',w',h') = fromRectangle rect+ buttonH = h' `intDiv` 2+ inputW = w' - buttonH - 2+ buttonW = buttonH + 2+ in+ (+ toRectangle (x',y',inputW,h'),+ toRectangle (x'+inputW,y',buttonW,buttonH),+ toRectangle (x'+inputW,y'+ buttonH,buttonW,buttonH)+ )++handleSpinner :: Ref LowLevel.Input -> Ref LowLevel.Spinner -> Event -> IO (Either UnknownEvent ())+handleSpinner i s e =+ let upOrDown = do+ key <- FL.eventKey+ case key of+ SpecialKeyType Kb_Up -> spinnerUpCallback s i >> return (Right ())+ SpecialKeyType Kb_Down -> spinnerDownCallback s i >> return (Right ())+ _ -> return (Right ())+ in+ case e of+ Keydown -> upOrDown+ Shortcut -> upOrDown+ _ -> LowLevel.handleSuper (safeCast s :: Ref LowLevel.Group) e++updateInput :: Maybe T.Text -> Double -> Ref LowLevel.Input -> IO ()+updateInput format v i =+ let vString =+ case format of+ Just f -> if (doublePrecisionFormat `T.isPrefixOf` f) then show v else show (truncate v)+ Nothing -> show (truncate v)+ in LowLevel.setValue i (T.pack vString) >> return ()++resizeSpinner :: Ref LowLevel.Input -> Ref LowLevel.Button -> Ref LowLevel.Button -> Ref LowLevel.Spinner -> Rectangle -> IO ()+resizeSpinner i up down s r = do+ LowLevel.resizeSuper (safeCast s :: Ref LowLevel.Group) r+ let (iRect,upRect,downRect) = spinnerComponentBounds r+ LowLevel.resize i iRect+ LowLevel.resize up upRect+ LowLevel.resize down downRect++spinnerInputCallback :: Ref LowLevel.Spinner -> Ref LowLevel.Input -> IO ()+spinnerInputCallback s i = do+ vString <- LowLevel.getValue i+ (vs :: Double) <-+ case (T.decimal vString) of+ Left _ ->+ case (T.double vString) of+ Left _ -> throwIO+ (userError+ ("The contents of the spinner input must be an integer or floating point number: "++ (show (T.unpack vString))))+ Right (v,_) -> return v+ Right (v,_) -> return (fromIntegral v)+ min <- LowLevel.getMinimum s+ max <- LowLevel.getMaximum s+ f <- LowLevel.getFormat s+ let v =+ if (vs < min)+ then min+ else if (vs > max)+ then max+ else vs+ LowLevel.setValue s v+ updateInput f v i+ LowLevel.setChanged s+ LowLevel.doCallback s++spinnerUpCallback :: Ref LowLevel.Spinner -> Ref LowLevel.Input -> IO ()+spinnerUpCallback s i = do+ vi <- LowLevel.getValue s+ min <- LowLevel.getMinimum s+ max <- LowLevel.getMaximum s+ step <- LowLevel.getStep s+ wrap <- LowLevel.getWrap s+ f <- LowLevel.getFormat s+ let v =+ let tmp = vi + step+ in+ if (tmp > max)+ then if wrap then min else max+ else tmp+ LowLevel.setValue s v+ updateInput f v i+ LowLevel.setChanged s+ LowLevel.doCallback s++spinnerDownCallback :: Ref LowLevel.Spinner -> Ref LowLevel.Input -> IO ()+spinnerDownCallback s i = do+ vi <- LowLevel.getValue s+ min <- LowLevel.getMinimum s+ max <- LowLevel.getMaximum s+ step <- LowLevel.getStep s+ wrap <- LowLevel.getWrap s+ let v =+ let tmp = vi - step+ in+ if (tmp < min)+ then if wrap then max else min+ else tmp+ LowLevel.setValue s v+ f <- LowLevel.getFormat s+ updateInput f v i+ LowLevel.setChanged s+ LowLevel.doCallback s++spinnerNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Spinner)+spinnerNew rect l = mdo+ s <- LowLevel.spinnerCustom rect l Nothing+ (Just (LowLevel.defaultCustomWidgetFuncs+ {+ LowLevel.handleCustom = Just (handleSpinner i),+ LowLevel.resizeCustom = Just (resizeSpinner i upButton downButton)+ }))+ LowLevel.setColor s lightBackground+ LowLevel.setBox s BorderBox+ LowLevel.setTextfont s commonFont+ LowLevel.setTextsize s commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor s color+ LowLevel.setLabelfont s commonFont+ LowLevel.setLabelsize s commonFontSize+ cs <- LowLevel.getArray s+ mapM_ LowLevel.hide cs+ numChildren <- LowLevel.children s+ mapM_ (LowLevel.removeIndex s . AtIndex) [0 .. numChildren-1]+ let (inputRect,upRect,downRect) = spinnerComponentBounds rect+ LowLevel.begin s+ i <- inputNew inputRect Nothing Nothing+ LowLevel.setValue i "1"+ LowLevel.setInputType i LowLevel.FlIntInput+ LowLevel.setWhen i [WhenEnterKey, WhenRelease]+ LowLevel.setCallback i (spinnerInputCallback s)+ upButton <- LowLevel.buttonCustom+ upRect+ Nothing+ (Just (\b -> do+ spec <- buttonFillSpec b+ r <- LowLevel.getRectangle b+ s <- LowLevel.getDataSize upSmallImage+ drawRegularButton (spec { fillCornerRadius = 0 }) b+ LowLevel.draw upSmallImage (centerInRectangle r s)))+ Nothing+ buttonSetup upButton+ LowLevel.setCallback upButton (\_ -> spinnerUpCallback s i)+ downButton <- LowLevel.buttonCustom+ downRect+ Nothing+ (Just (\b -> do+ spec <- buttonFillSpec b+ r <- LowLevel.getRectangle b+ s <- LowLevel.getDataSize upSmallImage+ drawRegularButton (spec { fillCornerRadius = 0 }) b+ LowLevel.draw downSmallImage (centerInRectangle r s)))+ Nothing+ buttonSetup downButton+ LowLevel.setCallback downButton (\_ -> spinnerDownCallback s i)+ LowLevel.end s+ return s
+ src/Graphics/UI/FLTK/Theme/Light/Table.hs view
@@ -0,0 +1,131 @@+{-|+Module: Graphics.UI.FLTK.Theme.Light.Table++A word on the table widgets, the theme does provide overrides of+[Table](http://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-Table.html)+and+[TableRow](http://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-TableRow.html)+but they are pretty lowlevel widgets requiring you to supply column\/row\/cell drawing functions. The+functions below draw nicely themed cells and can be passed the Table/TableRow constructors.++The idea is they are used in the generic table drawing cell function at each drawing context,+something like:++@+...+table <- tableRowNew+ (Rectangle ...)+ (Just "My Table")+ Nothing+ drawCell+ defaultCustomWidgetFuncs+ defaultCustomTableFuncs+...++drawCell :: (?assets :: Assets) => Ref TableRow -> TableContext -> TableCoordinate -> Rectangle -> IO ()+drawCell t tcontext ... =+ case tcontext of+ ContextRowHeader -> do+ ...+ drawHeader ...+ ContextColHeader -> do+ ...+ drawHeader ...+ ContextCell -> do+ ...+ drawDataCell ...+ _ -> return ()+@+-}+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Table+ (+ drawDataCell,+ drawHeader,+ drawHeaderWithImage,+ tableCustom,+ tableRowNew+ )+where+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.Theme.Light.Assets++drawHeader :: (?assets :: Assets) => Color -> Alignments -> T.Text -> Rectangle -> IO ()+drawHeader c labelAlign l rect = do+ spec <- fmap (\s -> s { fillCornerRadius = 0 }) (makeFillSpec rect c c)+ fillRectangle spec False+ borderRectangle spec True False+ f <- LowLevel.flcFont+ s <- LowLevel.flcSize+ LowLevel.flcSetFont commonFont commonFontSize+ oldC <- LowLevel.flcColor+ LowLevel.flcSetColor blackColor+ LowLevel.flcDrawInBox l rect labelAlign Nothing Nothing+ LowLevel.flcSetColor oldC+ LowLevel.flcSetFont f s++drawHeaderWithImage :: (LowLevel.Parent a LowLevel.Image, ?assets :: Assets) => Color -> Alignments -> T.Text -> Ref a -> Rectangle -> IO ()+drawHeaderWithImage c labelAlign l i rect = do+ spec <- fmap (\s -> s { fillCornerRadius = 0 }) (makeFillSpec rect c c)+ fillRectangle spec False+ borderRectangle spec True False+ f <- LowLevel.flcFont+ s <- LowLevel.flcSize+ LowLevel.flcSetFont commonFont commonFontSize+ oldC <- LowLevel.flcColor+ LowLevel.flcSetColor blackColor+ LowLevel.flcDrawInBoxWithImageReference l rect labelAlign Nothing i Nothing+ LowLevel.flcSetColor oldC+ LowLevel.flcSetFont f s++-- | Custom cell drawing function+drawDataCell :: (?assets :: Assets) => Color -> Alignments -> T.Text -> Rectangle -> IO ()+drawDataCell c contentsAlign contents rect = do+ spec <- fmap (\s -> s { fillCornerRadius = 0 }) (makeFillSpec rect c c)+ LowLevel.flcRectfWithColor rect c+ f <- LowLevel.flcFont+ s <- LowLevel.flcSize+ oldC <- LowLevel.flcColor+ LowLevel.flcSetFont commonFont commonFontSize+ LowLevel.flcSetColor blackColor+ let (x,y,w,h) = fromRectangle rect+ LowLevel.flcDrawInBox contents (toRectangle (x+1,y+1,w-2,h-2)) contentsAlign Nothing Nothing+ LowLevel.flcRectWithColor rect (fillBorderColor spec)+ LowLevel.flcSetColor oldC+ LowLevel.flcSetFont f s++tableCustom :: Rectangle -- ^ Bounds of this table+ -> Maybe T.Text -- ^ Optional label+ -> Maybe (Ref LowLevel.Table -> IO ()) -- ^ Optional custom table drawing function+ -> (Ref LowLevel.Table -> TableContext -> LowLevel.TableCoordinate -> Rectangle -> IO ()) -- ^ Custom table cell drawing function+ -> LowLevel.CustomWidgetFuncs LowLevel.Table -- ^ Widget overrides+ -> LowLevel.CustomTableFuncs LowLevel.Table -- ^ Table overrides+ -> IO (Ref LowLevel.Table)+tableCustom rectangle label' draw'' drawCell' customWidgetFuncs' customTableFuncs' = do+ t <- LowLevel.tableCustom rectangle label' draw'' drawCell' customWidgetFuncs' customTableFuncs'+ c <- commonColor+ LowLevel.setColor t lightBackground+ LowLevel.setColHeaderColor t c+ LowLevel.setRowHeaderColor t c+ commonFillColor >>= LowLevel.setSelectionColor t+ return t++tableRowNew :: Rectangle -- ^ Bounds of this table+ -> Maybe T.Text -- ^ Optional label+ -> Maybe (Ref LowLevel.TableRow -> IO ()) -- ^ Optional custom table drawing function+ -> (Ref LowLevel.TableRow -> TableContext -> LowLevel.TableCoordinate -> Rectangle -> IO ()) -- ^ Custom table cell drawing function+ -> LowLevel.CustomWidgetFuncs LowLevel.TableRow -- ^ Widget overrides+ -> LowLevel.CustomTableFuncs LowLevel.TableRow -- ^ Table overrides+ -> IO (Ref LowLevel.TableRow)+tableRowNew rectangle label' draw'' drawCell' customWidgetFuncs' customTableFuncs' = do+ t <- LowLevel.tableRowNew rectangle label' draw'' drawCell' customWidgetFuncs' customTableFuncs'+ c <- commonColor+ LowLevel.setColor t lightBackground+ LowLevel.setColHeaderColor t c+ LowLevel.setRowHeaderColor t c+ commonFillColor >>= LowLevel.setSelectionColor t+ return t
+ src/Graphics/UI/FLTK/Theme/Light/Tabs.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Tabs+ (+ tabsNew,+ -- * Tab Helpers and Handlers+ TabSpec(..),+ drawTabs,+ lightTabClientAreaCustom,+ lightTabHandleCustom,+ lightTabHeightCustom,+ lightTabPositionsCustom,+ lightTabRedrawTabs,+ lightTabWhichCustom+ )+where+import Control.Monad+import Data.IORef+import Data.List+import Graphics.UI.FLTK.LowLevel.Dispatch (safeCast)+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++-- | Visual properties of tabs+data TabSpec =+ TabSpec+ {+ tabRadius :: Int, -- ^ The corner radius of each tab+ tabHorizontalPadding :: Int, -- ^ Left\/right padding between a tab edge and its label+ tabVerticalPadding :: Int, -- ^ Top\/bottom padding between a tab edge and its label+ tabInactiveBorderColor :: Color, -- ^ Color of tabs not currently in focus+ tabBorderColor :: Color, -- ^ Border color of active tab+ tabFillColor :: Color,+ tabViewOffset :: IORef Int, -- ^ Location of the left edge of a tab relative to left edge of the widget itself.+ tabPartiallyVisible :: Int+ }++-- | Custom tab drawing function+drawTabs :: TabSpec -> Ref LowLevel.Tabs -> IO ()+drawTabs spec t = do+ bounds <- LowLevel.getRectangle t+ (selectedMaybe, _,widths) <- lightTabPositionsCustom spec t+ when (not (null widths)) $ do+ (Height tabHeight) <- lightTabHeightCustom spec t+ offset <- readIORef (tabViewOffset spec)+ let Rectangle (Position (X tabsX) (Y tabsY)) (Size (Width tabsWidth) (Height tabsHeight)) = bounds+ (AtIndex tabSelectedIndex) = maybe (AtIndex 0) id selectedMaybe+ offsetWidths = map (\(X x,Width w) -> (X (x+offset), Width w)) widths+ (X tabSelectedX, Width tabSelectedWidth) = offsetWidths !! tabSelectedIndex+ oldShortcut <- LowLevel.flcDrawShortcut+ oldColor <- LowLevel.flcColor+ LowLevel.flcSetDrawShortcut (Just NormalDrawShortcut)+ cs <- LowLevel.getArray t+ damages <- LowLevel.getDamage t+ when (elem DamageAll damages || elem DamageScroll damages)+ (let (X leftMostX,_) = head offsetWidths+ rightMostX = let (X rightX, Width w) = last offsetWidths in rightX + w+ indexedWidths = zip (map AtIndex [0 ..]) offsetWidths+ tabBorder yOffset openBorder = do+ LowLevel.flcPushClip (Rectangle (Position (X tabsX) yOffset) (Size (Width tabsWidth) (Height tabsHeight)))+ LowLevel.flcBeginLine+ LowLevel.flcVertex (toPrecisePosition (Position (X leftMostX) yOffset))+ LowLevel.flcVertex (toPrecisePosition (Position (X tabSelectedX) yOffset))+ LowLevel.flcEndLine+ LowLevel.flcBeginLine+ LowLevel.flcVertex (toPrecisePosition (Position (X (tabSelectedX + tabSelectedWidth)) yOffset))+ let tabsEnd = if (tabsX + tabsWidth < rightMostX) then tabsX + tabsWidth else rightMostX+ LowLevel.flcVertex (toPrecisePosition (Position (X (tabsX+tabsWidth)) yOffset))+ LowLevel.flcEndLine+ LowLevel.flcPopClip+ let widgetBorder =+ case openBorder of+ OpenBorderTop ->+ Rectangle+ (Position (X tabsX) (Y (tabsY+tabHeight)))+ (Size (Width tabsWidth) (Height (tabsHeight-(abs tabHeight))))+ OpenBorderBottom ->+ Rectangle+ (Position (X tabsX) (Y tabsY))+ (Size (Width tabsWidth) (Height (tabsHeight-(abs tabHeight))))+ LowLevel.flcBeginLine+ mapM_ (LowLevel.flcVertex . toPrecisePosition) (roundedBoxPoints widgetBorder Nothing (Just openBorder))+ LowLevel.flcEndLine+ drawTab openBorder yOffset (AtIndex i, (X tabX,Width tabWidth)) = do+ let tabPosition = Position (X tabX) yOffset+ tabRectangle = Rectangle tabPosition (Size (Width tabWidth) (Height (abs tabHeight)))+ oldColor <- LowLevel.flcColor+ -- blank it out first+ drawBorderBox t+ (BorderBoxSpec+ {+ borderBoxBounds = tabRectangle,+ borderBoxFocusedColor = tabFillColor spec,+ borderBoxHoveringColor = tabFillColor spec,+ borderBoxColor = tabFillColor spec,+ borderBoxFillColor = tabFillColor spec+ })+ True+ if (i == tabSelectedIndex) then+ LowLevel.flcSetColor (tabBorderColor spec)+ else LowLevel.flcSetColor (tabInactiveBorderColor spec)+ LowLevel.flcBeginLine+ mapM_ (LowLevel.flcVertex . toPrecisePosition) (roundedBoxPoints tabRectangle (Just (tabRadius spec)) (Just openBorder))+ LowLevel.flcEndLine+ let widget = cs !! i+ oldLabeltype <- LowLevel.getLabeltype widget+ case oldLabeltype of { NoLabelType -> LowLevel.setLabeltype widget NormalLabelType ResolveImageLabelDoNothing; _ -> return () }+ tabAlign <- LowLevel.getTabAlign t+ LowLevel.drawLabel widget (Just (tabRectangle, Alignments [tabAlign]))+ LowLevel.setLabeltype widget oldLabeltype ResolveImageLabelDoNothing+ LowLevel.flcSetColor oldColor+ in+ if (tabHeight < 0)+ then do+ oldColor <- LowLevel.flcColor+ let yOffset = tabsY + tabsHeight - (abs tabHeight)+ LowLevel.flcPushClip (toRectangle (tabsX,yOffset,tabsWidth,abs tabHeight))+ mapM_ (drawTab OpenBorderTop (Y yOffset)) indexedWidths+ LowLevel.flcPopClip+ LowLevel.flcSetColor (tabBorderColor spec)+ tabBorder (Y yOffset) OpenBorderBottom+ LowLevel.flcSetColor oldColor+ else do+ oldColor <- LowLevel.flcColor+ LowLevel.flcPushClip (toRectangle (tabsX,tabsY,tabsWidth,tabHeight))+ mapM_ (drawTab OpenBorderBottom (Y tabsY)) indexedWidths+ LowLevel.flcPopClip+ LowLevel.flcSetColor (tabBorderColor spec)+ tabBorder (Y (tabsY + tabHeight)) OpenBorderTop+ LowLevel.flcSetColor oldColor)+ if (elem DamageAll damages)+ then LowLevel.drawChild t (cs !! tabSelectedIndex)+ else LowLevel.updateChild t (cs !! tabSelectedIndex)+ LowLevel.flcSetColor oldColor+ LowLevel.flcSetDrawShortcut oldShortcut++-- | Damage the tabs widget appropriately for redraw+lightTabRedrawTabs :: TabSpec -> Ref LowLevel.Tabs -> IO ()+lightTabRedrawTabs spec t = do+ bounds <- LowLevel.getRectangle t+ let (tabsX,tabsY,tabsWidth,tabsHeight) = fromRectangle bounds+ (Height tabHeight) <- LowLevel.tabHeight t+ LowLevel.setDamageInside t [DamageScroll]+ (if (tabHeight < 0)+ then toRectangle (tabsX,tabsY+tabsHeight-(abs tabHeight),tabsWidth,(abs tabHeight))+ else toRectangle (tabsX,tabsY,tabsWidth,tabHeight))++-- | Handles all events to the tab+lightTabHandleCustom :: TabSpec -> Ref LowLevel.Tabs -> Event -> IO (Either UnknownEvent ())+lightTabHandleCustom spec t e = do+ tl <- LowLevel.getLabel t+ bounds <- LowLevel.getRectangle t+ let (tabsX,tabsY,tabsWidth,tabsHeight) = fromRectangle bounds+ offset <- readIORef (tabViewOffset spec)+ pos@(Position (X x') (Y y')) <- FL.eventPosition+ nextIndexAndWidget <- lightTabWhichCustom spec t pos+ (_,_,widths) <- lightTabPositionsCustom spec t+ let nextWidget = fmap (\(_,w) -> w) nextIndexAndWidget+ nextIndex = fmap (\(i,_) -> i) nextIndexAndWidget+ setSelectedWidget = LowLevel.setPush t nextWidget >> return (Right ())+ offsetWidths = map (\(X x, Width w) -> (X (x+offset), Width w)) widths+ adjustOffset newOffset = writeIORef (tabViewOffset spec) (offset-newOffset)+ partiallyShow i =+ let (_,Width w) = offsetWidths !! i in+ if (w >= (tabPartiallyVisible spec))+ then (tabPartiallyVisible spec)+ else w+ handleRelease = do+ tabBarRect <- tabBarRectangle spec t+ if (not (insideRectangle pos tabBarRect))+ then LowLevel.handleSuper t e+ else do+ lastSelected <- LowLevel.getPush t+ LowLevel.setPush t (Nothing :: (Maybe (Ref LowLevel.Widget)))+ focusedWidget <- FL.focus+ case lastSelected of+ Nothing -> return (Right ())+ Just w -> do+ vf <- FL.visibleFocus+ when vf+ (do+ imFocused <- refPtrEquals w t+ if imFocused then lightTabRedrawTabs spec t+ else FL.setFocus(t) >> lightTabRedrawTabs spec t)+ changed <- LowLevel.setValue t lastSelected+ case changed of+ Left NoChange -> do+ whens <- LowLevel.getWhen t+ when (WhenNotChanged `elem` whens) (LowLevel.setChanged t >> LowLevel.doCallback t)+ Right () -> LowLevel.setChanged t >> LowLevel.doCallback t+ deleted <- isNull w+ if (not deleted)+ then LowLevel.tooltipSetCurrent (Just w) >> return (Right())+ else return (Right ())+ handlePush =+ let adjustWhenNot yOutsideRange =+ if yOutsideRange then LowLevel.handleSuper (safeCast t :: Ref LowLevel.Group) e+ else+ case nextIndex of+ Just (AtIndex i) ->+ let (X x, Width w) = offsetWidths !! i+ rightOverflow = (x+w) - (tabsX+tabsWidth)+ leftOverflow = x-tabsX+ in do+ case i of+ _ | i == 0 -> adjustOffset leftOverflow+ | i == (length widths - 1) -> adjustOffset (if (rightOverflow < 0) then 0 else rightOverflow)+ | otherwise ->+ if (rightOverflow >= 0)+ then adjustOffset (rightOverflow + partiallyShow (i+1))+ else if (leftOverflow < 0)+ then adjustOffset (leftOverflow - partiallyShow (i-1))+ else return ()+ setSelectedWidget+ _ -> setSelectedWidget+ in do+ (Height tabHeight) <- LowLevel.tabHeight t+ if (tabHeight < 0)+ then adjustWhenNot (y' < tabsY + tabsHeight - (abs tabHeight))+ else adjustWhenNot (y' > tabsY + tabHeight)++ case e of+ Push -> handlePush+ Drag -> handleRelease+ Release -> handleRelease+ Keydown -> do+ (selectedMaybe,_,widths) <- lightTabPositionsCustom spec t+ eventKey <- FL.eventKey+ case eventKey of+ SpecialKeyType Kb_Left ->+ case selectedMaybe of+ Just (AtIndex i) ->+ if (i == 0) then LowLevel.handleSuper t e+ else+ let (X x, Width w) = offsetWidths !! (i-1)+ currOffset = x - tabsX+ in do+ if (currOffset >= 0)+ then return ()+ else adjustOffset (currOffset - (if (i > 1) then partiallyShow (i-2) else 0))+ LowLevel.handleSuper t e+ _ -> LowLevel.handleSuper t e+ SpecialKeyType Kb_Right ->+ case selectedMaybe of+ Just (AtIndex i) ->+ if (i == ((length widths) - 1)) then LowLevel.handleSuper t e+ else+ let (X x,Width w) = offsetWidths !! (i+1)+ currOffset = (x+w) - (tabsX+tabsWidth)+ in do+ when (currOffset >= 0) (adjustOffset (currOffset + (if (i < (length widths - 2)) then partiallyShow (i+2) else 0)))+ LowLevel.handleSuper t e+ _ -> LowLevel.handleSuper t e+ _ -> LowLevel.handleSuper t e+ _ -> LowLevel.handleSuper t e++-- | Calculate the width and x coordinate of each tab+lightTabPositionsCustom :: TabSpec -> Ref LowLevel.Tabs -> IO (Maybe AtIndex, Int, [(X,Width)])+lightTabPositionsCustom spec t = do+ bounds <- LowLevel.getRectangle t+ cs <- LowLevel.getArray t+ let Rectangle (Position (X x) _) _ = bounds+ selected <- selectedTab (zip (map AtIndex [0 ..]) cs)+ widths <-+ mapM+ (\c -> do+ oldLabeltype <- LowLevel.getLabeltype c+ oldAlign <- LowLevel.getAlign c+ case oldLabeltype of { NoLabelType -> LowLevel.setLabeltype c NormalLabelType ResolveImageLabelDoNothing; _ -> return () }+ (Size (Width width') _) <- LowLevel.measureLabel c Nothing+ tabAlign <- LowLevel.getTabAlign t+ LowLevel.setAlign c (Alignments [tabAlign])+ LowLevel.setLabeltype c oldLabeltype ResolveImageLabelDoNothing+ LowLevel.setAlign c oldAlign+ return (width' + (tabHorizontalPadding spec) * 2)+ )+ cs+ let xOffsets = zip (map X (map ((+) x) (scanl (+) 0 widths))) (map Width widths)+ return (selected, (0 :: Int), xOffsets)+ where+ selectedTab :: [(AtIndex, Ref LowLevel.Widget)] -> IO (Maybe AtIndex)+ selectedTab [] = return Nothing+ selectedTab ((i,w):ws) = do+ v <- LowLevel.getVisible w+ if v then return (Just i) else selectedTab ws++-- | Calculate the height of each tab, a negative height indicates tabs are along the bottom+lightTabHeightCustom :: TabSpec -> Ref LowLevel.Tabs -> IO Height+lightTabHeightCustom spec t = do+ cs <- LowLevel.getArray t+ if (null cs)+ then return (Height 0)+ else do+ (Y y) <- LowLevel.getY t+ (Height h) <- LowLevel.getH t+ tops <- mapM (\c -> do {(Y y) <- LowLevel.getY c; return (y+(tabVerticalPadding spec)*2);}) cs+ bottoms <- mapM (\c -> do {(Y y) <- LowLevel.getY c; (Height h) <- LowLevel.getH c; return (y+h-(tabVerticalPadding spec)*2);}) cs+ let topGap = minimum (map (\cy -> cy - y) tops)+ bottomGap = y+h - (maximum bottoms)+ height = if (bottomGap > topGap) then+ if bottomGap <= 0 then 0 else (-bottomGap)+ else if topGap <= 0 then 0 else topGap+ return (Height height)++-- | Calculate the bounds of the area inside the tab containing other widgets+lightTabClientAreaCustom :: TabSpec -> Ref LowLevel.Tabs -> LowLevel.TabsHeightOffset -> IO Rectangle+lightTabClientAreaCustom spec t tOffset = do+ cs <- LowLevel.getArray t+ case cs of+ (c:_) -> LowLevel.getRectangle c+ _ -> do+ lf <- LowLevel.getLabelfont t+ ls <- LowLevel.getLabelsize t+ (Height h) <- LowLevel.flcHeightOfFont lf ls+ let paddedHeight = h+(tabVerticalPadding spec * 2)+ (tabsX,tabsY,tabsW,tabsH) <- fmap fromRectangle (LowLevel.getRectangle t)+ let clientArea = case tOffset of+ LowLevel.TabsAtTop Nothing -> (tabsX,tabsY+paddedHeight,tabsW,tabsH-paddedHeight)+ LowLevel.TabsAtBottom Nothing -> (tabsX,tabsY,tabsW,tabsH-paddedHeight)+ LowLevel.TabsAtTop (Just o) -> (tabsX,tabsY+o,tabsW,tabsH-o)+ LowLevel.TabsAtBottom (Just o) -> (tabsX,tabsY,tabsW,tabsH-o)+ return (toRectangle clientArea)++-- | Calcuate the bounds of the tab bar+tabBarRectangle :: TabSpec -> Ref LowLevel.Tabs -> IO Rectangle+tabBarRectangle spec t = do+ (tabsX,tabsY,tabsW,tabsH) <- fmap fromRectangle (LowLevel.getRectangle t)+ (Height tabHeight) <- lightTabHeightCustom spec t+ return+ (if (tabHeight < 0)+ then toRectangle (tabsX,tabsY+tabsH-(abs tabHeight),tabsW,abs tabHeight)+ else toRectangle (tabsX,tabsY,tabsW,tabHeight))++-- | Determine which tab was just selected+lightTabWhichCustom :: TabSpec -> Ref LowLevel.Tabs -> Position -> IO (Maybe (AtIndex, Ref LowLevel.Widget))+lightTabWhichCustom spec t pos = do+ tabBarRect <- tabBarRectangle spec t+ if (not (insideRectangle pos tabBarRect))+ then return Nothing+ else do+ let (_,tabBarY,_,tabBarHeight) = fromRectangle tabBarRect+ (_,_,widths) <- lightTabPositionsCustom spec t+ offset <- readIORef (tabViewOffset spec)+ let tab = find+ (\(i,(x,w)) -> insideRectangle pos (Rectangle (Position x (Y tabBarY)) (Size w (Height tabBarHeight))))+ (zip (map AtIndex [0 ..]) (map (\(X x, Width w) -> (X (x+offset), Width w)) widths))+ cs <- LowLevel.getArray t+ return (fmap (\(AtIndex i, _) -> (AtIndex i,cs !! i)) tab)++-- | A default 'TabSpec'+tabSpec :: (?assets :: Assets) => Rectangle -> IO TabSpec+tabSpec rectangle = do+ let (tabsX,tabsY,tabsWidth,tabsHeight) = fromRectangle rectangle+ buttonWidth = 15+ buttonHeight = 15+ borderColor <- commonSelectionColor+ color <- commonColor+ offset <- newIORef 0+ return+ (TabSpec+ {+ tabRadius = 1+ , tabHorizontalPadding = 10+ , tabVerticalPadding = 3+ , tabInactiveBorderColor = colorAverage color blackColor 0.97+ , tabBorderColor = borderColor+ , tabFillColor = lightBackground+ , tabViewOffset = offset+ , tabPartiallyVisible = 20+ })++tabsNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Tabs)+tabsNew rectangle label = do+ spec <- tabSpec rectangle+ t <- LowLevel.tabsCustom+ rectangle+ label+ (Just+ (LowLevel.CustomTabFuncs+ {+ LowLevel.tabDrawCustom = drawTabs spec+ , LowLevel.tabPositionsCustom = lightTabPositionsCustom spec+ , LowLevel.tabHeightCustom = lightTabHeightCustom spec+ , LowLevel.tabWhichCustom = lightTabWhichCustom spec+ , LowLevel.tabRedrawTabs = lightTabRedrawTabs spec+ , LowLevel.tabClientArea = lightTabClientAreaCustom spec+ }))+ (Just+ (LowLevel.defaultCustomWidgetFuncs+ {+ LowLevel.handleCustom = Just (lightTabHandleCustom spec)+ }))+ p <- LowLevel.getParent t+ color <- maybe (return lightBackground) LowLevel.getColor p+ LowLevel.setColor t color+ LowLevel.setLabelfont t commonFont+ LowLevel.setLabelsize t commonFontSize+ return t
+ src/Graphics/UI/FLTK/Theme/Light/TextDisplay.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings #-}+module Graphics.UI.FLTK.Theme.Light.TextDisplay+ (+ textDisplayNew+ )+where+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import qualified Data.Text as T+import Graphics.UI.FLTK.Theme.Light.Assets++textDisplayNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.TextDisplay)+textDisplayNew r l = do+ t <- LowLevel.textDisplayNew r l+ LowLevel.setColor t lightBackground+ LowLevel.setTextfont t commonFont+ LowLevel.setTextsize t commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor t color+ LowLevel.setLabelfont t commonFont+ LowLevel.setLabelsize t commonFontSize+ return t
+ src/Graphics/UI/FLTK/Theme/Light/TextEditor.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings #-}+module Graphics.UI.FLTK.Theme.Light.TextEditor+ (+ textEditorNew+ )+where+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import qualified Data.Text as T+import Graphics.UI.FLTK.Theme.Light.Assets++textEditorNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.TextEditor)+textEditorNew r l = do+ t <- LowLevel.textEditorNew r l+ LowLevel.setColor t lightBackground+ LowLevel.setTextfont t commonFont+ LowLevel.setTextsize t commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor t color+ LowLevel.setLabelfont t commonFont+ LowLevel.setLabelsize t commonFontSize+ return t
+ src/Graphics/UI/FLTK/Theme/Light/Tree.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Tree+ (+ treeNew+ )+where+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.Theme.Light.Assets++treeNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Tree)+treeNew rectangle l' = do+ let customDraw :: Ref LowLevel.Tree -> IO ()+ customDraw t = do+ (color :: Color) <- LowLevel.getColor t+ let slightlyDarker = colorAverage color blackColor 0.85+ withCustomBoxDraw+ BorderBox+ (\rect _ -> do+ LowLevel.flcRectfWithColor rect color+ LowLevel.flcRectWithColor rect slightlyDarker)+ (LowLevel.drawSuper t)+ t <- LowLevel.treeCustom rectangle l' (Just customDraw) Nothing+ LowLevel.setBox t BorderBox+ LowLevel.setColor t lightBackground+ LowLevel.setLabelfont t commonFont+ LowLevel.setLabelsize t commonFontSize+ LowLevel.setItemLabelfont t commonFont+ LowLevel.setItemLabelsize t commonFontSize+ sc <- commonSelectionColor+ LowLevel.setSelectionColor t sc+ LowLevel.setScrollbarSize t 10+ LowLevel.setConnectorstyle t TreeConnectorSolid+ return t
+ src/Graphics/UI/FLTK/Theme/Light/Valuator.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Valuator+ (+ adjusterNew,+ valueOutputNew,+ valueInputNew+ )+where+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import Graphics.UI.FLTK.Theme.Light.Input+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import Graphics.UI.FLTK.LowLevel.Dispatch+import Graphics.UI.FLTK.Theme.Light.Assets++adjusterNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Adjuster)+adjusterNew rectangle label = do+ a <- LowLevel.adjusterNew rectangle label+ LowLevel.setLabelfont a commonFont+ LowLevel.setLabelsize a commonFontSize+ color <- commonColor+ LowLevel.setColor a color+ color <- commonSelectionColor+ LowLevel.setSelectionColor a color+ return a++valueOutputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ValueOutput)+valueOutputNew rect l = do+ let customDraw :: Ref LowLevel.ValueOutput -> IO ()+ customDraw vo =+ withCustomBoxDraw+ BorderBox+ (\rect color -> do+ LowLevel.flcRectfWithColor rect color+ focused <- isWidget vo FL.focus+ inputBox focused rect color)+ (LowLevel.drawSuper vo)+ vo <- LowLevel.valueOutputCustom rect l (Just customDraw) Nothing+ LowLevel.setColor vo lightBackground+ LowLevel.setBox vo BorderBox+ LowLevel.setTextfont vo commonFont+ LowLevel.setTextsize vo commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor vo color+ LowLevel.setLabelfont vo commonFont+ LowLevel.setLabelsize vo commonFontSize+ return vo++valueInputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ValueInput)+valueInputNew rect l = do+ let customDraw :: Ref LowLevel.ValueInput -> IO ()+ customDraw vi =+ withCustomBoxDraw+ BorderBox+ (\rect color -> do+ LowLevel.flcRectfWithColor rect color+ focused <- isWidget vi FL.focus+ inputBox focused rect color)+ (LowLevel.drawSuper vi)+ vi <- LowLevel.valueInputCustom rect l (Just customDraw) Nothing+ LowLevel.setColor vi lightBackground+ LowLevel.setBox vi BorderBox+ LowLevel.setTextfont vi commonFont+ LowLevel.setTextsize vi commonFontSize+ color <- commonSelectionColor+ LowLevel.setSelectionColor vi color+ LowLevel.setLabelfont vi commonFont+ LowLevel.setLabelsize vi commonFontSize+ return vi
+ src/Graphics/UI/FLTK/Theme/Light/Window.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module Graphics.UI.FLTK.Theme.Light.Window+ (+ doubleWindowNew,+ singleWindowNew,+ windowNew+ )+where+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.Theme.Light.Common+import qualified Data.Text as T+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel++windowNew :: Size -> Maybe Position -> Maybe T.Text -> IO (Ref LowLevel.Window)+windowNew size position label = do+ w <- LowLevel.windowNew size position label+ LowLevel.setColor w lightBackground+ return w++doubleWindowNew :: Size -> Maybe Position -> Maybe T.Text -> IO (Ref LowLevel.DoubleWindow)+doubleWindowNew size position label = do+ w <- LowLevel.doubleWindowNew size position label+ LowLevel.setColor w lightBackground+ return w++singleWindowNew :: Size -> Maybe Position -> Maybe T.Text -> IO (Ref LowLevel.SingleWindow)+singleWindowNew size position label = do+ w <- LowLevel.singleWindowNew size position label+ LowLevel.setColor w lightBackground+ return w
+ src/Graphics/UI/FLTK/Theme/Light/Wizard.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE ImplicitParams, OverloadedStrings #-}+module Graphics.UI.FLTK.Theme.Light.Wizard+ (+ wizardNew+ )+where+import Graphics.UI.FLTK.Theme.Light.Common+import Graphics.UI.FLTK.Theme.Light.Assets+import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel+import qualified Data.Text as T++wizardNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.Wizard)+wizardNew r l = do+ w <- LowLevel.wizardNew r l+ LowLevel.setColor w lightBackground+ color <- commonSelectionColor+ LowLevel.setSelectionColor w color+ LowLevel.setLabelfont w commonFont+ LowLevel.setLabelsize w commonFontSize+ return w