fltkhs-themes-0.1.0.0: src/Graphics/UI/FLTK/Theme/Light/Assets.hs
{-# 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.