-- | Rudimentary support for inline style attributes
module StyleAttrs(TagAttrs,lookupAttr,
                  lookupStyleAttr,lookupLength,lookupMargins,getBgImage,
                  lookupWidth,lookupHeight,lookupBorderWidth) where
import Data.List(stripPrefix)
import Data.Maybe(listToMaybe)
import Control.Monad((<=<))
import Control.Applicative((<|>))
import TagAttrs(TagAttrs,lookupAttr)
import Utils2(chopList,breakAt,trim,aboth)

lookupStyleAttr attrName cssName attrs =
  lookupAttr attrName attrs <|> lookupStyle cssName attrs

lookupStyle name attrs = lookup name . parseStyle =<< lookupAttr "STYLE" attrs

parseStyle = map (aboth trim . breakAt ':') . chopList (breakAt ';')

lookupWidth = lookupLength "WIDTH" "width"
lookupHeight = lookupLength "HEIGHT" "height"

lookupMargins attrs =
  case lookupStyleLengths "margin" attrs of
    [] -> Nothing
    ms -> Just (t,r,b,l) where t:r:b:l:_ = cycle ms

lookupBorderWidth attrs =
  lookupLength "BORDER" "border" attrs<|>lookupStyleLength "border-width" attrs

lookupLength attrName cssName attrs =
    lookupInt attrName attrs <|> lookupStyleLength cssName attrs

lookupStyleLength cssName = listToMaybe . lookupStyleLengths cssName

lookupStyleLengths cssName attrs =
   applyUnit=<<reads=<<maybe [] words (lookupStyle cssName attrs)
  where
    applyUnit (i,u) =
      case u of
        "" -> [i::Int]
        "px" -> [i]
        _ -> [] -- "px" is the only length unit supported for now !!

getBgImage attrs =
    lookupAttr "BACKGROUND" attrs <|>
    (parseURI =<< lookupStyle "background-image" attrs)
  where
    parseURI = unquote <=< unwrap "url(" ")"

--------------------------------------------------------------------------------

lookupInt k attrs =
  do (i,"") <- readM =<< lookupAttr k attrs
     return (i::Int)

readM s = listToMaybe (reads s)

unwrap pre suf = stripSuffix suf <=< stripPrefix pre
unquote a = unwrap "\"" "\"" a <|> unwrap "'" "'" a <|> return a
stripSuffix suf s = reverse <$> stripPrefix (reverse suf) (reverse s)