{-# LANGUAGE OverloadedStrings #-}
-- | Parses & desugars CSS properties to general CatTrap datastructures.
module Graphics.Layout.CSS(CSSBox(..), BoxSizing(..), Display(..),
        finalizeCSS, finalizeCSS') where

import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import qualified Data.Text as Txt
import Stylist (PropertyParser(..), TrivialPropertyParser, parseOperands,
                parseUnorderedShorthand', parseUnorderedShorthand)
import Stylist.Tree (StyleTree(..))
import Data.Text.ParagraphLayout (PageOptions(..))

import Graphics.Layout.Box as B
import Graphics.Layout
import Graphics.Text.Font.Choose (Pattern(..), unset)
import Graphics.Layout.CSS.Length
import Graphics.Layout.CSS.Font
import Graphics.Layout.Grid.CSS
import Graphics.Layout.Inline.CSS

import Data.Maybe (isJust, fromMaybe)
import qualified Data.HashMap.Lazy as HM

-- | Parsed CSS properties relevant to layout.
data CSSBox a = CSSBox {
    -- | Which layout formula to use, a.k.a. parsed CSS display property.
    display :: Display,
    -- | (Unused) Parsed CSS box-sizing
    boxSizing :: BoxSizing,
    -- | sizing, margins, border-width, & padding CSS properties.
    -- Stores units in case they're needed for font-related units.
    cssBox :: PaddedBox Unitted Unitted, -- calc()?
    -- | Query parameters describing desired font.
    font :: Pattern,
    -- | Additional font-related CSS properties.
    font' :: CSSFont,
    -- | Caller-specified data, to parse additional CSS properties.
    inner :: a,
    -- | Grid-related CSS properties.
    gridStyles :: CSSGrid,
    -- | Grid item related CSS properties.
    cellStyles :: CSSCell,
    -- | inline-related CSS properties.
    inlineStyles :: CSSInline,
    -- | Parsed CSS caption-side.
    captionBelow :: Bool,
    -- | Parsed widows & orphans controlling pagination.
    pageOptions :: PageOptions
}
-- | Possible values for CSS box-sizing.
data BoxSizing = BorderBox | ContentBox
-- | Empty border, to use as default value.
noborder = Border (0,"px") (0,"px") (0,"px") (0,"px")

-- | Possibly values for CSS display property.
data Display = Block | Grid | Inline | Table | None |
    TableRow | TableHeaderGroup | TableRowGroup | TableFooterGroup | TableCell |
    TableColumn | TableColumnGroup | TableCaption deriving Eq
-- | Can the display value contain table-rows?
rowContainer CSSBox { display = d } =
    d `elem` [Table, TableHeaderGroup, TableRowGroup, TableFooterGroup]

instance PropertyParser a => PropertyParser (CSSBox a) where
    temp = CSSBox {
        boxSizing = ContentBox,
        display = Inline,
        cssBox = PaddedBox {
            B.min = Size auto auto,
            size = Size auto auto,
            nat = Size 0 0,
            B.max = Size auto auto,
            padding = noborder,
            border = noborder,
            margin = noborder
        },
        font = temp,
        font' = temp,
        inner = temp,
        gridStyles = temp,
        cellStyles = temp,
        inlineStyles = temp,
        captionBelow = False,
        pageOptions = PageOptions 0 0 2 2
      }
    inherit parent = CSSBox {
        boxSizing = boxSizing parent,
        display = Inline,
        cssBox = cssBox (temp :: CSSBox TrivialPropertyParser),
        font = inherit $ font parent,
        font' = inherit $ font' parent,
        inner = inherit $ inner parent,
        gridStyles = inherit $ gridStyles parent,
        cellStyles = inherit $ cellStyles parent,
        inlineStyles = inherit $ inlineStyles parent,
        captionBelow = captionBelow parent,
        pageOptions = pageOptions parent
      }
    priority self = concat [x font, x font', x gridStyles, x cellStyles, x inner]
      where x getter = priority $ getter self

    -- Wasn't sure how to implement in FontConfig-Pure
    longhand _ self "font-family" [Ident "initial"] =
        Just self { font = unset "family" $ font self}

    longhand _ self "box-sizing" [Ident "content-box"] = Just self {boxSizing = ContentBox}
    longhand _ self "box-sizing" [Ident "border-box"] = Just self {boxSizing = BorderBox}
    longhand _ self "box-sizing" [Ident "initial"] = Just self {boxSizing = ContentBox}

    longhand _ self@CSSBox {cssBox = box} "padding-top" toks | Just x <- parseLength toks =
        Just self { cssBox = box { padding = (padding box) { top = x } } }
    longhand _ self@CSSBox {cssBox = box} "padding-bottom" toks | Just x <- parseLength toks =
        Just self { cssBox = box { padding = (padding box) { bottom = x } } }
    longhand _ self@CSSBox {cssBox = box} "padding-left" toks | Just x <- parseLength toks =
        Just self { cssBox = box { padding = (padding box) { left = x } } }
    longhand _ self@CSSBox {cssBox = box} "padding-right" toks | Just x <- parseLength toks =
        Just self { cssBox = box { padding = (padding box) { right = x } } }
    longhand _ self@CSSBox {cssBox = box} "border-top-width" toks | Just x <- parseLength toks =
        Just self { cssBox = box { border = (border box) { top = x } } }
    longhand _ self@CSSBox {cssBox = box} "border-bottom-width" toks | Just x <- parseLength toks =
        Just self { cssBox = box { border = (border box) { bottom = x } } }
    longhand _ self@CSSBox {cssBox = box} "border-left-width" toks | Just x <- parseLength toks =
        Just self { cssBox = box { border = (border box) { left = x } } }
    longhand _ self@CSSBox {cssBox = box} "border-right-width" toks | Just x <- parseLength toks =
        Just self { cssBox = box { border = (border box) { right = x } } }
    longhand _ self@CSSBox {cssBox = box} "margin-top" toks | Just x <- parseLength toks =
        Just self { cssBox = box { margin = (margin box) { top = x } } }
    longhand _ self@CSSBox {cssBox = box} "margin-bottom" toks | Just x <- parseLength toks =
        Just self { cssBox = box { margin = (margin box) { bottom = x } } }
    longhand _ self@CSSBox {cssBox = box} "margin-left" toks | Just x <- parseLength toks =
        Just self { cssBox = box { margin = (margin box) { left = x } } }
    longhand _ self@CSSBox {cssBox = box} "margin-right" toks | Just x <- parseLength toks =
        Just self { cssBox = box { margin = (margin box) { right = x } } }

    longhand _ self@CSSBox {cssBox = box} "width" toks | Just x <- parseLength' toks =
        Just self { cssBox = box { size = (size box) { inline = x } } }
    longhand _ self@CSSBox {cssBox = box} "height" toks | Just x <- parseLength' toks =
        Just self { cssBox = box { size = (size box) { block = x } } }
    longhand _ self@CSSBox {cssBox = box} "max-width" toks | Just x <- parseLength' toks =
        Just self { cssBox = box { B.max = (B.max box) { inline = x } } }
    longhand _ self@CSSBox {cssBox = box} "min-width" toks | Just x <- parseLength' toks =
        Just self { cssBox = box { B.min = (B.min box) { inline = x } } }
    longhand _ self@CSSBox {cssBox = box} "max-height" toks | Just x <- parseLength' toks =
        Just self { cssBox = box { B.max = (B.max box) { block = x } } }
    longhand _ self@CSSBox {cssBox = box} "min-height" toks | Just x <- parseLength' toks =
        Just self { cssBox = box { B.min = (B.min box) { block = x } } }

    longhand _ self "display" [Ident "block"] = Just self { display = Block }
    longhand _ self "display" [Ident "none"] = Just self { display = None }
    longhand _ self "display" [Ident "grid"] = Just self { display = Grid }
    {-longhand _ self "display" [Ident "table"] = Just self { display = Table }
    longhand CSSBox { display = Table } self "display" [Ident "table-row-group"] =
        Just self { display=TableRowGroup }
    longhand CSSBox { display = Table } self "display" [Ident "table-header-group"] =
        Just self { display = TableHeaderGroup }
    longhand CSSBox { display = Table } self "display" [Ident "table-footer-group"] =
        Just self { display = TableFooterGroup }
    longhand parent self "display" [Ident "table-row"] | rowContainer parent =
        Just self { display = TableRow }
    longhand CSSBox { display = TableRow } self "display" [Ident "table-cell"] =
        Just self { display = TableCell }
    longhand CSSBox { display = Table } self "display" [Ident "table-column-group"] =
        Just self { display = TableColumnGroup }
    longhand CSSBox { display = TableColumnGroup } self "display" [Ident "table-column"] =
        Just self { display = TableColumn }
    longhand CSSBox { display = Table } self "display" [Ident "table-caption"] =
        Just self { display=TableCaption } -}
    longhand _ self "display" [Ident "inline"] = Just self { display = Inline }
    longhand _ self "display" [Ident "initial"] = Just self { display = Inline }

    longhand _ self "caption-side" [Ident "top"] = Just self { captionBelow = False }
    longhand _ self "caption-side" [Ident "bottom"] = Just self { captionBelow = True }
    longhand _ self "caption-side" [Ident "initial"] = Just self {captionBelow = False}

    longhand _ self "orphans" [Number _ (NVInteger x)] =
        Just self { pageOptions = (pageOptions self) { pageOrphans = fromInteger x } }
    longhand _ self "widows" [Number _ (NVInteger x)] =
        Just self { pageOptions = (pageOptions self) { pageWidows = fromInteger x } }

    longhand a b c d | Just x <- longhand (font a) (font b) c d,
        Just y <- longhand (font' a) (font' b) c d =
            Just b { font = x, font' = y } -- Those properties can overlap!
    longhand a b c d | Just font' <- longhand (font a) (font b) c d = Just b {
        font = font'
      }
    longhand a b c d | Just font <- longhand (font' a) (font' b) c d = Just b {
        font' = font
      }
    longhand a b c d | Just inline' <- longhand (inlineStyles a) (inlineStyles b) c d =
        Just b { inlineStyles = inline' }
    longhand a b c d | Just grid' <- longhand (gridStyles a) (gridStyles b) c d =
        Just b { gridStyles = grid' }
    longhand a b c d | Just cell' <- longhand (cellStyles a) (cellStyles b) c d =
        Just b { cellStyles = cell' }
    longhand a b c d | Just inner' <- longhand (inner a) (inner b) c d = Just b {
        inner = inner'
      }

    -- Technically a grid shorthand, but we need parent data to parse it!
    longhand CSSBox { gridStyles = parent } self "grid-area" [Ident x]
        | Just ((colS, colE), (rowS, rowE)) <- x `HM.lookup` templateAreas parent
            = Just self { cellStyles = (cellStyles self) {
                columnStart = p colS,
                columnEnd = p colE,
                rowStart = p rowS,
                rowEnd = p $ fromMaybe (length $ templateAreas parent) rowE
            }}
      where p x = Numbered x Nothing

    longhand _ _ _ _ = Nothing

    shorthand self "font" toks = case parseOperands toks of
        (a:b:c:d:toks') | ret@(_:_) <- unordered [a,b,c,d] -> inner ret toks'
        (a:b:c:toks') | ret@(_:_) <- unordered [a,b,c] -> inner ret toks'
        (a:b:toks') | ret@(_:_) <- unordered [a,b] -> inner ret toks'
        (a:toks') | ret@(_:_) <- unordered [a] -> inner ret toks'
        toks' -> inner [] toks'
      where
        unordered operands = parseUnorderedShorthand' self [
            "font-style", "font-variant", "font-weight", "font-stretch"] operands
        inner ret (size:[Delim '/']:height:family)
            | Just _ <- longhand self self "font-size" size,
              Just _ <- longhand self self "line-height" height,
              Just _ <- longhand self self "font-family" $ concat family =
                ("font-size", size):("line-height", height):
                    ("font-family", concat family):ret
            | otherwise = []
        inner ret (size:family)
            | Just _ <- longhand self self "font-size" size,
              Just _ <- longhand self self "font-family" $ concat family =
                ("font-size", size):("line-height", [Ident "initial"]):
                    ("font-family", concat family):ret
            | otherwise = []
        inner _ _ = []
    shorthand self "margin" toks
        | length x > 0 && length x <= 4, all (validProp self "margin-top") x,
            (top:right:bottom:left:_) <- cycle x =
                [("margin-top", top), ("margin-right", right),
                 ("margin-bottom", bottom), ("margin-left", left)]
      where x = parseOperands toks
    shorthand self "padding" toks
        | length x > 0 && length x <= 4, all (validProp self "padding-top") x,
            (top:right:bottom:left:_) <- cycle x =
                [("padding-top", top), ("padding-right", right),
                 ("padding-bottom", bottom), ("padding-left", left)]
      where x = parseOperands toks
    shorthand self "border-width" toks
        | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x,
            all (validProp self "border-top-width") x =
                [("border-top-width", top), ("border-right-width", right),
                 ("border-bottom-width", bottom), ("border-left-width", left)]
      where x = parseOperands toks
    -- Define other border shorthands here to properly handle border-widths
    shorthand self "border" toks = parseUnorderedShorthand self [
        "border-color", "border-style", "border-width"] toks
    shorthand self "border-top" toks = parseUnorderedShorthand self [
        "border-top-color", "border-top-style", "border-top-width"] toks
    shorthand self "border-right" toks = parseUnorderedShorthand self [
        "border-right-color", "border-right-style", "border-right-width"] toks
    shorthand self "border-bottom" toks = parseUnorderedShorthand self [
        "border-bottom-color", "border-bottom-style", "border-bottom-width"] toks
    shorthand self "border-left" toks = parseUnorderedShorthand self [
        "border-left-color", "border-left-style", "border-left-width"] toks
    shorthand self "border-color" toks
        | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x,
            all (validProp self "border-top-color") x =
                [("border-top-color", top), ("border-right-color", right),
                 ("border-bottom-color", bottom), ("border-left-color", left)]
      where x = parseOperands toks
    shorthand self "border-style" toks
        | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x,
            all (validProp self "border-top-style") x =
                [("border-top-style", top), ("border-right-style", right),
                 ("border-bottom-style", bottom), ("border-left-style", left)]
      where x = parseOperands toks
    shorthand self "border-width" toks
        | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x,
            all (validProp self "border-top-width") x =
                [("border-top-width", top), ("border-right-width", right),
                 ("border-bottom-width", bottom), ("border-left-width", left)]
      where x = parseOperands toks

    shorthand self k v | Just _ <- longhand self self k v = [(k, v)]
    shorthand self k v | ret@(_:_) <- shorthand (font self) k v = ret
    shorthand self k v | ret@(_:_) <- shorthand (font' self) k v = ret
    shorthand self k v | ret@(_:_) <- shorthand (inlineStyles self) k v = ret
    shorthand self k v | ret@(_:_) <- shorthand (gridStyles self) k v = ret
    shorthand self k v | ret@(_:_) <- shorthand (cellStyles self) k v = ret
    shorthand self k v = shorthand (inner self) k v

validProp self key value = isJust $ longhand self self key value

-- | Desugar parsed CSS into more generic layout parameters.
finalizeCSS :: PropertyParser x => Font' -> Font' -> StyleTree (CSSBox x) ->
        LayoutItem Length Length x
finalizeCSS root parent StyleTree { style = self'@CSSBox { display = None } } =
    LayoutFlow (inner self') lengthBox []
finalizeCSS root parent self@StyleTree {
    style = self'@CSSBox { display = Grid, inner = val }, children = childs
  } = LayoutFlow val (finalizeBox self' font_) [
        finalizeGrid (gridStyles self') font_ (map cellStyles $ map style childs)
            (finalizeChilds root font_ (inner self') childs)]
  where
    font_ = pattern2font (font self') (font' self') parent root
finalizeCSS root parent self@StyleTree {
        style = self'@CSSBox { display = Table, captionBelow = False }, children = childs
    } = LayoutFlow (inner self') (finalizeBox self' font_)
        ([finalizeCSS root font_ child { style = child' { display = Block } }
            | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs] ++
        [finalizeTable root font_ (inner self') childs])
  where
    font_ = pattern2font (font self') (font' self') parent root
finalizeCSS root parent self@StyleTree {
        style = self'@CSSBox { display = Table, captionBelow = True }, children = childs
    } = LayoutFlow (inner self') (finalizeBox self' font_)
        (finalizeTable root font_ temp childs:
        [finalizeCSS root font_ child { style = child' { display = Block } }
            | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs])
  where
    font_ = pattern2font (font self') (font' self') parent root
finalizeCSS root parent self@StyleTree {
    style = self'@CSSBox { inner = val }, children = childs
  } = LayoutFlow val (finalizeBox self' font_) (finalizeChilds root font_ val childs)
  where
    font_ = pattern2font (font self') (font' self') parent root
finalizeCSS' sysfont self@StyleTree { style = self' } =
    finalizeCSS (pattern2font (font self') (font' self') sysfont sysfont) sysfont self

-- | Desugar a sequence of child nodes, taking care to capture runs of inlines.
finalizeChilds :: PropertyParser x => Font' -> Font' -> x -> [StyleTree (CSSBox x)] ->
        [LayoutItem Length Length x]
finalizeChilds root parent style' (StyleTree { style = CSSBox { display = None } }:childs) =
    finalizeChilds root parent style' childs
finalizeChilds root parent style' childs@(child:childs')
    | isInlineTree childs, Just self <- finalizeParagraph (flattenTree childs) parent =
        -- FIXME propagate display properties, how to handle the hierarchy.
        -- NOTE: Playing around in firefox, it appears the CSS borders should cover
        -- their entire span, doubling up on borders where needed.
        [LayoutInline (inherit style') parent self paging (repeat $ inherit style')]
    | (inlines@(_:_), blocks) <- spanInlines childs,
        Just self <- finalizeParagraph (flattenTree inlines) parent  =
            LayoutInline (inherit style') parent self paging (repeat $ inherit style') :
                finalizeChilds root parent style' blocks
    | (StyleTree { style = CSSBox { display = Inline } }:childs') <- childs =
        finalizeChilds root parent style' childs' -- Inline's all whitespace...
    | otherwise = finalizeCSS root parent child : finalizeChilds root parent style' childs'
  where
    paging = pageOptions $ style child
    isInlineTree = all isInlineTree0
    isInlineTree0 StyleTree { style = CSSBox { display = Inline }, children = childs } =
        isInlineTree childs
    isInlineTree0 _ = False
    spanInlines childs = case span isInlineTree0 childs of
        (inlines, (StyleTree {
            style = CSSBox { display = Inline }, children = tail
          }:blocks)) -> let (inlines', blocks') = spanInlines tail
            in (inlines ++ inlines', blocks' ++ blocks)
        ret -> ret
    flattenTree (StyleTree { children = child@(_:_) }:childs) =
        flattenTree child `concatParagraph` flattenTree childs
    flattenTree (child:childs) =
        buildParagraph (inlineStyles $ style child) `concatParagraph` flattenTree childs
    flattenTree [] = ParagraphBuilder "" []
finalizeChilds _ _ _ [] = []

-- | Desugar most units, possibly in reference to given font.
finalizeBox self@CSSBox { cssBox = box } font_ =
    mapY' (flip finalizeLength font_) $ mapX' (flip finalizeLength font_) box

-- | (Unused, incomplete) Desugar a styletree of table elements to a grid layout.
finalizeTable root parent val childs = LayoutFlow val lengthBox [] -- Placeholder!
{- finalizeTable root parent val childs = LayoutGrid val grid $ zip cells' childs'
  where -- FIXME? How to handle non-table items in <table>?
    grid = Grid {
        rows = take width $ repeat ("", (0,"auto")),
        rowBounds = [],
        subgridRows = 0,
        columns = take height $ repeat ("", (0,"auto")),
        colBounds = [],
        subgridCols = 0,
        gap = Size (0,"px") (0,"px"), -- FIXME where to get this from?
        containerSize = Size Auto Auto, -- Proper size is set on parent.
        containerMin = Size Auto Auto,
        containerMax = Size Auto Auto
    }
    cells' = adjustWidths cells
    
    (cells, width, height) = lowerCells childs
    lowerCells (StyleTree self@CSSBox { display = TableRow } cells:rest) =
        (row:rows, max rowwidth width', succ height)
      where
        (row, rowwidth) = lowerRow cells 0 -- FIXME: How to dodge colspans?
        (rows, width', height') = lowerCells rest
    lowerCells (StyleTree self@CSSBox { display = TableHeaderGroup } childs ) =
        -}