{-# LANGUAGE TemplateHaskell, RankNTypes #-}
module Control.Monad.Takahashi.HtmlBuilder.Style 
  ( FloatOption(..)
  , TextAlign(..)
  , VerticalAlign(..)
  , Display(..)
  , Len(..)
  , Color(..)
  , BorderStyle(..)
  , BoxSizing(..)
  , FontFamily(..)
  , WhiteSpace(..)
  -----
  , Style(..)
  , size, float, display, font, backGround, align, border
  , Size(..)
  , height, width
  , Align(..)
  , textAlign, verticalAlign
  , Font(..)
  , foreColor, fontSize, fontFamily, whiteSpace
  , Margin(..)
  , margin, paddingTop, paddingLeft, paddingRight, paddingBottom
  , marginTop, marginLeft, marginRight, marginBottom
  , Border(..)
  , borderColor, borderWidth, borderStyle, boxSizing 
  -----
  , defaultStyle
  , MakeStyle
  , runMakeStyle
  , execMakeStyle
  , showStyle
  , makeStyle
  -----
  , normalizeColor
  , showColor
  ) where
import Control.Lens
import Control.Monad.State
import Numeric
import Data.List(intercalate)

data FloatOption = FloatLeft | ClearBoth deriving (Show, Read, Eq, Ord)
data TextAlign = AlignLeft | AlignCenter | AlignRight deriving (Show, Read, Eq, Ord)
data VerticalAlign = AlignTop | AlignMiddle | AlignBottom deriving (Show, Read, Eq, Ord)
data Display = Table | TableCell | Block | None | InlineTable | InlineBlock deriving (Show, Read, Eq, Ord)
data Len = Per Int | Px Int deriving (Show, Read, Eq, Ord)
data Color = Color Integer Integer Integer deriving (Show, Read, Eq, Ord)
data BorderStyle = BorderNone | BorderSolid | BorderDouble deriving (Show, Read, Eq, Ord)
data BoxSizing = ContentsBox | BorderBox  deriving (Show, Read, Eq, Ord)
data FontFamily = FontName String | Monospace | Selif | SansSelif deriving (Show, Read, Eq, Ord)
data WhiteSpace = Normal | Pre deriving (Show, Read, Eq, Ord)

data Margin = Margin 
  { _paddingTop :: Maybe Len
  , _paddingLeft :: Maybe Len
  , _paddingBottom :: Maybe Len
  , _paddingRight :: Maybe Len
  , _marginTop :: Maybe Len
  , _marginLeft :: Maybe Len
  , _marginBottom :: Maybe Len
  , _marginRight :: Maybe Len
  } deriving (Show, Read, Eq, Ord)

data Size = Size 
  { _height :: Maybe Len
  , _width :: Maybe Len
  } deriving (Show, Read, Eq, Ord)

data Align = Align
  { _textAlign :: Maybe TextAlign
  , _verticalAlign :: Maybe VerticalAlign
  } deriving (Show, Read, Eq, Ord)

data Font = Font
  { _foreColor :: Maybe Color
  , _fontSize :: Maybe Int
  , _fontFamily :: Maybe [FontFamily]
  , _whiteSpace :: Maybe WhiteSpace
  } deriving (Show, Read, Eq, Ord)

data Border = Border 
  { _borderColor :: Maybe Color
  , _borderWidth :: Maybe Int
  , _borderStyle :: Maybe BorderStyle
  , _boxSizing :: Maybe BoxSizing
  } deriving (Show, Read, Eq, Ord)

data Style = Style
  { _size :: Size
  , _float :: Maybe FloatOption
  , _display :: Maybe Display
  , _backGround :: Maybe Color
  , _margin :: Margin
  , _border :: Border
  , _font :: Font
  , _align :: Align
  } deriving (Show, Read, Eq, Ord)

makeLenses ''Margin
makeLenses ''Size
makeLenses ''Align
makeLenses ''Font
makeLenses ''Style
makeLenses ''Border

defaultStyle :: Style
defaultStyle = Style
  { _size = Size
    { _height = Nothing
    , _width = Nothing
    }
  , _align = Align
    { _textAlign = Nothing
    , _verticalAlign = Nothing
    }
  , _font = Font
    { _fontSize = Nothing
    , _foreColor = Nothing
    , _fontFamily = Nothing
    , _whiteSpace = Nothing
    }
  , _margin = Margin
    { _paddingTop = Nothing
    , _paddingLeft = Nothing
    , _paddingBottom  = Nothing
    , _paddingRight  = Nothing
    , _marginTop = Nothing
    , _marginLeft = Nothing
    , _marginBottom  = Nothing
    , _marginRight  = Nothing
    }
  , _border = Border
    { _borderColor = Nothing
    , _borderWidth = Nothing
    , _borderStyle = Nothing
    , _boxSizing = Nothing
    }
  , _float = Nothing
  , _display = Nothing
  , _backGround = Nothing
  }

----

showStyle :: Style -> String
showStyle style = intercalate ";" . filter (/="") $
  [ emaybe (\y -> "height:" ++ showLen y) $ style^.size.height
  , emaybe (\y -> "width:" ++ showLen y) $ style^.size.width
  , emaybe (\y -> "text-align:" ++ showTextAlign y) $ style^.align.textAlign
  , emaybe (\y -> "vertical-align:" ++ showVerticalAlign y) $ style^.align.verticalAlign
  , emaybe showFloat $ _float style
  , emaybe (\y -> "display:" ++ showDisplay y) $ _display style
  , emaybe (\y -> "font-size:" ++ show y ++ "px") $ style^.font.fontSize
  , emaybe (\y -> "color:" ++ showColor y) $ style^.font.foreColor
  , emaybe (\y -> "background:" ++ showColor y) $ _backGround style
  , emaybe (\y -> "padding-top:" ++ showLen y) $ style^.margin.paddingTop
  , emaybe (\y -> "padding-left:" ++ showLen y) $ style^.margin.paddingLeft
  , emaybe (\y -> "padding-right:" ++ showLen y) $ style^.margin.paddingRight
  , emaybe (\y -> "padding-bottom:" ++ showLen y) $ style^.margin.paddingBottom
  , emaybe (\y -> "margin-top:" ++ showLen y) $ style^.margin.marginTop
  , emaybe (\y -> "margin-left:" ++ showLen y) $ style^.margin.marginLeft
  , emaybe (\y -> "margin-right:" ++ showLen y) $ style^.margin.marginRight
  , emaybe (\y -> "margin-bottom:" ++ showLen y) $ style^.margin.marginBottom
  , emaybe (\y -> "border-width:" ++ show y) $ style^.border.borderWidth
  , emaybe (\y -> "border-style:" ++ showBorderStyle y) $ style^.border.borderStyle
  , emaybe (\y -> "border-color:" ++ showColor y) $ style^.border.borderColor
  , emaybe (\y -> "box-sizing:" ++ showBoxSizing y) $ style^.border.boxSizing
  , emaybe (\y -> "font-family:" ++ (intercalate "," $ map showFontFamily y)) $ style^.font.fontFamily
  , emaybe (\y -> "white-space:" ++ showWhiteSpace y) $ style^.font.whiteSpace
  ] 
    where
      emaybe = maybe ""     

      showFloat x
        = case x of
          FloatLeft -> "float:left"
          ClearBoth -> "clear:both"

      showDisplay x
        = case x of
          Table -> "table"
          Block -> "block"
          TableCell -> "table-cell"
          None -> "none;"
          InlineTable -> "inline-table"
          InlineBlock -> "inline-block"

      showBorderStyle x
        = case x of
          BorderNone -> "none"
          BorderSolid -> "solid"
          BorderDouble -> "double"

      showBoxSizing x
        = case x of
          ContentsBox -> "contents-box"
          BorderBox -> "border-box"

      showFontFamily x
        = case x of
          FontName s -> "'" ++ s ++ "'"
          Monospace -> "monospace"
          Selif -> "selif"
          SansSelif -> "sans-selif"

      showWhiteSpace x
        = case x of
          Normal -> "normal"
          Pre -> "pre"

showLen :: Len -> String
showLen (Per x) = show x ++ "%"
showLen (Px x) = show x ++ "px"

----

type MakeStyle a = State Style a

runMakeStyle :: Style -> MakeStyle a -> (a, Style)
runMakeStyle s f = runState f s

execMakeStyle :: Style -> MakeStyle a -> Style
execMakeStyle s f = execState f s

makeStyle :: MakeStyle a -> String
makeStyle f = showStyle . execMakeStyle defaultStyle $ f

----

showTextAlign :: TextAlign -> String
showTextAlign AlignLeft = "left"
showTextAlign AlignCenter = "center"
showTextAlign AlignRight = "right"

showVerticalAlign :: VerticalAlign -> String
showVerticalAlign AlignTop = "top"
showVerticalAlign AlignMiddle = "middle"
showVerticalAlign AlignBottom = "bottom"

----

normalizeColor :: Color -> Color
normalizeColor (Color x y z) = Color (normalize x) (normalize y) (normalize z)
  where
    normalize :: Integer -> Integer
    normalize a 
      | a   < 0   = 0
      | 255 < a   = 255
      | otherwise = a

showColor :: Color -> String
showColor (Color x y z) = concat ["#", int2Hex x, int2Hex y, int2Hex z]
  where
    int2Hex :: Integer -> String
    int2Hex i = reverse . take 2 . reverse $ "0" ++ showHex i ""