{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
-- | Datastructures for parsing table styling properties,
-- & for positioning cells into Grid layout regions.
module Graphics.Layout.Grid.Table where

import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Stylist (PropertyParser(..))
import Graphics.Layout.CSS.Length (Unitted, parseLength, Font', finalizeLength)
import Graphics.Layout.Box (Length(..), PaddedBox(..), zero, mapX, mapY)
import Graphics.Layout.Grid (Alignment(..))
import Data.Text.Glyphize (Direction(..))
import Data.Text.ParagraphLayout.Rich (
        ParagraphOptions(..), ParagraphAlignment(..))

import Text.Read (readMaybe)
import Data.Text (unpack)

-- | Tracks `rowspan` attributes so later rows can dodge it.
type Overflowed = [Int]

-- | A row with no cells overflowing into it.
emptyRow :: Overflowed
emptyRow :: [Int]
emptyRow = []

-- | Decrement all `rowspan`s being overflowed, removing 0'd ones.
commitRow :: Overflowed -> Overflowed
commitRow :: [Int] -> [Int]
commitRow = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int) -> [Int] -> [Int]) -> (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
Prelude.max Int
0 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
pred

-- | Find the next column which a previous multi-row cell hasn't called "dibs" on.
allocCol :: Int -> Overflowed -> Int
allocCol :: Int -> [Int] -> Int
allocCol Int
ix [Int]
cols = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([Int], [Int]) -> Int
forall a. ([Int], a) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ([Int] -> ([Int], [Int])) -> [Int] -> ([Int], [Int])
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
ix [Int]
cols)

-- | Splice a newly-allocated cell covernig `colspan` (2nd arg) & `rowspan` (3rd arg)
-- from "ix" (from 1st arg) into the final arg.
insertCell :: Int -> Int -> Int -> Overflowed -> Overflowed
insertCell :: Int -> Int -> Int -> [Int] -> [Int]
insertCell Int
ix Int
colspan Int
rowspan [Int]
cols = [Int]
before [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int] -> [Int]
inner Int
colspan [Int]
after
  where
    ([Int]
before, [Int]
after) = Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
ix [Int]
cols
    inner :: Int -> [Int] -> [Int]
inner Int
x [Int]
cols' | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Int]
cols'
    inner Int
colspan (Int
col:[Int]
cols') = Int -> Int -> Int
forall a. Ord a => a -> a -> a
Prelude.max Int
col Int
rowspanInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:Int -> [Int] -> [Int]
inner (Int -> Int
forall a. Enum a => a -> a
pred Int
colspan) [Int]
cols'
    inner Int
x [] = Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
x Int
colspan

-- | Parsed CSS properties & HTML attributes for laying out "table" elements.
-- To parse HTML attributes, expects the following useragent stylesheet rules:
--
-- [rowspan] { -argo-rowspan: attr(rowspan) }
-- [colspan] { -argo-colspan: attr(colspan) }
data TableOptions = TableOptions {
    -- | HTML rowspan attribute
    TableOptions -> Int
rowspan :: Int,
    -- | HTML colspan attribute
    TableOptions -> Int
colspan :: Int,
    -- | Parsed CSS caption-side.
    TableOptions -> Bool
captionBelow :: Bool,
    -- | Parsed CSS border-collapse
    TableOptions -> Bool
borderCollapse :: Bool,
    -- | Semi-parsed border-spacing, horizontal axis
    TableOptions -> Unitted
borderHSpacing :: Unitted,
    -- | Semi-parsed border-spacing, vertical axis
    TableOptions -> Unitted
borderVSpacing :: Unitted,
    -- TODO: Implement `table-layout: fixed`, that needs its own layout formula...
    -- | Parsed CSS vertical-align
    TableOptions -> Unitted
verticalAlign :: Unitted
}

instance PropertyParser TableOptions where
    temp :: TableOptions
temp = TableOptions {
        rowspan :: Int
rowspan = Int
1, colspan :: Int
colspan = Int
1,
        captionBelow :: Bool
captionBelow = Bool
False, borderCollapse :: Bool
borderCollapse = Bool
False,
        borderHSpacing :: Unitted
borderHSpacing = (Double
0,Text
"px"), borderVSpacing :: Unitted
borderVSpacing = (Double
0,Text
"px"),
        verticalAlign :: Unitted
verticalAlign = (Double
0,Text
"baseline")
    }
    inherit :: TableOptions -> TableOptions
inherit = TableOptions -> TableOptions
forall a. a -> a
id

    longhand :: TableOptions
-> TableOptions -> Text -> [Token] -> Maybe TableOptions
longhand TableOptions
_ TableOptions
self Text
"-argo-rowspan" [Ident Text
"initial"] = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { rowspan :: Int
rowspan = Int
1 }
    longhand TableOptions
_ TableOptions
self Text
"-argo-rowspan" [String Text
x]
        | Just Int
y <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
x, Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { rowspan :: Int
rowspan = Int
y }
    longhand TableOptions
_ TableOptions
self Text
"-argo-rowspan" [Number Text
_ (NVInteger Integer
x)]
        | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1 = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { rowspan :: Int
rowspan = Integer -> Int
forall a. Enum a => a -> Int
fromEnum Integer
x }
    longhand TableOptions
_ TableOptions
self Text
"-argo-colspan" [Ident Text
"initial"] = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { colspan :: Int
colspan = Int
1 }
    longhand TableOptions
_ TableOptions
self Text
"-argo-colspan" [String Text
x]
        | Just Int
y <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
x, Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { colspan :: Int
colspan = Int
y }
    longhand TableOptions
_ TableOptions
self Text
"-argo-colspan" [Number Text
_ (NVInteger Integer
x)]
        | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1 = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { colspan :: Int
colspan = Integer -> Int
forall a. Enum a => a -> Int
fromEnum Integer
x }

    longhand TableOptions
_ TableOptions
self Text
"caption-side" [Ident Text
"top"] = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { captionBelow :: Bool
captionBelow = Bool
False }
    longhand TableOptions
_ TableOptions
self Text
"caption-side" [Ident Text
"bottom"] = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { captionBelow :: Bool
captionBelow = Bool
True }
    longhand TableOptions
_ TableOptions
self Text
"caption-side" [Ident Text
"initial"] = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self {captionBelow :: Bool
captionBelow = Bool
False}

    longhand TableOptions
_ TableOptions
self Text
"border-collapse" [Ident Text
"collapse"] =
        TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { borderCollapse :: Bool
borderCollapse = Bool
True }
    longhand TableOptions
_ TableOptions
self Text
"border-collapse" [Ident Text
"separate"] =
        TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { borderCollapse :: Bool
borderCollapse = Bool
False }
    longhand TableOptions
_ TableOptions
self Text
"border-collapse" [Ident Text
"initial"] =
        TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { borderCollapse :: Bool
borderCollapse = Bool
False }

    longhand TableOptions
_ TableOptions
self Text
"border-spacing" v :: [Token]
v@[Dimension Text
_ NumericValue
_ Text
_] | Just Unitted
x <- [Token] -> Maybe Unitted
parseLength [Token]
v =
        TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { borderHSpacing :: Unitted
borderHSpacing = Unitted
x, borderVSpacing :: Unitted
borderVSpacing = Unitted
x }
    longhand TableOptions
_ TableOptions
self Text
"border-spacing" [x :: Token
x@(Dimension Text
_ NumericValue
_ Text
_), y :: Token
y@(Dimension Text
_ NumericValue
_ Text
_)]
            | Just Unitted
x' <- [Token] -> Maybe Unitted
parseLength [Token
x], Just Unitted
y' <- [Token] -> Maybe Unitted
parseLength [Token
y] =
        TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { borderHSpacing :: Unitted
borderHSpacing = Unitted
x', borderVSpacing :: Unitted
borderVSpacing = Unitted
y' }
    longhand TableOptions
_ TableOptions
self Text
"border-spacing" [Ident Text
"initial"] =
        TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { borderHSpacing :: Unitted
borderHSpacing = (Double
0,Text
"px"), borderVSpacing :: Unitted
borderVSpacing = (Double
0,Text
"px") }

    longhand TableOptions
_ TableOptions
self Text
"vertical-align" [Ident Text
x]
        | Text
x Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"baseline", Text
"sub", Text
"super", Text
"text-top", Text
"text-bottom",
            Text
"middle", Text
"top", Text
"bottom"] = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { verticalAlign :: Unitted
verticalAlign = (Double
0,Text
x) }
        | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"initial" = TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { verticalAlign :: Unitted
verticalAlign = (Double
0,Text
"baseline") }
        | Bool
otherwise = Maybe TableOptions
forall a. Maybe a
Nothing
    longhand TableOptions
_ TableOptions
self Text
"vertical-align" [Token]
v | Just Unitted
x <- [Token] -> Maybe Unitted
parseLength [Token]
v =
        TableOptions -> Maybe TableOptions
forall a. a -> Maybe a
Just TableOptions
self { verticalAlign :: Unitted
verticalAlign = Unitted
x }

    longhand TableOptions
_ TableOptions
_ Text
_ [Token]
_ = Maybe TableOptions
forall a. Maybe a
Nothing

-- | Resolve any units in the "border-spacing" property according to the given font.
-- If "border-collapse" is set, removes this spacing.
finalizeGap :: TableOptions -> Font' -> (Length, Length)
finalizeGap :: TableOptions -> Font' -> (Length, Length)
finalizeGap TableOptions { borderCollapse :: TableOptions -> Bool
borderCollapse = Bool
True } Font'
_ = (Double -> Length
Pixels Double
0, Double -> Length
Pixels Double
0)
finalizeGap TableOptions { borderHSpacing :: TableOptions -> Unitted
borderHSpacing = Unitted
x, borderVSpacing :: TableOptions -> Unitted
borderVSpacing = Unitted
y } Font'
font =
    (Unitted -> Font' -> Length
finalizeLength Unitted
x Font'
font, Unitted -> Font' -> Length
finalizeLength Unitted
y Font'
font)

-- | Shorthand for a padded box without its CSS units resolved, simplifies type signatures.
type UPaddedBox = PaddedBox Unitted Unitted
-- | Removes margins & halves borders if "border-collapse" is set,
-- as per the CSS specification. Apply this on the table cells, rows, & columns.
collapseBorders :: TableOptions -> UPaddedBox -> UPaddedBox
collapseBorders :: TableOptions -> UPaddedBox -> UPaddedBox
collapseBorders TableOptions { borderCollapse :: TableOptions -> Bool
borderCollapse = Bool
False } UPaddedBox
ret = UPaddedBox
ret
collapseBorders TableOptions
_ UPaddedBox
box = UPaddedBox
box {
    margin :: Border Unitted Unitted
margin = Border Unitted Unitted
forall a. Zero a => a
zero,
    border :: Border Unitted Unitted
border = (Unitted -> Unitted)
-> Border Unitted Unitted -> Border Unitted Unitted
forall n nn m. (n -> nn) -> Border m n -> Border m nn
mapX Unitted -> Unitted
forall {a} {b}. Fractional a => (a, b) -> (a, b)
half (Border Unitted Unitted -> Border Unitted Unitted)
-> Border Unitted Unitted -> Border Unitted Unitted
forall a b. (a -> b) -> a -> b
$ (Unitted -> Unitted)
-> Border Unitted Unitted -> Border Unitted Unitted
forall m mm n. (m -> mm) -> Border m n -> Border mm n
mapY Unitted -> Unitted
forall {a} {b}. Fractional a => (a, b) -> (a, b)
half (Border Unitted Unitted -> Border Unitted Unitted)
-> Border Unitted Unitted -> Border Unitted Unitted
forall a b. (a -> b) -> a -> b
$ UPaddedBox -> Border Unitted Unitted
forall m n. PaddedBox m n -> Border m n
border UPaddedBox
box
  }
-- | Removes padding & halves borders if "border-collapse" is set,
-- as per the CSS specification. Apply this on the table itself.
collapseTBorders :: TableOptions -> UPaddedBox -> UPaddedBox
collapseTBorders :: TableOptions -> UPaddedBox -> UPaddedBox
collapseTBorders TableOptions { borderCollapse :: TableOptions -> Bool
borderCollapse = Bool
False } UPaddedBox
ret = UPaddedBox
ret
collapseTBorders TableOptions
_ UPaddedBox
box = UPaddedBox
box {
    padding :: Border Unitted Unitted
padding = Border Unitted Unitted
forall a. Zero a => a
zero,
    border :: Border Unitted Unitted
border = (Unitted -> Unitted)
-> Border Unitted Unitted -> Border Unitted Unitted
forall n nn m. (n -> nn) -> Border m n -> Border m nn
mapX Unitted -> Unitted
forall {a} {b}. Fractional a => (a, b) -> (a, b)
half (Border Unitted Unitted -> Border Unitted Unitted)
-> Border Unitted Unitted -> Border Unitted Unitted
forall a b. (a -> b) -> a -> b
$ (Unitted -> Unitted)
-> Border Unitted Unitted -> Border Unitted Unitted
forall m mm n. (m -> mm) -> Border m n -> Border mm n
mapY Unitted -> Unitted
forall {a} {b}. Fractional a => (a, b) -> (a, b)
half (Border Unitted Unitted -> Border Unitted Unitted)
-> Border Unitted Unitted -> Border Unitted Unitted
forall a b. (a -> b) -> a -> b
$ UPaddedBox -> Border Unitted Unitted
forall m n. PaddedBox m n -> Border m n
border UPaddedBox
box
  }
-- | Helper for halving a unit.
half :: (a, b) -> (a, b)
half (a
x,b
u) = (a
xa -> a -> a
forall a. Fractional a => a -> a -> a
/a
2,b
u)

-- | Lower vertical alignment to grid alignment options.
finalizeVAlign :: TableOptions -> Alignment
finalizeVAlign :: TableOptions -> Alignment
finalizeVAlign TableOptions { verticalAlign :: TableOptions -> Unitted
verticalAlign = (Double
_,Text
"top") } = Alignment
Start
finalizeVAlign TableOptions { verticalAlign :: TableOptions -> Unitted
verticalAlign = (Double
_,Text
"middle") } = Alignment
Mid
finalizeVAlign TableOptions { verticalAlign :: TableOptions -> Unitted
verticalAlign = (Double
_,Text
"bottom") } = Alignment
End
finalizeVAlign TableOptions
_ = Alignment
Start -- FIXME: Support baseline alignment!
-- | Lower text alignment to grid alignment.
finalizeHAlign :: ParagraphOptions -> Direction -> Alignment
finalizeHAlign :: ParagraphOptions -> Direction -> Alignment
finalizeHAlign (ParagraphOptions -> ParagraphAlignment
paragraphAlignment -> ParagraphAlignment
AlignStart) Direction
_ = Alignment
Start
finalizeHAlign (ParagraphOptions -> ParagraphAlignment
paragraphAlignment -> ParagraphAlignment
AlignEnd) Direction
_ = Alignment
End
finalizeHAlign (ParagraphOptions -> ParagraphAlignment
paragraphAlignment -> ParagraphAlignment
AlignLeft) Direction
DirLTR = Alignment
Start
finalizeHAlign (ParagraphOptions -> ParagraphAlignment
paragraphAlignment -> ParagraphAlignment
AlignLeft) Direction
_ = Alignment
End
finalizeHAlign (ParagraphOptions -> ParagraphAlignment
paragraphAlignment -> ParagraphAlignment
AlignRight) Direction
DirLTR = Alignment
End
finalizeHAlign (ParagraphOptions -> ParagraphAlignment
paragraphAlignment -> ParagraphAlignment
AlignRight) Direction
_ = Alignment
Start
finalizeHAlign (ParagraphOptions -> ParagraphAlignment
paragraphAlignment -> ParagraphAlignment
AlignCentreH) Direction
_ = Alignment
Mid