cattrap 0.1.0.0 → 0.2.0.0

raw patch · 12 files changed

+1026/−375 lines, 12 filesdep +unordered-containersdep ~balkondep ~basedep ~stylist-traitsPVP ok

version bump matches the API change (PVP)

Dependencies added: unordered-containers

Dependency ranges changed: balkon, base, stylist-traits

API changes (from Hackage documentation)

Files

• Graphics/Layout.hs +100/−72
• Graphics/Layout/Box.hs +10/−2
• Graphics/Layout/CSS.hs +44/−191
• Graphics/Layout/CSS/Font.hs +4/−6
• Graphics/Layout/CSS/Length.hs +5/−0
• Graphics/Layout/CSS/Parse.hs +404/−0
• Graphics/Layout/Grid/CSS.hs +154/−9
• Graphics/Layout/Inline.hs +185/−47
• Graphics/Layout/Inline/CSS.hs +93/−41
• app/Main.hs +3/−2
• cattrap.cabal +5/−5
• test/Test.hs +19/−0

@@ -4,21 +4,22 @@ -- Attempts to follow the CSS specs. -- See `boxLayout` for a main entrypoint, -- & `Graphics.Layout.CSS` to receive CSS input.-module Graphics.Layout(LayoutItem(..),+module Graphics.Layout(LayoutItem(..), UserData,         layoutGetBox, layoutGetChilds, layoutGetInner,         boxMinWidth, boxMaxWidth, boxNatWidth, boxWidth,         boxNatHeight, boxMinHeight, boxMaxHeight, boxHeight,-        boxSplit, boxPaginate, boxPosition, boxLayout, glyphsPerFont) where+        boxSplit, boxPaginate, boxPosition, boxLayout{-, glyphsPerFont-}) where -import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..), Fragment(..),-        ParagraphLayout(..), PageOptions(..), PageContinuity(..), paginate, layoutPlain)-import Stylist (PropertyParser(..))+import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),+                                ParagraphLayout(..), layoutRich)+import Data.Text.ParagraphLayout (paginate, PageContinuity(..), PageOptions(..))+import Stylist (PropertyParser(temp))  import Graphics.Layout.Box as B import Graphics.Layout.Grid as G import Graphics.Layout.Flow as F import Graphics.Layout.Inline as I-import Graphics.Layout.CSS.Font (Font'(..))+import Graphics.Layout.CSS.Font (Font')  import Data.Maybe (fromMaybe) @@ -28,6 +29,9 @@ import qualified Data.Text.Glyphize as Hb import Graphics.Text.Font.Choose (Pattern) +-- | Additional data routed through Balkon.+type UserData m n x = ((Font', Int), PaddedBox m n, x)+ -- | A tree of different layout algorithms. -- More to come... data LayoutItem m n x =@@ -35,13 +39,16 @@     LayoutFlow x (PaddedBox m n) [LayoutItem m n x]     -- | A grid or table element.     | LayoutGrid x (Grid m n) [GridItem] [LayoutItem m n x]-    -- | Some richtext.-    | LayoutInline x Font' Paragraph PageOptions [x] -- Balkon holds children.+    -- | Some richtext. (Balkón holds children)+    | LayoutInline x (Paragraph (UserData m n x)) PageOptions     -- | Results laying out richtext, has fixed width.     -- Generated from `LayoutInline` for the sake of pagination.-    | LayoutInline' x Font' ParagraphLayout PageOptions [x]+    | LayoutInline' x (ParagraphLayout (UserData m n x)) PageOptions+    -- | A branch with constant bounding box.+    -- Generated from `LayoutInline` when attaching position info.+    | LayoutConst x (PaddedBox m n) [LayoutItem m n x]     -- | Children of a `LayoutInline` or `LayoutInline'`.-    | LayoutSpan x Font' Fragment+    | LayoutSpan (FragmentTree (UserData m n x)) -- | An empty box. nullLayout :: (PropertyParser x, Zero m, Zero n) => LayoutItem m n x nullLayout = LayoutFlow temp zero []@@ -58,29 +65,28 @@     B.max = Size (fromDouble $ trackNat toDouble $ inline self)             (fromDouble $ trackNat toDouble $ block self) }-layoutGetBox (LayoutInline _ f self _ _) = zero {-    B.min = inlineMin f self, B.size = inlineSize f self, B.max = inlineSize f self-}-layoutGetBox (LayoutInline' _ f self _ _) = zero {-    B.min = layoutSize f self, B.size = layoutSize f self, B.max = layoutSize f self+layoutGetBox (LayoutInline _ self _) = zero {+    B.min = inlineMin self, B.size = inlineSize self, B.max = inlineSize self }-layoutGetBox (LayoutSpan _ f self) = zero {-    B.min = fragmentSize f self, B.size = fragmentSize f self, B.max = fragmentSize f self+layoutGetBox (LayoutInline' _ self _) = zero {+    B.min = layoutSize self, B.size = layoutSize self, B.max = layoutSize self }+layoutGetBox (LayoutSpan self) = treeBox self+layoutGetBox (LayoutConst _ ret _) = ret -- | Retrieve the subtree under a node. layoutGetChilds (LayoutFlow _ _ ret) = ret layoutGetChilds (LayoutGrid _ _ _ ret) = ret-layoutGetChilds (LayoutSpan _ _ _) = []-layoutGetChilds (LayoutInline _ font self _ vals) = map inner $ inlineChildren vals self-  where inner (val, fragment) = LayoutSpan val font fragment-layoutGetChilds (LayoutInline' _ font self _ vals) = map inner $ layoutChildren vals self-  where inner (val, fragment) = LayoutSpan val font fragment+layoutGetChilds (LayoutSpan _) = []+layoutGetChilds (LayoutInline _ self _) = map LayoutSpan $ inlineChildren self+layoutGetChilds (LayoutInline' _ self _) = map LayoutSpan $ layoutChildren self+layoutGetChilds (LayoutConst _ _ childs) = childs -- | Retrieve the caller-specified data attached to a layout node. layoutGetInner (LayoutFlow ret _ _) = ret layoutGetInner (LayoutGrid ret _ _ _) = ret-layoutGetInner (LayoutInline ret _ _ _ _) = ret-layoutGetInner (LayoutInline' ret _ _ _ _) = ret-layoutGetInner (LayoutSpan ret _ _) = ret+layoutGetInner (LayoutInline ret _ _) = ret+layoutGetInner (LayoutInline' ret _ _) = ret+layoutGetInner (LayoutConst ret _ _) = ret+layoutGetInner (LayoutSpan x) = treeInner x  -- | map-ready wrapper around `setCellBox` sourcing from a child node. setCellBox' (child, cell) = setCellBox cell $ layoutGetBox child@@ -107,9 +113,11 @@     parent' = fromMaybe (gridEstWidth self cells0) parent     zeroBox :: PaddedBox Double Double     zeroBox = zero-boxMinWidth _ self@(LayoutInline _ _ _ _ _) = self-boxMinWidth _ self@(LayoutInline' _ _ _ _ _) = self-boxMinWidth _ self@(LayoutSpan _ _ _) = self+boxMinWidth _ self@(LayoutInline _ _ _) = self+boxMinWidth _ self@(LayoutInline' _ _ _) = self+boxMinWidth _ (LayoutConst val self' childs) =+    LayoutConst val self' $ map (boxMinWidth Nothing) childs+boxMinWidth _ self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache ideal width. boxNatWidth :: (Zero y, CastDouble y) =>         Maybe Double -> LayoutItem y Length x -> LayoutItem y Length x@@ -132,9 +140,11 @@     parent' = fromMaybe (gridEstWidth self cells0) parent     zeroBox :: PaddedBox Double Double     zeroBox = zero-boxNatWidth _ self@(LayoutInline _ _ _ _ _) = self-boxNatWidth _ self@(LayoutInline' _ _ _ _ _) = self-boxNatWidth _ self@(LayoutSpan _ _ _) = self+boxNatWidth _ self@(LayoutInline _ _ _) = self+boxNatWidth _ self@(LayoutInline' _ _ _) = self+boxNatWidth _ (LayoutConst val self' childs) =+    LayoutConst val self' $ map (boxNatWidth Nothing) childs+boxNatWidth _ self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache maximum legible width. boxMaxWidth :: CastDouble y => PaddedBox a Double -> LayoutItem y Length x -> LayoutItem y Length x boxMaxWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs'@@ -149,9 +159,11 @@     inner (Size cellx celly, child) =         boxMaxWidth (cellSize (inline self) cellx `size2box` cellSize (block self) celly) child     size2box x y = zeroBox { B.min = Size x y, B.max = Size x y, B.size = Size x y }-boxMaxWidth parent self@(LayoutInline _ _ _ _ _) = self-boxMaxWidth parent self@(LayoutInline' _ _ _ _ _) = self-boxMaxWidth parent self@(LayoutSpan _ f self') = self+boxMaxWidth parent self@(LayoutInline _ _ _) = self+boxMaxWidth parent self@(LayoutInline' _ _ _) = self+boxMaxWidth _ (LayoutConst val self' childs) = LayoutConst val self' $+    map (boxMaxWidth $ mapY' toDouble $ mapX' toDouble self') childs+boxMaxWidth parent self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache final width. boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length x ->         LayoutItem y Double x@@ -176,11 +188,17 @@     }     outerwidth = inline $ size parent     widths = sizeTrackMaxs (inline $ size parent) $ inline self-boxWidth parent (LayoutInline val font (Paragraph a b c d) paging vals) =-    LayoutInline val font (Paragraph a b c d { paragraphMaxWidth = round width }) paging vals+boxWidth parent (LayoutInline val (Paragraph a b c d) paging) =+    LayoutInline val (paragraphMap (mapX' $ lowerLength width) $+        Paragraph a b c d { paragraphMaxWidth = round width }) paging   where width = B.inline $ B.size parent-boxWidth _ (LayoutInline' a b c d e) = LayoutInline' a b c d e-boxWidth parent (LayoutSpan val font self') = LayoutSpan val font self'+boxWidth p (LayoutInline' a b c) =+    LayoutInline' a (layoutMap (mapX' $ lowerLength $ B.inline $ B.size p) b) c+boxWidth p (LayoutConst val self childs) = LayoutConst val (mapX' cb self) $+    map (boxWidth $ mapY' toDouble $ mapX' cb self) childs+  where cb = lowerLength $ width p+boxWidth parent (LayoutSpan self') =+    LayoutSpan $ treeMap (mapX' $ lowerLength $ width parent) self'  -- | Update a (sub)tree to compute & cache ideal legible height. boxNatHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x@@ -197,9 +215,11 @@     cells' = map setCellBox' $ zip childs' cells -- Flatten subgrids     childs' = map (boxNatHeight width) childs     width = trackNat id $ inline self-boxNatHeight parent self@(LayoutInline _ _ _ _ _) = self-boxNatHeight parent self@(LayoutInline' _ _ _ _ _) = self-boxNatHeight parent self@(LayoutSpan _ _ _) = self+boxNatHeight parent self@(LayoutInline _ _ _) = self+boxNatHeight parent self@(LayoutInline' _ _ _) = self+boxNatHeight p (LayoutConst val self' childs) = LayoutConst val self' $+    map (boxNatHeight $ width $ mapY' (lowerLength p) self') childs+boxNatHeight parent self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache minimum legible height. boxMinHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x boxMinHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs'@@ -217,9 +237,11 @@     self' = Size (inline self) (block self) { trackMins = heights }     heights = sizeTrackMins width (block self) $ map block cells     width = trackNat id $ inline self-boxMinHeight parent self@(LayoutInline _ _ _ _ _) = self-boxMinHeight _ self@(LayoutInline' _ _ _ _ _) = self-boxMinHeight parent self@(LayoutSpan _ font self') = self+boxMinHeight parent self@(LayoutInline _ _ _) = self+boxMinHeight _ self@(LayoutInline' _ _ _) = self+boxMinHeight p (LayoutConst val self' childs) = LayoutConst val self' $+    map (boxMinHeight $ width $ mapY' (lowerLength p) self') childs+boxMinHeight parent self@(LayoutSpan _) = self -- | Update a subtree to compute & cache maximum legible height. boxMaxHeight :: PaddedBox Double Double -> LayoutItem Length Double x ->         LayoutItem Length Double x@@ -238,11 +260,11 @@         child' = boxMaxHeight (gridItemBox self cell) child     heights = sizeTrackMaxs (inline $ size parent) (block self)     width = inline $ size parent-boxMaxHeight parent (LayoutInline val font self' paging vals) =-    LayoutInline val font self' paging vals-boxMaxHeight parent (LayoutInline' val font self' paging vals) =-    LayoutInline' val font self' paging vals-boxMaxHeight parent (LayoutSpan val font self') = LayoutSpan val font self'+boxMaxHeight _ (LayoutInline val self' paging) = LayoutInline val self' paging+boxMaxHeight _ (LayoutInline' val self' paging) = LayoutInline' val self' paging+boxMaxHeight p (LayoutConst val self' childs) = LayoutConst val self' $+    map (boxMaxHeight $ mapY' (lowerLength $ width p) self') childs+boxMaxHeight parent (LayoutSpan self') = LayoutSpan self' -- | Update a (sub)tree to compute & cache final height. boxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> LayoutItem Double Double x boxHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs'@@ -269,11 +291,15 @@     lowerSize (Left x) = Left $ lowerLength width x     lowerSize (Right x) = Right x     width = inline $ size parent-boxHeight parent (LayoutInline val font self' paging vals) =-    LayoutInline val font self' paging vals-boxHeight _ (LayoutInline' val font self' paging vals) =-    LayoutInline' val font self' paging vals-boxHeight _ (LayoutSpan val font self') = LayoutSpan val font self'+boxHeight p (LayoutInline val self' paging) =+    LayoutInline val (paragraphMap (mapY' $ lowerLength $ width p) self') paging+boxHeight p (LayoutInline' val self' paging) =+    LayoutInline' val (layoutMap (mapY' $ lowerLength $ width p) self') paging+boxHeight p (LayoutConst val self childs) =+    let self' = mapY' (lowerLength $ width p) self+    in LayoutConst val self' $ map (boxHeight self') childs+boxHeight p (LayoutSpan self') =+    LayoutSpan $ treeMap (mapY' $ lowerLength $ width p) self'  -- | Split a (sub)tree to fit within max-height. -- May take full page height into account.@@ -300,10 +326,11 @@     inner start (child:childs) = (start', child):inner start' childs -- TODO margin collapse?         where start' = start + height (layoutGetBox child)     inner _ [] = []+boxSplit _ _ self@(LayoutConst _ _ _) = (self, Nothing) -- Doesn't split. boxSplit _ _ self@(LayoutGrid _ _ _ _) = (self, Nothing) -- TODO-boxSplit maxheight pageheight (LayoutInline a b self c d) =-    boxSplit maxheight pageheight $ LayoutInline' a b (layoutPlain self) c d-boxSplit maxheight pageheight (LayoutInline' a b self paging c) =+boxSplit maxheight pageheight (LayoutInline a self b) =+    boxSplit maxheight pageheight $ LayoutInline' a (layoutRich self) b+boxSplit maxheight pageheight (LayoutInline' a self paging) =     case paginate paging {             pageCurrentHeight = toEnum $ fromEnum maxheight,             pageNextHeight = toEnum $ fromEnum pageheight@@ -311,8 +338,8 @@         (Continue, self', next) -> (wrap self', wrap <$> next)         (Break, _, _) -> (nullLayout, Just $ wrap self)   where-    wrap self' = LayoutInline' a b self' paging c-boxSplit _ _ self@(LayoutSpan _ _ _) = (self, Nothing) -- Can't split!+    wrap self' = LayoutInline' a self' paging+boxSplit _ _ self@(LayoutSpan _) = (self, Nothing) -- Can't split! -- | Generate a list of pages from a node, splitting subtrees where necessary. boxPaginate pageheight node     | (page, Just overflow) <- boxSplit pageheight pageheight node =@@ -320,8 +347,8 @@     | otherwise = [node]  -- | Compute position of all nodes in the (sub)tree relative to a base coordinate.-boxPosition :: PropertyParser x => (Double, Double) -> LayoutItem Double Double x ->-    LayoutItem Double Double ((Double, Double), x)+boxPosition :: (PropertyParser x, Eq x) => (Double, Double) ->+    LayoutItem Double Double x -> LayoutItem Double Double ((Double, Double), x) boxPosition pos@(x, y) (LayoutFlow val self childs) = LayoutFlow (pos, val) self childs'   where     childs' = map recurse $ zip pos' childs@@ -332,16 +359,17 @@     childs' = map recurse $ zip pos' childs     recurse ((x', y'), child) = boxPosition (x + x', y + y') child     pos' = gridPosition self cells-boxPosition pos@(x, y) (LayoutInline val font self paging vals) =-    LayoutInline (pos, val) font self paging $ map (\(x, y) -> (fragmentPos font pos y, x)) $-            inlineChildren vals self-boxPosition pos@(x, y) (LayoutInline' val font self paging vals) =-    LayoutInline' (pos, val) font self paging $ map (\(x, y) -> (fragmentPos font pos y, x)) $-            layoutChildren vals self-boxPosition pos (LayoutSpan val f self) = LayoutSpan (pos, val) f self -- No children...+boxPosition pos@(x, y) (LayoutInline val self paging) =+    boxPosition pos $ LayoutInline' val (layoutRich self) paging+boxPosition pos@(x, y) self@(LayoutInline' val _ _) =+    boxPosition pos $ LayoutConst val (layoutGetBox self) $ layoutGetChilds self+boxPosition pos (LayoutConst val self childs) =+    LayoutConst (pos, val) self $ map (boxPosition pos) childs+boxPosition pos (LayoutSpan self) = LayoutSpan $ positionTree pos self -- | Compute sizes & position information for all nodes in the (sub)tree.-boxLayout :: PropertyParser x => PaddedBox Double Double -> LayoutItem Length Length x ->-        Bool -> [LayoutItem Double Double ((Double, Double), x)]+boxLayout :: (PropertyParser x, Eq x) => PaddedBox Double Double ->+        LayoutItem Length Length x -> Bool -> +        [LayoutItem Double Double ((Double, Double), x)] boxLayout parent self paginate = self9   where     self0 = boxMinWidth Nothing self@@ -359,8 +387,8 @@ -- | Compute a mapping from a layout tree indicating which glyphs for which fonts -- are required. -- Useful for assembling glyph atlases.-glyphsPerFont :: LayoutItem x y z -> M.Map (Pattern, Double) IS.IntSet+{- glyphsPerFont :: LayoutItem x y z -> M.Map (Pattern, Double) IS.IntSet glyphsPerFont (LayoutSpan _ font self) =     (pattern font, fontSize font) `M.singleton` IS.fromList glyphs   where glyphs = map fromEnum $ map Hb.codepoint $ map fst $ fragmentGlyphs self-glyphsPerFont node = M.unionsWith IS.union $ map glyphsPerFont $ layoutGetChilds node+glyphsPerFont node = M.unionsWith IS.union $ map glyphsPerFont $ layoutGetChilds node -}

@@ -5,12 +5,13 @@         Size(..), mapSizeX, mapSizeY,         PaddedBox(..), zeroBox, lengthBox, mapX', mapY',         width, height, minWidth, minHeight, maxWidth, maxHeight,+        leftSpace, rightSpace, topSpace, bottomSpace, hSpace, vSpace,         Length(..), mapAuto, lowerLength, Zero(..), CastDouble(..)) where  -- | Amount of space surrounding the box. data Border m n = Border {     top :: m, bottom :: m, left :: n, right :: n-}+} deriving Eq -- | Convert horizontal spacing via given callback. mapX :: (n -> nn) -> Border m n -> Border m nn -- | Convert vertical spacing via given callback.@@ -44,7 +45,7 @@     border :: Border m n,     -- | The amount of space between the border & anything else.     margin :: Border m n-}+} deriving Eq -- | An empty box, takes up nospace onscreen. zeroBox :: PaddedBox Double Double zeroBox = PaddedBox {@@ -109,6 +110,13 @@ -- | The total maximum size along the block axis. maxHeight PaddedBox {..} = top margin + top border + top padding +     block max + bottom padding + bottom border + bottom margin++leftSpace PaddedBox {..} = left margin + left border + left padding+rightSpace PaddedBox {..} = right margin + right border + right padding+topSpace PaddedBox {..} = top margin + top border + top padding+bottomSpace PaddedBox {..} = bottom margin + bottom border + bottom padding+hSpace self = leftSpace self + rightSpace self+vSpace self = topSpace self + bottomSpace self  -- | A partially-computed length value. data Length = Pixels Double -- ^ Absolute number of device pixels.

@@ -1,194 +1,30 @@ {-# LANGUAGE OverloadedStrings #-}+-- These following language extensions are to aid a dependency injection into+-- inline styling.+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} -- | 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)+import Stylist (PropertyParser(..)) import Stylist.Tree (StyleTree(..))-import Data.Text.ParagraphLayout (PageOptions(..))+import Data.Text.ParagraphLayout.Rich (paragraphLineHeight, constructParagraph,+        defaultParagraphOptions, defaultBoxOptions,+        LineHeight(..), InnerNode(..), Box(..), RootNode(..))  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 --- | 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-      }--    -- 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 } }+import Data.Char (isSpace)+import Graphics.Layout.CSS.Parse -    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'-      }-    longhand _ _ _ _ = Nothing+instance (PropertyParser x, Zero m, Zero n) => Default (UserData m n x) where+    def = ((placeholderFont, 0), zero, temp)  -- | Desugar parsed CSS into more generic layout parameters. finalizeCSS :: PropertyParser x => Font' -> Font' -> StyleTree (CSSBox x) ->@@ -199,7 +35,7 @@     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)]+            (finalizeChilds root font_ self' childs)]   where     font_ = pattern2font (font self') (font' self') parent root finalizeCSS root parent self@StyleTree {@@ -220,26 +56,23 @@     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)+  } = LayoutFlow val (finalizeBox self' font_) (finalizeChilds root font_ self' 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 :: PropertyParser x => Font' -> Font' -> CSSBox 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')]+    | isInlineTree childs, Just self <- finalizeParagraph (flattenTree0 childs) =+        [LayoutInline (inherit $ inner style') self paging]     | (inlines@(_:_), blocks) <- spanInlines childs,-        Just self <- finalizeParagraph (flattenTree inlines) parent  =-            LayoutInline (inherit style') parent self paging (repeat $ inherit style') :+        Just self <- finalizeParagraph (flattenTree0 inlines) =+            LayoutInline (inherit $ inner style') self paging :                 finalizeChilds root parent style' blocks     | (StyleTree { style = CSSBox { display = Inline } }:childs') <- childs =         finalizeChilds root parent style' childs' -- Inline's all whitespace...@@ -256,11 +89,31 @@           }: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 "" []+    flattenTree0 childs+        | iStyle@(CSSInline _ _ bidi) <- inlineStyles style',+            bidi `elem` [BdOverride, BdIsolateOverride] = RootBox $ Box+                (applyBidi iStyle $ map (flattenTree parent) $ enumerate childs)+                $ flip applyFontInline parent $ txtOpts style'+        | otherwise = RootBox $ Box (map (flattenTree parent) $ enumerate childs)+            $ flip applyFontInline parent $ txtOpts style'+    flattenTree p (i, StyleTree { children = child@(_:_), style = self }) =+        buildInline f i self $ map (flattenTree f) $ enumerate child+      where f = pattern2font (font self) (font' self) p root+    flattenTree f (i,StyleTree {style=self@CSSBox {inlineStyles=CSSInline txt _ _}})+        = buildInline f i self [TextSequence ((f,0),zero,inherit $ inner self) txt]+    buildInline f i self childs =+        InlineBox ((f, i), finalizeBox self f, inner self)+                (Box childs' $ flip applyFontInline f $ txtOpts self)+                defaultBoxOptions -- Fill in during layout.+      where childs' = applyBidi (inlineStyles self) childs+    finalizeParagraph (RootBox (Box [TextSequence _ txt] _))+        | Txt.all isSpace txt = Nothing -- Discard isolated whitespace.+    finalizeParagraph tree =+        Just $ constructParagraph "" tree "" defaultParagraphOptions {+            paragraphLineHeight = Absolute $ toEnum $ fromEnum+                    (lineheight parent * hbUnit)+          }+    enumerate = zip $ enumFrom 0 finalizeChilds _ _ _ [] = []  -- | Desugar most units, possibly in reference to given font.

@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -- | Infrastructure for parsing & desugaring CSS properties related to fonts.-module Graphics.Layout.CSS.Font(Font'(..), placeholderFont, hbScale, hbUnit,+module Graphics.Layout.CSS.Font(Font'(..), placeholderFont, hbUnit,         pattern2hbfont, pattern2font, CSSFont(..), variations') where  import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..), serialize)@@ -22,9 +22,6 @@ -- | zero'd `Font'` to serve as the root's parent in a font heirarchy. placeholderFont = Font' undefined [] (const 0) (const 0) 0 0 0 0  0 0 0 0  1 -- | Scale-factor for text-shaping APIs.-hbScale :: Font' -> Double-hbScale f = fontSize f*hbUnit--- | Magic number informing the value of `hbScale`. hbUnit = 64 :: Double  -- | Convert from FontConfig query result to a Harfbuzz font.@@ -66,7 +63,7 @@         height' (Just x) = fromIntegral $ HB.height x         height' Nothing = fontSize'         lineheight' | snd (cssLineheight styles) == "normal",-            Just extents <- fontHExtents font' = (fromIntegral $ lineGap extents)/scale'+            Just extents <- fontHExtents font' = (fromIntegral $ lineGap extents)/hbUnit             | otherwise = lowerLength' (cssLineheight styles) parent         fontSize' = lowerLength' (cssFontSize styles) parent         lowerLength' a = lowerLength (fontSize parent) . finalizeLength a@@ -78,7 +75,7 @@             Just (font:_, _) -> fontRenderPrepare' q font             _ -> error "TODO: Set fallback font!"         font' = pattern2hbfont font (round scale') $ variations' fontSize' styles-        scale' = fontSize'*hbUnit+        scale' = fontSize' * hbUnit  -- | Parsed CSS font properties, excluding the FontConfig query. data CSSFont = CSSFont {@@ -121,6 +118,7 @@         opticalSize = True     }     inherit parent = parent+    priority _ = []      longhand _ self "font-size" [Ident "xx-small"] = fracDefault self $ 3/5     longhand _ self "font-size" [Ident "x-small"] = fracDefault self $ 3/4

@@ -55,7 +55,9 @@ finalizeLength (x,"rem") f = Pixels $ x*rootEm f finalizeLength (x,"rlh") f = Pixels $ x*rlh f finalizeLength (x,"vh") f = Pixels $ x*vh f+finalizeLength (x,"vb") f = Pixels $ x*vh f -- TODO: Support vertical text finalizeLength (x,"vw") f = Pixels $ x*vw f+finalizeLength (x,"vi") f = Pixels $ x*vw f -- TODO: Support vertical text finalizeLength (x,"vmax") f = Percent $ x*vmax f finalizeLength (x,"vmin") f = Percent $ x*vmin f finalizeLength (x,"px") f = Pixels $ x*scale f@@ -104,3 +106,6 @@     -- | How many device pixels in a CSS px?     scale :: Double }++instance Eq Font' where+    a == b = pattern a == pattern b

@@ -0,0 +1,404 @@+{-# 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)+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+}+-- | 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+      }+    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} "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 _ _ _ _ = 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

@@ -1,19 +1,46 @@ {-# LANGUAGE OverloadedStrings #-} -- | Infrastructure for parsing & desugaring grid-layout related CSS properties.-module Graphics.Layout.Grid.CSS(CSSGrid(..), Axis(..), CSSCell(..), Placement(..), finalizeGrid) where+module Graphics.Layout.Grid.CSS(CSSGrid(..), Axis(..), CSSCell(..), Placement(..),+                                finalizeGrid, Areas, parseASCIIGrid) where -import Stylist (PropertyParser(..))+import Stylist (PropertyParser(..), parseOperands) import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))+ import Data.Text (Text) import qualified Data.Text as Txt import Data.Char (isAlphaNum)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isNothing)+import Data.List (nub)+import qualified Data.HashMap.Lazy as HM  import Graphics.Layout.CSS.Length import Graphics.Layout.Box import Graphics.Layout.Grid import Graphics.Layout +type Areas = HM.HashMap Text ((Int, Int), (Int, Maybe Int))++-- | Converts a grid to lookup table start & indices for row & columns.+-- Exported for the sake of testing+parseASCIIGrid :: [[Text]] -> Int -> Areas -> Maybe Areas+parseASCIIGrid (row:rows) i prev+    | names == nub names, and [span == fst rec && isNothing (snd $ snd rec)+            | (name, span) <- row', Just rec <- [name `HM.lookup` prev]] =+        parseASCIIGrid rows (succ i) $ HM.mapWithKey closeAreas $ HM.union prev $+            HM.fromList [(name, (span, (i, Nothing))) | (name, span) <- row']+    | otherwise = Nothing+  where+    names = map fst row'+    row' = parseAsciiRow $ enumerate row+    parseAsciiRow ((j, cell):cells) =+        let (self, cells') = span (\z -> snd z == cell) cells+        in (cell, (j, succ j + length self)):parseAsciiRow cells'+    parseAsciiRow [] = []+    enumerate = zip [0..]+    closeAreas name (a, (b, Nothing)) | name `notElem` names = (a, (b, Just i))+    closeAreas _ ret = ret+parseASCIIGrid [] _ ret = Just ret+ -- | Parsed CSS Grid properties data CSSGrid = CSSGrid {     -- | Parsed CSS grid-auto-columns@@ -25,7 +52,7 @@     -- | Parsed CSS grid-auto-rows     autoRows :: Unitted,     -- | Parsed CSS grid-template-areas-    templateAreas :: [[Text]],+    templateAreas :: Areas,     -- | Parsed CSS grid-template-columns     templateColumns :: [([Text], Unitted)],     -- | Parsed CSS grid-template-rows@@ -60,13 +87,14 @@         autoFlow = Row,         autoFlowDense = False,         autoRows = auto,-        templateAreas = [],+        templateAreas = HM.empty,         templateColumns = [],         templateRows = [],         cssGap = Size (0,"px") (0,"px"),         alignItems = Size Start Start -- FIXME: Should be stretch, unsupported.     }     inherit _ = temp+    priority _ = []      longhand _ s "grid-auto-columns" toks | Just x <- parseFR toks = Just s {autoColumns=x}     longhand _ s "grid-auto-rows" toks | Just x <- parseFR toks = Just s { autoRows = x }@@ -84,11 +112,15 @@         autoFlow = Col, autoFlowDense = True       } -    longhand _ self "grid-template-areas" [Ident "none"] = Just self {templateAreas = []}-    longhand _ self "grid-template-areas" [Ident "initial"] = Just self {templateAreas=[]}+    -- FIXME Parse & validate the ASCII-art grid into rectangles.+    longhand _ self "grid-template-areas" [Ident "none"] =+        Just self { templateAreas = HM.empty }+    longhand _ self "grid-template-areas" [Ident "initial"] =+        Just self { templateAreas = HM.empty }     longhand _ self "grid-template-areas" toks-        | all isString toks, validate [Txt.words x | String x <- toks] =-            Just self { templateAreas = [Txt.words x | String x <- toks] }+        | all isString toks, let grid = [Txt.words x | String x <- toks],+            validate grid, Just areas <- parseASCIIGrid grid 0 HM.empty =+                Just self { templateAreas = areas }       where         isString (String _) = True         isString _ = False@@ -164,6 +196,7 @@         alignSelf = Size Nothing Nothing     }     inherit _ = temp+    priority _ = []      longhand _ self "grid-column-start" toks | Just x <- placement toks =         Just self { columnStart = x}@@ -222,6 +255,118 @@         Just self { alignSelf = (alignSelf self) { inline = Nothing } }      longhand _ _ _ _ = Nothing++    shorthand _ "grid-column" toks = case break (== Delim '/') toks of+        (a, Delim '/':b) | Just _ <- placement a, Just _ <- placement b ->+            [("grid-column-start", a), ("grid-column-end", b)]+        _ | Just _ <- placement toks ->+            [("grid-column-start", toks), ("grid-column-end", toks)]+        _ -> []+    shorthand self "grid-gap" toks = case parseOperands toks of+        [a] | Just _ <- longhand self self "grid-row-gap" a ->+            [("grid-row-gap", a), ("grid-column-gap", a)]+        [a, b] | Just _ <- longhand self self "grid-row-gap" a,+            Just _ <- longhand self self "grid-column-gap" b ->+                [("grid-row-gap", a), ("grid-column-gap", b)]+        _ -> []+    shorthand _ "grid-row" toks = case break (== Delim '/') toks of+        (a, Delim '/':b) | Just _ <- placement a, Just _ <- placement b ->+            [("grid-row-start", a), ("grid-row-end", b)]+        _ | Just _ <- placement toks ->+            [("grid-row-start", toks), ("grid-row-end", toks)]+        _ -> []+    shorthand _ "grid-template" toks@[Ident "none"] =+        [("grid-template-columns", toks), ("grid-template-rows", toks),+         ("grid-template-areas", toks)]+    shorthand self "grid-template" toks+        | (rows, Delim '/':cols) <- break (== Delim '/') toks,+            Just _ <- longhand self self "grid-template-rows" rows,+            Just _ <- longhand self self "grid-template-columns" cols =+                [("grid-template-rows", rows), ("grid-template-columns", cols),+                 ("grid-template-areas", [Ident "none"])]+        | (rowsTemplate, Delim '/':cols) <- break (== Delim '/') toks,+            Just (areas, rows) <- splitTemplate rowsTemplate,+            Just _ <- longhand self self "grid-template-cols" cols,+            Just _ <- longhand self self "grid-template-areas" areas =+                [("grid-template-rows", concat rows),+                 ("grid-template-columns", cols), ("grid-template-areas", areas)]+      where+        splitTemplate (LeftSquareBracket:t)+            | (names, RightSquareBracket:t') <- break (== RightSquareBracket) t,+              all isIdent names, Just (areas, row:rows) <- splitTemplate t' =+                Just (areas,+                    (LeftSquareBracket:names ++ RightSquareBracket:row):rows)+        splitTemplate (x@(String _):toks)+            | Just (areas, rows) <- splitTemplate' toks = Just (x:areas, rows)+        splitTemplate _ = Nothing+        splitTemplate' (x:LeftSquareBracket:t)+            | (names, RightSquareBracket:t') <- break (== RightSquareBracket) t,+              all isIdent names, Just _ <- parseFR' [x],+              Just (areas, rows) <- splitTemplate t' =+                Just (areas,+                    (x:LeftSquareBracket:names ++ [RightSquareBracket]):rows)+        splitTemplate' (x:toks)+            | Just _ <- parseFR' [x], Just (areas, rows) <- splitTemplate toks =+                Just (areas, [x]:rows)+        splitTemplate' (LeftSquareBracket:t)+            | (names, RightSquareBracket:t') <- break (== RightSquareBracket) t,+              all isIdent names, Just (areas, rows) <- splitTemplate t' =+                Just (areas,+                    (LeftSquareBracket:names ++ [RightSquareBracket]):rows)+        splitTemplate' toks+            | Just (areas, rows) <- splitTemplate toks = Just (areas, []:rows)+            | otherwise = Nothing+        isIdent (Ident _) = True+        isIdent _ = False+    shorthand self "grid" toks+        | ret@(_:_) <- shorthand self "grid-template" toks =+            ("grid-auto-flow", [Ident "row"]):ret+    shorthand self "grid" toks = case break (== Delim '/') toks of+        (rows, Delim '/':Ident "auto-flow":Ident "dense":cols) |+          Just _ <- longhand self self "grid-template-rows" rows,+          Just _ <- longhand self self "grid-auto-columns" cols ->+            [("grid-template-rows", rows),+             ("grid-template-columns", [Ident "none"]),+             ("grid-auto-columns", cols), ("grid-auto-rows", [Ident "none"]),+             ("grid-auto-flow", [Ident "column", Ident "dense"])]+        (rows, Delim '/':Ident "dense":Ident "auto-flow":cols) |+          Just _ <- longhand self self "grid-template-rows" rows,+          Just _ <- longhand self self "grid-auto-columns" cols ->+            [("grid-template-rows", rows),+             ("grid-template-columns", [Ident "none"]),+             ("grid-auto-columns", cols), ("grid-auto-rows", [Ident "none"]),+             ("grid-auto-flow", [Ident "column", Ident "dense"])]+        (rows, Delim '/':Ident "auto-flow":cols) |+          Just _ <- longhand self self "grid-template-rows" rows,+          Just _ <- longhand self self "grid-auto-columns" cols ->+            [("grid-template-rows", rows),+             ("grid-template-columns", [Ident "none"]),+             ("grid-auto-columns", cols), ("grid-auto-rows", [Ident "none"]),+             ("grid-auto-flow", [Ident "column"])]+        (Ident "auto-flow":Ident "dense":rows, Delim '/':cols) |+          Just _ <- longhand self self "grid-auto-rows" rows,+          Just _ <- longhand self self "grid-template-columns" cols ->+            [("grid-auto-rows", rows), ("grid-auto-columns", [Ident "none"]),+             ("grid-template-columns", cols),+             ("grid-template-rows", [Ident "none"]),+             ("grid-auto-flow", [Ident "row", Ident "dense"])]+        (Ident "dense":Ident "auto-flow":rows, Delim '/':cols) |+          Just _ <- longhand self self "grid-auto-rows" rows,+          Just _ <- longhand self self "grid-template-columns" cols ->+            [("grid-auto-rows", rows), ("grid-auto-columns", [Ident "none"]),+             ("grid-template-columns", cols),+             ("grid-template-rows", [Ident "none"]),+             ("grid-auto-flow", [Ident "row", Ident "dense"])]+        (Ident "auto-flow":rows, Delim '/':cols) |+          Just _ <- longhand self self "grid-auto-rows" rows,+          Just _ <- longhand self self "grid-template-columns" cols ->+            [("grid-auto-rows", rows), ("grid-auto-columns", [Ident "none"]),+             ("grid-template-columns", cols),+             ("grid-template-rows", [Ident "none"]),+             ("grid-auto-flow", [Ident "row"])]+        _ -> []+    shorthand self k v | Just _ <- longhand self self k v = [(k, v)]+        | otherwise = []  -- | Parse a length or FR unit. parseFR [Dimension _ x "fr"] = Just (n2f x,"fr")

@@ -1,74 +1,212 @@ {-# LANGUAGE TupleSections #-} -- | Sizes inline text & extracts positioned children, -- wraps Balkón for the actual logic.-module Graphics.Layout.Inline(inlineMinWidth, inlineMin, inlineNatWidth, inlineHeight,-    inlineSize, inlineChildren, layoutSize, layoutChildren,-    fragmentSize, fragmentSize', fragmentPos) where+module Graphics.Layout.Inline(paragraphMap, layoutMap, treeMap,+    inlineMin, inlineSize, inlineChildren, layoutSize, layoutChildren,+    treeBox, positionTree, treeInner, FragmentTree(..)) where -import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..),-                                    SpanLayout(..), Fragment(..),-                                    ParagraphLayout(..), layoutPlain, Span(..))-import Data.Text.ParagraphLayout.Rect (Rect(..), width, height, x_min, y_min)-import Data.Text.Internal (Text(..))-import qualified Data.Text as Txt-import Data.Char (isSpace)+import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),+                                Fragment(..), ParagraphLayout(..), AncestorBox(..),+                                InnerNode(..), Box(..), RootNode(..),+                                layoutRich, boxSpacing, BoxSpacing(..))+import Data.Text.ParagraphLayout.Rect (Rect(..),+                                width, height, x_max, x_min, y_min, y_max) import Data.Int (Int32)+import Debug.Trace (trace) -- To warn about unexpected branches! -import Graphics.Layout.Box (Size(..), CastDouble(..), fromDouble)-import Graphics.Layout.CSS.Font (Font', hbScale)+import Graphics.Layout.Box hiding (min, max, width, height)+import qualified Graphics.Layout.Box as Box+import Graphics.Layout.CSS.Font (hbUnit)  -- | Convert from Harfbuzz units to device pixels as a Double-hbScale' font = (/hbScale font) . fromIntegral+hbScale :: Int32 -> Double+hbScale = (/hbUnit) . fromIntegral -- | Convert from Harfbuzz units to device pixels as a Double or Length.-c font = fromDouble . hbScale' font+c :: CastDouble a => Int32 -> a+c = fromDouble . hbScale+-- | Convert from a CastDouble in device pixels to Harfbuzz units.+unscale :: CastDouble x => x -> Int32+unscale = floor . (*hbUnit) . toDouble --- | Compute minimum width for some richtext.-inlineMinWidth :: Font' -> Paragraph -> Double-inlineMinWidth font self = hbScale' font $ width $ layoutPlain' self 0 -- | Compute minimum width & height for some richtext.-inlineMin :: (CastDouble x, CastDouble y) => Font' -> Paragraph -> Size x y-inlineMin font self = Size (c font $ width rect) (c font $ height rect)-    where rect = layoutPlain' self 0--- | Compute natural (single-line) width for some richtext.-inlineNatWidth :: Font' -> Paragraph -> Double-inlineNatWidth font self = hbScale' font $ width $ layoutPlain' self maxBound--- | Compute height for rich text at given width.-inlineHeight :: Font' -> Double -> Paragraph -> Double-inlineHeight font width self =-    hbScale' font $ height $ layoutPlain' self $ round (hbScale font * width)-+inlineMin :: (CastDouble x, CastDouble y) =>+        Paragraph (a, PaddedBox x y, c) -> Size x y+inlineMin self = Size (c $ width rect) (c $ height rect)+    where rect = layoutRich' self 0 -- | Compute width & height of some richtext at configured width.-inlineSize :: (CastDouble x, CastDouble y) => Font' -> Paragraph -> Size x y-inlineSize font self = layoutSize font $ layoutPlain self+inlineSize :: (CastDouble x, CastDouble y) =>+        Paragraph (a, PaddedBox x y, c) -> Size x y+inlineSize self = layoutSize $ layoutRich $ lowerSpacing self -- | Retrieve children out of some richtext, -- associating given userdata with them.-inlineChildren :: [x] -> Paragraph -> [(x, Fragment)]-inlineChildren vals self = layoutChildren vals $ layoutPlain self+inlineChildren :: (CastDouble x, CastDouble y, Eq x, Eq y, Eq a, Eq c) =>+        Paragraph (a, PaddedBox x y, c) -> [FragmentTree (a, PaddedBox x y, c)]+inlineChildren self = layoutChildren $ layoutRich $ lowerSpacing self  -- | Retrieve a laid-out paragraph's rect & convert to CatTrap types.-layoutSize :: (CastDouble x, CastDouble y) => Font' -> ParagraphLayout -> Size x y-layoutSize font self = Size (c font $ width r) (c font $ height r)+layoutSize :: (CastDouble x, CastDouble y) => ParagraphLayout a -> Size x y+layoutSize self = Size (c $ width r) (c $ height r)   where r = paragraphRect self -- | Retrieve a laid-out paragraph's children & associate with given userdata.-layoutChildren :: [x] -> ParagraphLayout -> [(x, Fragment)]-layoutChildren vals self = zip vals $ concat $ map inner $ spanLayouts self-  where inner (SpanLayout y) = y+layoutChildren :: Eq a => ParagraphLayout a -> [FragmentTree a]+layoutChildren self = reconstructTree self  -- | Layout a paragraph at given width & retrieve resulting rect.-layoutPlain' :: Paragraph -> Int32 -> Rect Int32-layoutPlain' (Paragraph a b c d) width =-    paragraphRect $ layoutPlain $ Paragraph a b c d { paragraphMaxWidth = width }+layoutRich' :: (CastDouble m, CastDouble n) =>+        Paragraph (a, PaddedBox m n, c) -> Int32 -> Rect Int32+layoutRich' (Paragraph a b c d) width = paragraphRect $ layoutRich $+    lowerSpacing $ Paragraph a b c d { paragraphMaxWidth = width } +-- | Copy surrounding whitespace into Balkon properties.+lowerSpacing :: (CastDouble m, CastDouble n) =>+    Paragraph (a, PaddedBox m n, c) -> Paragraph (a, PaddedBox m n, c)+lowerSpacing (Paragraph a b (RootBox c) d) = Paragraph a b (RootBox $ inner c) d+  where+    inner (Box childs opts) = flip Box opts $ map inner' childs+    inner' (InlineBox e@(_, f, _) child opts) = InlineBox e (inner child) opts {+            boxSpacing = BoxSpacingLeftRight (leftSpace box) (rightSpace box)+        }+      where box = mapX' unscale $ mapY' unscale f+    inner' self@(TextSequence _ _) = self+++data FragmentTree x = Branch (AncestorBox x) [FragmentTree x]+    | Leaf (Fragment x)++-- | Apply an operation to the 2nd field of the paragraph's userdata,+-- for it's entire subtree.+paragraphMap :: (b -> b') -> Paragraph (a, b, c) -> Paragraph (a, b', c)+paragraphMap cb (Paragraph a b (RootBox c) d) =+    Paragraph a b (RootBox $ inner c) d+  where+    inner (Box childs opts) = flip Box opts $ map inner' childs+    inner' (InlineBox (e, f, g) child opts) =+        InlineBox (e, cb f, g) (inner child) opts+    inner' (TextSequence (e, f, g) leaf) = TextSequence (e, cb f, g) leaf++-- | Apply an operation to the 2nd field of a laid-out paragraph's userdata,+-- for it's entire subtree.+layoutMap :: (b -> b') -> ParagraphLayout (a, b, c) -> ParagraphLayout (a, b', c)+layoutMap cb (ParagraphLayout a b) = ParagraphLayout a $ map inner b+  where+    inner self@Fragment { fragmentUserData = (a, b, c) } = self {+        fragmentUserData = (a, cb b, c),+        fragmentAncestorBoxes = map inner' $ fragmentAncestorBoxes self+      }+    inner' self@AncestorBox { boxUserData = (a, b, c) } = self {+        boxUserData = (a, cb b, c)+      }++-- | Apply an operation to the 2nd field of the tree extracted from a laid-out+-- paragraph, for all nodes.+treeMap :: (b -> b') -> FragmentTree (a, b, c) -> FragmentTree (a, b', c)+treeMap cb (Branch self@AncestorBox { boxUserData = (a, b, c) } childs) =+    Branch self { boxUserData = (a, cb b, c) } $ map (treeMap cb) childs+treeMap cb (Leaf self@Fragment { fragmentUserData = (a, b, c) }) =+    Leaf self { fragmentUserData = (a, cb b, c), fragmentAncestorBoxes = [] }+ -- | Retrieve the rect for a fragment & convert to CatTrap types.-fragmentSize :: (CastDouble x, CastDouble y) => Font' -> Fragment -> Size x y-fragmentSize font self = Size (c font $ width r) (c font $ height r)-    where r = fragmentRect self+fragmentSize :: (CastDouble x, CastDouble y) =>+        FragmentTree (a, PaddedBox x y, c) -> Size x y+fragmentSize self = Size (c $ width r) (c $ height r)+    where r = treeRect self+-- | Compute the unioned rect for a subtree.+treeRect :: (CastDouble m, CastDouble n) =>+        FragmentTree (a, PaddedBox m n, c) -> Rect Int32+treeRect (Branch AncestorBox { boxUserData = (_, box', _)} childs) =+        unions $ map treeRect childs+    where+        box :: PaddedBox Int32 Int32+        box = mapX' unscale $ mapY' unscale box'+treeRect (Leaf self) = fragmentRect self++-- | Compute the paddedbox for a subtree.+treeBox :: (CastDouble m, CastDouble n) =>+    FragmentTree (a, PaddedBox m n, c) -> PaddedBox m n+treeBox self@(Branch AncestorBox { boxUserData = (_, box', _)} _) = box' {+    Box.min = size', Box.max = size', Box.size = size', Box.nat = size+  } where+    size' = mapSizeX fromDouble $ mapSizeY fromDouble size+    size = mapSizeX (subtract $ hSpace box) $ mapSizeY (subtract $ vSpace box)$+         mapSizeX toDouble $ mapSizeY toDouble $ fragmentSize self+    box = mapX' toDouble $ mapY' toDouble box'+treeBox self@(Leaf Fragment { fragmentUserData = (_, box', _)}) = box' {+    Box.min = size', Box.max = size', Box.size = size', Box.nat = size+  } where+    size' = mapSizeX fromDouble $ mapSizeY fromDouble size+    size = mapSizeX (subtract $ hSpace box) $ mapSizeY (subtract $ vSpace box) $+        mapSizeX toDouble $ mapSizeY toDouble $ fragmentSize self+    box = mapX' toDouble $ mapY' toDouble box'+ -- | Variant of `fragmentSize` asserting to the typesystem that both fields -- of the resulting `Size` are of the same type.-fragmentSize' :: CastDouble x => Font' -> Fragment -> Size x x+fragmentSize' :: CastDouble x => FragmentTree (a, PaddedBox x x, c) -> Size x x fragmentSize' = fragmentSize -- Work around for typesystem. -- | Retrieve the position of a fragment.-fragmentPos :: Font' -> (Double, Double) -> Fragment -> (Double, Double)-fragmentPos font (x, y) self =-        (x + hbScale' font (x_min r), y + hbScale' font (y_min r))+fragmentPos :: (Double, Double) -> Fragment a -> (Double, Double)+fragmentPos (x, y) self = (x + hbScale (x_min r), y + hbScale (y_min r))     where r = fragmentRect self++reconstructTree :: Eq x => ParagraphLayout x -> [FragmentTree x]+reconstructTree ParagraphLayout { paragraphFragments = frags } =+    reconstructTree' [frag {+            fragmentAncestorBoxes = reverse $ fragmentAncestorBoxes frag+        } | frag <- frags]+reconstructTree' :: Eq x => [Fragment x] -> [FragmentTree x]+reconstructTree' (self@Fragment { fragmentAncestorBoxes = [] }:frags) =+    Leaf self:reconstructTree' frags+reconstructTree' frags@(Fragment {+        fragmentAncestorBoxes = branch:_, fragmentLine = line+  }:_) =+    Branch branch (reconstructTree' [ child { fragmentAncestorBoxes = ancestors }+            | child@Fragment { fragmentAncestorBoxes = _:ancestors } <- childs])+        :reconstructTree' sibs+  where+    (childs, sibs) = span sameBranch frags+    -- Cluster ancestor branches, breaking them per-line.+    sameBranch Fragment {fragmentAncestorBoxes=branch':_, fragmentLine=line'} =+        branch == branch' && line == line'+    -- Leaves are always in their own branch.+    sameBranch Fragment { fragmentAncestorBoxes = [] } = False+reconstructTree' [] = []++positionTree :: (CastDouble m, CastDouble n) => (Double, Double) ->+        FragmentTree (a, PaddedBox m n, c) ->+        FragmentTree (a, PaddedBox m n, ((Double, Double), c))+positionTree (x, y) self@(Branch (AncestorBox (a, b, c) d e f g) childs) =+    Branch (AncestorBox (a, b, (pos, c)) d e f g) $+        map (positionTree pos) childs+  where+    pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))+    rect = treeRect self+positionTree (x, y) self@(Leaf (Fragment (a, b, c) d _ f g h)) =+    Leaf (Fragment (a, b, (pos, c)) d [] f g h)+  where+    pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))+    rect = treeRect self+treeInner :: FragmentTree (a, b, c) -> c+treeInner (Branch AncestorBox { boxUserData = (_, _, ret) } _) = ret+treeInner (Leaf Fragment { fragmentUserData = (_, _, ret) }) = ret++------+--- Taken from Balkón+------+-- | Calculate the smallest rectangle that completely contains all the given+-- rectangles.+unions [] = trace "No rects to union!" $ Rect 0 0 0 0+unions rects = foldr1 union rects++-- | Calculate the smallest rectangle that completely contains the given two+-- rectangles.+--+-- The origin of the resulting rectangle will be the corner with the lowest+-- X coordinate and the highest Y coordinate, regardless of the origin of the+-- input rectangles.+union :: (Num a, Ord a) => Rect a -> Rect a -> Rect a+union a b = Rect x_low y_high dx (-dy) where+    x_low = x_min a `min` x_min b+    y_low = y_min a `min` y_min b+    x_high = x_max a `max` x_max b+    y_high = y_max a `max` y_max b+    dx = x_high - x_low+    dy = y_high - y_low

@@ -1,60 +1,112 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, ViewPatterns #-} -- | Infrastructure for parsing & desugaring text related CSS properties.-module Graphics.Layout.Inline.CSS(CSSInline(..), ParagraphBuilder(..),-    buildParagraph, concatParagraph, finalizeParagraph) where+module Graphics.Layout.Inline.CSS(+    CSSInline(..), Default(..), UnicodeBidi(..), applyFontInline, applyBidi) where  import Data.CSS.Syntax.Tokens (Token(..)) import Stylist (PropertyParser(..))-import qualified Data.Text.Lazy as Lz import qualified Data.Text as Txt-import Data.Text.Internal (Text(..))-import Data.Text.ParagraphLayout (Span(..), SpanOptions(..), LineHeight(..),-                                Paragraph(..), ParagraphOptions(..))+import Data.Text (Text)+import Data.Text.ParagraphLayout.Rich+import Data.Text.Glyphize (Direction(..)) -import Graphics.Layout.CSS.Font (Font'(..), hbScale)+import Graphics.Layout.CSS.Font (Font'(..), hbUnit) import Data.Char (isSpace)+import Debug.Trace (trace) -- To report unexpected cases.  -- | Document text with Balkón styling options, CSS stylable.-data CSSInline = CSSInline Lz.Text SpanOptions+data CSSInline = CSSInline Txt.Text TextOptions UnicodeBidi+-- | To what degree is the text direction isolated?+data UnicodeBidi = BdNormal | BdEmbed | BdOverride | BdIsolate+        | BdIsolateOverride | BdPlainText deriving (Eq, Ord, Enum, Read, Show)  instance PropertyParser CSSInline where-    temp = CSSInline "" SpanOptions {-        spanLanguage = "Zxx"-    }-    inherit (CSSInline _ opts) = CSSInline "" opts+    temp = CSSInline "" (defaultTextOptions DirLTR) BdNormal+    inherit (CSSInline _ opts _) = CSSInline "" opts BdNormal+    priority _ = ["direction"] -- To inform logical spacing in caller! -    longhand _ (CSSInline _ opts) "content" toks+    longhand _ (CSSInline _ opts bidi) "content" [Ident "initial"] =+        Just $ CSSInline "" opts bidi+    longhand _ (CSSInline _ opts bidi) "content" toks         | all isString toks =-            Just $ CSSInline (Lz.concat [Lz.fromStrict x | String x <- toks]) opts+            Just $ CSSInline (Txt.concat [x | String x <- toks]) opts bidi       where         isString (String _) = True         isString _ = False-    longhand _ (CSSInline txt opts) "-argo-lang" [String x] =-        Just $ CSSInline txt opts { spanLanguage = Txt.unpack x }++    longhand _ (CSSInline t o b) "-argo-lang" [Ident kw]+        | kw `elem` ["initial", "auto"] = Just $ CSSInline t o {textLanguage=""} b+    longhand _ (CSSInline txt opts bidi) "-argo-lang" [String x] =+        Just $ CSSInline txt opts { textLanguage = Txt.unpack x } bidi++    longhand _ (CSSInline txt opts bidi) "direction" [Ident "ltr"] =+        Just $ CSSInline txt opts { textDirection = DirLTR } bidi+    longhand _ (CSSInline txt opts bidi) "direction" [Ident "rtl"] =+        Just $ CSSInline txt opts { textDirection = DirRTL } bidi+    longhand _ (CSSInline txt opts bidi) "direction" [Ident "initial"] =+        Just $ CSSInline txt opts { textDirection = DirLTR } bidi++    longhand _ (CSSInline txt opts _) "unicode-bidi" [Ident "initial"] =+        Just $ CSSInline txt opts BdNormal+    longhand _ (CSSInline txt opts _) "unicode-bidi" [Ident "normal"] =+        Just $ CSSInline txt opts BdNormal+    longhand _ (CSSInline txt opts _) "unicode-bidi" [Ident "embed"] =+        Just $ CSSInline txt opts BdEmbed+    longhand _ (CSSInline txt opts _) "unicode-bidi" [Ident "isolate"] =+        Just $ CSSInline txt opts BdIsolate+    longhand _ (CSSInline txt opts _) "unicode-bidi" [Ident "bidi-override"] =+        Just $ CSSInline txt opts BdOverride+    longhand _ (CSSInline txt opts _) "unicode-bidi" [Ident "isolate-override"] =+        Just $ CSSInline txt opts BdIsolateOverride+    longhand _ (CSSInline txt opts _) "unicode-bidi" [Ident "plaintext"] =+        Just $ CSSInline txt opts BdPlainText     longhand _ _ _ _ = Nothing --- | Helper datastructure for concatenating CSSInlines.-data ParagraphBuilder = ParagraphBuilder Lz.Text [Span]+applyFontInline :: TextOptions -> Font' -> TextOptions+applyFontInline opts font = opts {+    textFont = hbFont font,+    textLineHeight = Absolute $ toEnum $ fromEnum $ lineheight font * hbUnit+  }+-- | Apply Bidi chars around the inline text. FIXME: Handle the tree!+applyBidi :: Default d => CSSInline -> [InnerNode Text d] -> [InnerNode Text d]+applyBidi (CSSInline _ _ BdNormal) txt = txt+applyBidi (CSSInline _ (textDirection -> DirLTR) BdEmbed) txt =+    chLREmbed:txt+:chPopDir+applyBidi (CSSInline _ (textDirection -> DirRTL) BdEmbed) txt =+    chRLEmbed:txt+:chPopDir+applyBidi (CSSInline _ (textDirection -> DirLTR) BdIsolate) txt =+    chLRIsolate:txt+:chPopDirIsolate+applyBidi (CSSInline _ (textDirection -> DirRTL) BdIsolate) txt =+    chRLIsolate:txt+:chPopDirIsolate+applyBidi (CSSInline _ (textDirection -> DirLTR) BdOverride) txt =+    chLROverride:txt+:chPopDir+applyBidi (CSSInline _ (textDirection -> DirRTL) BdOverride) txt =+    chRLOverride:txt+:chPopDir+applyBidi (CSSInline _ (textDirection -> DirLTR) BdIsolateOverride) txt =+    ch1stStrongIsolate:chLROverride:txt+:chPopDir+:chPopDirIsolate+applyBidi (CSSInline _ (textDirection -> DirRTL) BdIsolateOverride) txt =+    ch1stStrongIsolate:chRLOverride:txt+:chPopDir+:chPopDirIsolate+applyBidi (CSSInline _ _ BdPlainText) txt =+    ch1stStrongIsolate:txt+:chPopDirIsolate+applyBidi (CSSInline _ (textDirection -> dir) _) txt =+    trace ("Unexpected direction! " ++ show dir) txt --- | Convert a CSSInline to a paragraph builder, with a span covering the entire text.-buildParagraph :: CSSInline -> ParagraphBuilder-buildParagraph (CSSInline txt opts) =-    ParagraphBuilder txt [flip Span opts $ fromEnum $ Lz.length txt]--- | Concatenate two `ParagraphBuilder`s, adjusting the spans appropriately.-concatParagraph :: ParagraphBuilder -> ParagraphBuilder -> ParagraphBuilder-concatParagraph (ParagraphBuilder aTxt aOpts) (ParagraphBuilder bTxt bOps) =-    ParagraphBuilder (aTxt `Lz.append` bTxt)-                    (aOpts ++ [Span (toEnum (fromEnum $ Lz.length aTxt) + off) opts-                                | Span off opts <- bOps])--- | Convert a builder + font to a Balkón paragraph.-finalizeParagraph :: ParagraphBuilder -> Font' -> Maybe Paragraph-finalizeParagraph (ParagraphBuilder txt _) _ | Lz.all isSpace txt || Lz.null txt = Nothing-finalizeParagraph (ParagraphBuilder txt ops) font' = Just $ Paragraph txt' 0 ops pOps-    where-        Text txt' _ _ = Lz.toStrict txt-        pOps = ParagraphOptions {-            paragraphFont = hbFont font',-            paragraphLineHeight = Absolute $ round (lineheight font' * hbScale font'),-            -- This is what we're computing! Configure to give natural width.-            paragraphMaxWidth = maxBound -- i.e. has all the space it needs...-        }+a +: b = a ++ [b]++chLREmbed, chRLEmbed, chLROverride, chRLOverride, chPopDir,+    chLRIsolate, chRLIsolate, ch1stStrongIsolate, chPopDirIsolate :: Default a =>+        InnerNode Text a+chLREmbed = leaf '\x202A'+chRLEmbed = leaf '\x202B'+chLROverride = leaf '\x202D'+chRLOverride = leaf '\x202E'+chPopDir = leaf '\x202C'+chLRIsolate = leaf '\x2066'+chRLIsolate = leaf '\x2067'+ch1stStrongIsolate = leaf '\x2068'+chPopDirIsolate = leaf '\x2069'++leaf ch = TextSequence def $ Txt.singleton ch++class Default a where+    def :: a

@@ -72,13 +72,14 @@     fromMaybe style $ longhand parent style (Txt.pack name) $         filter (/= Whitespace) $ tokenize $ Txt.pack val -data Nil = Nil+data Nil = Nil deriving Eq instance PropertyParser Nil where     temp = Nil     inherit _ = Nil     longhand _ _ _ _ = Nothing -renderDisplay :: GLuint -> LayoutItem Double Double ((Double, Double), a) -> IO ()+renderDisplay :: Eq a => GLuint -> LayoutItem Double Double ((Double, Double), a)+        -> IO () renderDisplay shader display = do     let ((x, y), _) = layoutGetInner display     let box = layoutGetBox display

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                cattrap-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Lays out boxes according to the CSS Box Model. description:         Computes where to place e.g. images, paragraphs, containers, tables, etc onscreen given desired amounts of whitespace. homepage:            https://argonaut-constellation.org/@@ -27,14 +27,14 @@                         Graphics.Layout.Box, Graphics.Layout.Arithmetic,                         Graphics.Layout.CSS.Length, Graphics.Layout.CSS.Font,                         Graphics.Layout.Inline, Graphics.Layout.Inline.CSS-  -- other-modules:+  other-modules:        Graphics.Layout.CSS.Parse   -- other-extensions:   build-depends:       base >=4.12 && <4.16, containers,                         css-syntax, scientific, text,-                        stylist-traits >= 0.1.1.0 && < 1,+                        stylist-traits >= 0.1.3.0 && < 1,                         fontconfig-pure >= 0.2 && < 0.3,                         harfbuzz-pure >= 1.0.3.2 && < 1.1, bytestring,-                        balkon >= 0.2.1 && < 1+                        balkon >= 1.1 && <2, unordered-containers   -- hs-source-dirs:   default-language:    Haskell2010   ghc-options:         -Wincomplete-patterns@@ -53,4 +53,4 @@   type:                exitcode-stdio-1.0   main-is:             Test.hs   build-depends:       base, cattrap, hspec >= 2 && < 3, QuickCheck >= 2 && < 3,-                        css-syntax, stylist-traits+                        css-syntax, stylist-traits, unordered-containers

@@ -6,12 +6,16 @@ import Graphics.Layout.Arithmetic import Data.CSS.Syntax.Tokens (tokenize, Token(..)) import Stylist (PropertyParser(..))+import Data.Maybe (fromJust)  import Graphics.Layout.Box as B import Graphics.Layout.Grid import Graphics.Layout.Flow import Graphics.Layout +import Graphics.Layout.Grid.CSS (parseASCIIGrid)+import qualified Data.HashMap.Lazy as HM+ main :: IO () main = hspec spec @@ -284,6 +288,21 @@             let LayoutFlow (pos, _) _ _ = snd $ head pxCells             containerSize pxGrid `shouldBe` Size 10 10             pos `shouldBe` (0, 0) -}+    describe "Grid templates" $ do+        it "parses successfully" $ do+            let grid = fromJust $ parseASCIIGrid [["head", "head"],+                                                  ["nav", "main"],+                                                  ["foot", "."]] 0 HM.empty+            HM.lookup "head" grid `shouldBe` Just ((0,2), (0, Just 1))+            HM.lookup "nav" grid `shouldBe` Just ((0,1), (1, Just 2))+            HM.lookup "main" grid `shouldBe` Just ((1,2), (1, Just 2))+            HM.lookup "foot" grid `shouldBe` Just ((0,1), (2, Nothing))+            HM.lookup "aside" grid `shouldBe` Nothing+        it "discards invalid non-squares" $ do+            let test grid = parseASCIIGrid grid 0 HM.empty `shouldBe` Nothing+            test [["head", "nav", "head"]]+            test [["head"], ["nav"], ["head"]]+            test [["head", "head"], ["head", "nav"]]  runMath = flip evalCalc [] . mapCalc fst . flip parseCalc [] . filter (/= Whitespace) . tokenize