Stylesheets.hs

module Graphics.Rendering.Hieroglyph.Stylesheets where

import Graphics.Rendering.Hieroglyph.Primitives
import Graphics.Rendering.Hieroglyph.Visual
import Data.Map (Map)
import qualified Data.Map as Map

type Style = BaseVisual -> BaseVisual
	
data Styling =
      StyleSelector String Style
    | ArcStyle Style
    | DotsStyle Style
    | PathStyle Style
    | RectStyle Style
    | TextStyle Style

data Stylesheet = Stylesheet
    { selectors :: Map String Style
    , arcstyle :: Style
    , dotstyle :: Style
    , pathstyle :: Style
    , rectanglestyle :: Style
    , textstyle :: Style
    }

data BaseSel =
      IsArc (Maybe String)
    | IsDots (Maybe String)
    | IsPath (Maybe String)
    | IsRect (Maybe String)
    | IsText (Maybe String)
    | IsRest (Maybe String)
    deriving (Ord,Eq)

stylesheet styles = foldr mkStylesheet' (Stylesheet Map.empty id id id id id) styles
    where mkStylesheet' (ArcStyle s)  ss       = ss{ arcstyle = s }
          mkStylesheet' (DotsStyle s) ss       = ss{ dotstyle = s }
          mkStylesheet' (PathStyle s) ss       = ss{ pathstyle = s }
          mkStylesheet' (RectStyle s) ss       = ss{ rectanglestyle = s }
          mkStylesheet' (TextStyle s) ss       = ss{ textstyle = s }
          mkStylesheet' (StyleSelector k s) ss = ss{ selectors = Map.insert k s . selectors $ ss }

binHelper p k = maybe
    (k Nothing,p)
    (\s -> (k (Just s),p))
    (styleselector . attribs $ p)

bin p@(Dots{}) = binHelper p IsDots
bin p@(Arc{}) = binHelper p IsArc
bin p@(Path{}) = binHelper p IsPath
bin p@(Rectangle{}) = binHelper p IsRect
bin p@(Text{}) = binHelper p IsText
bin p = binHelper p IsRest

styledPrims ss = style ss . primitives

withStylesheet ss v = concat $ Map.elems styledVisuals
    where binnedVisuals = foldr (\(b,p) -> Map.insertWith (++) b [p]) Map.empty . map bin $ v
          styledVisuals = Map.mapWithKey applyStyle binnedVisuals
          applyStyle (IsArc s) ps = applyStyle' s (arcstyle ss) ps
          applyStyle (IsDots s) ps = applyStyle' s (dotstyle ss) ps
          applyStyle (IsPath s) ps = applyStyle' s (pathstyle ss) ps
          applyStyle (IsRect s) ps = applyStyle' s (rectanglestyle ss) ps
          applyStyle (IsText s) ps = applyStyle' s (textstyle ss) ps
          applyStyle (IsRest s) ps = applyStyle' s id ps
          applyStyle' (Just sel) f ps = maybe (f ps) ($ps) (Map.lookup sel . selectors $ ss)