Style.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Barrie.Style (Style, Styled(..), addStyle, emptyStyle,
                     mkStyle, styleValue,
                     caption, getCaption,
                     hideDisabled, getHideDisabled,
                     homogenous, getHomogenous,
                     textValue, textItems,
                     minValue, maxValue,
                     getMinValue, getMaxValue,
                     adjustment, getAdjustment,
                     treeHeaderVisible, getTreeHeaderVisible) where

import Data.Monoid

newtype Style = Style [(String, StyleValue)]
           deriving (Read, Show, Monoid)

type StyleValue = String

mkStyle :: String -> StyleValue -> Style
mkStyle name value = Style [(name, value)]

class Styled a where
   setStyle :: Style -> a -> a
   getStyle :: a -> Style

instance Styled Style where
   setStyle = const
   getStyle = id

addStyle :: (Styled a) => Style -> a -> a
addStyle style item = setStyle (style `mappend` getStyle item) item

emptyStyle :: Style
emptyStyle = Style []

styleValue :: (Styled a) => String -> a -> Maybe StyleValue
styleValue name ss = lookup name styleList
   where (Style styleList) = getStyle ss

caption :: (Styled a) => String -> a -> a
caption text = addStyle $ mkStyle "caption" text

getCaption :: (Styled a) => a -> Maybe String
getCaption = styleValue "caption"

textValue :: (Styled a) => String -> a -> a
textValue text = addStyle $ mkStyle "textValue" text

textItems :: (Styled a) => [String] -> a -> a
textItems items = addStyle $ mkStyle "textItems" (unlines items)

hideDisabled :: (Styled a) => Bool -> a -> a
hideDisabled hide = addStyle $ mkStyle "hideDisabled" (show hide)

getHideDisabled :: (Styled a) => a -> Bool
getHideDisabled style = case styleValue "hideDisabled" style of
                          Nothing -> False
                          Just text -> read text


homogenous :: (Styled a) => Bool -> a -> a
homogenous set = addStyle $ mkStyle "homogenous" (show set)

getHomogenous :: (Styled a) => a -> Bool
getHomogenous style = case styleValue "homogenous" style of
                          Nothing -> False
                          Just text -> read text


minValue :: (Styled a, Num b, Show b, Read b) => b -> a -> a
minValue value = addStyle $ mkStyle "minValue" (show value)

getMinValue :: (Styled a, Num b, Show b, Read b) => a -> b
getMinValue style = case styleValue "minValue" style of
                          Nothing -> 0
                          Just text -> read text


maxValue :: (Styled a, Num b, Show b, Read b) => b -> a -> a
maxValue value = addStyle $ mkStyle "maxValue" (show value)

getMaxValue :: (Styled a, Num b, Show b, Read b) => a -> b
getMaxValue style = case styleValue "maxValue" style of
                          Nothing -> 0
                          Just text -> read text


adjustment :: (Styled a, Num b, Show b, Read b) => b -> a -> a
adjustment value = addStyle $ mkStyle "adjustment" (show value)

getAdjustment :: (Styled a, Num b, Show b, Read b) => a -> b
getAdjustment style = case styleValue "adjustment" style of
                          Nothing -> 1
                          Just text -> read text


treeHeaderVisible :: (Styled a) => Bool -> a -> a
treeHeaderVisible hide = addStyle $ mkStyle "treeHeaderVisible" (show hide)

getTreeHeaderVisible :: (Styled a) => a -> Bool
getTreeHeaderVisible style = case styleValue "treeHeaderVisible" style of
                               Nothing -> False
                               Just text -> read text