CssUtils.hs

{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2015 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

module Coin.UI.Utils.CssUtils (
    gtkStyleProviderPriorityTheme,
    gtkStyleProviderPrioritySetting,
    gtkStyleProviderPriorityApplication,
    gtkStyleProviderPriorityUser,
    cssUtilsAddProvider,
    cssUtilsProviderNew,
    cssStyle,
    cssStyleReset
) where

import Graphics.UI.Gtk
import Graphics.UI.Gtk.General.CssProvider
import Graphics.UI.Gtk.General.StyleContext

import Control.Exception

import Coin.Config.Version

gtkStyleProviderPriorityTheme :: Int
gtkStyleProviderPriorityTheme = 200

gtkStyleProviderPrioritySetting :: Int
gtkStyleProviderPrioritySetting = 400

gtkStyleProviderPriorityApplication :: Int
gtkStyleProviderPriorityApplication = 600

gtkStyleProviderPriorityUser :: Int
gtkStyleProviderPriorityUser = 800

cssUtilsAddProvider :: WidgetClass cls => cls -> CssProvider -> Int -> IO ()
cssUtilsAddProvider widget provider priority = do
    context <- widgetGetStyleContext $ castToWidget widget
    styleContextAddProvider context provider priority

cssUtilsProviderNew :: [String] -> IO CssProvider
cssUtilsProviderNew text = do
    provider <- cssProviderNew
    catch (cssProviderLoadFromString provider $ unlines text)
          (\(SomeException e) -> do
               putStrLn "cssUtilsProviderNew Exception."
               putStrLn $ show e
               putStrLn "Text:"
               putStrLn $ unlines text
               throw e
          )
    return provider

cssStyle :: WidgetClass cls => Attr cls [String]
cssStyle = newAttr (\_ -> undefined)
                   (\w text -> do
                       cssProvider <- cssUtilsProviderNew text
                       cssUtilsAddProvider w cssProvider gtkStyleProviderPriorityApplication
                   )

cssStyleReset :: String
cssStyleReset = unlines $
    if gtkVersionOld then
        {- Gtk-3.18 -}
        [ "* {"
        , "    color: inherit;"
        , "    font-size: inherit;"
        , "    background-color: initial;"
        , "    font-family: inherit;"
        , "    font-style: inherit;"
        , "    font-variant: inherit;"
        , "    font-weight: inherit;"
        , "    text-shadow: inherit;"
        , "    icon-shadow: inherit;"
        , "    box-shadow: initial;"
        , "    margin-top: initial;"
        , "    margin-left: initial;"
        , "    margin-bottom: initial;"
        , "    margin-right: initial;"
        , "    padding-top: initial;"
        , "    padding-left: initial;"
        , "    padding-bottom: initial;"
        , "    padding-right: initial;"
        , "    border-top-style: initial;"
        , "    border-top-width: initial;"
        , "    border-left-style: initial;"
        , "    border-left-width: initial;"
        , "    border-bottom-style: initial;"
        , "    border-bottom-width: initial;"
        , "    border-right-style: initial;"
        , "    border-right-width: initial;"
        , "    border-top-left-radius: initial;"
        , "    border-top-right-radius: initial;"
        , "    border-bottom-right-radius: initial;"
        , "    border-bottom-left-radius: initial;"
        , "    outline-style: initial;"
        , "    outline-width: initial;"
        , "    outline-offset: initial;"
        , "    background-clip: initial;"
        , "    background-origin: initial;"
        , "    background-size: initial;"
        , "    background-position: initial;"
        , "    border-top-color: initial;"
        , "    border-right-color: initial;"
        , "    border-bottom-color: initial;"
        , "    border-left-color: initial;"
        , "    outline-color:  initial;"
        , "    background-repeat: initial;"
        , "    background-image: initial;"
        , "    border-image-source: initial;"
        , "    border-image-repeat: initial;"
        , "    border-image-slice: initial;"
        , "    border-image-width: initial;"
        , "    transition-property: initial;"
        , "    transition-duration: initial;"
        , "    transition-timing-function: initial;"
        , "    transition-delay: initial;"
        , "    engine: initial;"
        , "    gtk-key-bindings: initial;"
        , "    -GtkNotebook-initial-gap: 0;"
        , "}"
        ]
    else
        {- Gtk-3.20 -}
        [ "* {"
        , "    all: unset;"
        , "}"
        ]