{-# LANGUAGE OverloadedStrings #-}
module Graphics.Layout.CSS.Parse (
    CSSBox(..), direction, txtOpts, BoxSizing(..), Display(..)) where
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Stylist (PropertyParser(..), TrivialPropertyParser, parseOperands,
                parseUnorderedShorthand', parseUnorderedShorthand)
import Data.Text.ParagraphLayout (PageOptions(..))
import Data.Text.ParagraphLayout.Rich (textDirection, ParagraphOptions,
            defaultParagraphOptions, paragraphAlignment, ParagraphAlignment(..))
import Data.Text.Glyphize (Direction(..))

import Graphics.Layout.Box as B
import Graphics.Text.Font.Choose (Pattern, unset)
import Graphics.Layout.CSS.Length (Unitted, parseLength', parseLength, auto)
import Graphics.Layout.CSS.Font (CSSFont)
import Graphics.Layout.Grid.CSS (CSSGrid(..), CSSCell(..), Placement(..))
import Graphics.Layout.Inline.CSS (CSSInline(..))

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,
    -- | Parsed text-alignment & other options which applies per-paragraph.
    paragraphOptions :: ParagraphOptions
}
-- | Accessor for inlineStyle's `textDirection` attribute.
direction CSSBox { inlineStyles = CSSInline _ opts _ } = textDirection opts
-- | Accessor for inlineStyle's options.
txtOpts CSSBox { inlineStyles = CSSInline _ opts _ } = opts
-- | 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,
        paragraphOptions = defaultParagraphOptions {
            paragraphAlignment = AlignStart
        }
      }
    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,
        paragraphOptions = paragraphOptions 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} "padding-inline-start" toks
        | Just x <- parseLength toks, DirLTR <- direction self =
            Just self { cssBox = box { padding = (padding box) { left = x } } }
        | Just x <- parseLength toks, DirRTL <- direction self =
            Just self { cssBox = box { padding = (padding box) { right = x } } }
    longhand _ self@CSSBox {cssBox = box} "padding-inline-end" toks
        | Just x <- parseLength toks, DirLTR <- direction self =
            Just self { cssBox = box { padding = (padding box) { right = x } } }
        | Just x <- parseLength toks, DirRTL <- direction self =
            Just self { cssBox = box { padding = (padding box) { left = 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 p self "border-inline-start-color" toks
        | DirLTR <- direction self = longhand p self "border-left-color" toks
        | DirRTL <- direction self = longhand p self "border-right-color" toks
    longhand p self "border-inline-start-width" toks
        | DirLTR <- direction self = longhand p self "border-left-width" toks
        | DirRTL <- direction self = longhand p self "border-right-width" toks
    longhand p self "border-inline-start-style" toks
        | DirLTR <- direction self = longhand p self "border-left-style" toks
        | DirRTL <- direction self = longhand p self "border-right-style" toks
    longhand p self "border-inline-end-color" toks
        | DirLTR <- direction self = longhand p self "border-right-color" toks
        | DirRTL <- direction self = longhand p self "border-left-color" toks
    longhand p self "border-inline-end-width" toks
        | DirLTR <- direction self = longhand p self "border-right-width" toks
        | DirRTL <- direction self = longhand p self "border-left-width" toks
    longhand p self "border-inline-end-style" toks
        | DirLTR <- direction self = longhand p self "border-right-style" toks
        | DirRTL <- direction self = longhand p self "border-left-style" toks
    longhand p self "border-start-start-radius" t
        | DirLTR <- direction self = longhand p self "border-top-left-radius" t
        | DirRTL <- direction self = longhand p self "border-top-right-radius" t
    longhand p self "border-start-end-radius" t
        | DirLTR <- direction self = longhand p self "border-top-right-radius" t
        | DirRTL <- direction self = longhand p self "border-top-left-radius" t
    longhand p s "border-end-start-radius" t
        | DirLTR <- direction s = longhand p s "border-bottom-left-radius" t
        | DirRTL <- direction s = longhand p s "border-bottom-right-radius" t
    longhand p s "border-end-end-radius" t
        | DirLTR <- direction s = longhand p s "border-bottom-right-radius" t
        | DirRTL <- direction s = longhand p s "border-bottom-left-radius" t

    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} "margin-inline-start" toks
        | Just x <- parseLength toks, DirLTR <- direction self =
            Just self { cssBox = box { margin = (margin box) { left = x } } }
        | Just x <- parseLength toks, DirRTL <- direction self =
            Just self { cssBox = box { margin = (margin box) { right = x } } }
    longhand _ self@CSSBox {cssBox = box} "margin-inline-end" toks
        | Just x <- parseLength toks, DirLTR <- direction self =
            Just self { cssBox = box { margin = (margin box) { right = x } } }
        | Just x <- parseLength toks, DirRTL <- direction self =
            Just self { cssBox = box { margin = (margin box) { left = x } } }

    -- Placeholder implementations until vertical text is implemented.
    longhand p self "padding-block-start" t = longhand p self "padding-top" t
    longhand p self "padding-block-end" t = longhand p self "padding-bottom" t
    longhand p self "margin-block-start" t = longhand p self "margin-top" t
    longhand p self "margin-block-end" t = longhand p self "margin-bottom" t
    longhand p self "border-block-start-color" toks =
        longhand p self "border-top-color" toks
    longhand p self "border-block-start-style" toks =
        longhand p self "border-top-style" toks
    longhand p self "border-block-start-width" toks =
        longhand p self "border-top-width" toks
    longhand p s "border-block-end-color" t = longhand p s "border-bottom-color" t
    longhand p s "border-block-end-style" t = longhand p s "border-bottom-style" t
    longhand p s "border-block-end-width" t = longhand p s "border-bottom-width" t

    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 _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "initial"] =
        Just self { paragraphOptions = o { paragraphAlignment = AlignStart } }
    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "start"] =
        Just self { paragraphOptions = o { paragraphAlignment = AlignStart } }
    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "end"] =
        Just self { paragraphOptions = o { paragraphAlignment = AlignEnd } }
    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "left"] =
        Just self { paragraphOptions = o { paragraphAlignment = AlignLeft } }
    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "right"] =
        Just self { paragraphOptions = o { paragraphAlignment = AlignRight } }
    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "center"] =
        Just self { paragraphOptions = o { paragraphAlignment = AlignCentreH } }
    -- text-align: justify is unimplemented.
    longhand p self@CSSBox { paragraphOptions = o } "text-align"
            [Ident "match-parent"] = case paragraphAlignment$paragraphOptions p of
        AlignStart | DirLTR <- direction p -> ret AlignLeft
        AlignStart | DirRTL <- direction p -> ret AlignRight
        AlignEnd | DirLTR <- direction p -> ret AlignRight
        AlignEnd | DirRTL <- direction p -> ret AlignLeft
        x -> ret x
      where ret x = Just self { paragraphOptions = o { paragraphAlignment = x } }

    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-inline" toks = parseUnorderedShorthand self [
        "border-inline-color", "border-inline-style", "border-inline-width"] toks
    shorthand self "border-inline-start" toks = parseUnorderedShorthand self [
        "border-inline-start-color", "border-inline-start-style",
        "border-inline-start-width"] toks
    shorthand self "border-inline-end" toks = parseUnorderedShorthand self [
        "border-inline-end-color", "border-inline-end-style",
        "border-inline-end-width"] toks
    shorthand self "border-block" toks = parseUnorderedShorthand self [
        "border-block-color", "border-block-style", "border-block-width"] toks
    shorthand self "border-block-start" toks = parseUnorderedShorthand self [
        "border-block-start-color", "border-block-start-style",
        "border-block-start-width"] toks
    shorthand self "border-block-end" toks = parseUnorderedShorthand self [
        "border-block-end-color", "border-block-end-style",
        "border-block-end-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 "border-inline-color" toks
        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
            all (validProp self "border-inline-start-color") x =
                [("border-inline-start-color", s), ("border-inline-end-color", e)]
      where x = parseOperands toks
    shorthand self "border-inline-style" toks
        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
            all (validProp self "border-inline-start-style") x =
                [("border-inline-start-style", s), ("border-inline-end-style", e)]
      where x = parseOperands toks
    shorthand self "border-inline-width" toks
        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
            all (validProp self "border-inline-start-width") x =
                [("border-inline-start-width", s), ("border-inline-end-style", e)]
      where x = parseOperands toks
    shorthand self "border-block-color" toks
        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
            all (validProp self "border-block-start-color") x =
                [("border-block-start-color", s), ("border-block-end-color", e)]
      where x = parseOperands toks
    shorthand self "border-block-style" toks
        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
            all (validProp self "border-block-start-style") x =
                [("border-block-start-style", s), ("border-block-end-style", e)]
      where x = parseOperands toks
    shorthand self "border-block-width" toks
        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
            all (validProp self "border-block-start-width") x =
                [("border-block-start-width", s), ("border-block-end-width", e)]
      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