M Graphics/Layout.hs => Graphics/Layout.hs +5 -5
@@ 11,15 11,15 @@ module Graphics.Layout(LayoutItem(..),
boxSplit, boxPaginate, boxPosition, boxLayout{-, glyphsPerFont-}) where
import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),
- Fragment(..), ParagraphLayout(..), layoutRich)
+ ParagraphLayout(..), layoutRich)
import Data.Text.ParagraphLayout (paginate, PageContinuity(..), PageOptions(..))
-import Stylist (PropertyParser(..))
+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)
@@ 86,7 86,7 @@ layoutGetInner (LayoutGrid ret _ _ _) = ret
layoutGetInner (LayoutInline ret _ _) = ret
layoutGetInner (LayoutInline' ret _ _) = ret
layoutGetInner (LayoutConst ret _ _) = ret
-layoutGetInner (LayoutSpan x) = subtreeInner x
+layoutGetInner (LayoutSpan x) = treeInner x
-- | map-ready wrapper around `setCellBox` sourcing from a child node.
setCellBox' (child, cell) = setCellBox cell $ layoutGetBox child
@@ 365,7 365,7 @@ 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 $ positionSubtree pos self
+boxPosition pos (LayoutSpan self) = LayoutSpan $ positionTree pos self
-- | Compute sizes & position information for all nodes in the (sub)tree.
boxLayout :: (PropertyParser x, Eq x) => PaddedBox Double Double ->
LayoutItem Length Length x -> Bool ->
M Graphics/Layout/CSS.hs => Graphics/Layout/CSS.hs +4 -396
@@ 3,414 3,22 @@
module Graphics.Layout.CSS(CSSBox(..), BoxSizing(..), Display(..),
finalizeCSS, finalizeCSS') where
-import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import qualified Data.Text as Txt
-import Stylist (PropertyParser(..), TrivialPropertyParser, parseOperands,
- parseUnorderedShorthand', parseUnorderedShorthand)
+import Stylist (PropertyParser(..))
import Stylist.Tree (StyleTree(..))
-import Data.Text.ParagraphLayout (PageOptions(..))
import Data.Text.ParagraphLayout.Rich (paragraphLineHeight, constructParagraph,
- defaultParagraphOptions, textDirection,
- defaultBoxOptions, LineHeight(..),
- InnerNode(..), Box(..), RootNode(..))
-import Data.Text.Glyphize (Direction(..))
+ 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
-import Data.Maybe (isJust, fromMaybe)
-import qualified Data.HashMap.Lazy as HM
import Data.Char (isSpace)
-
--- | 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
+import Graphics.Layout.CSS.Parse
-- | Desugar parsed CSS into more generic layout parameters.
finalizeCSS :: PropertyParser x => Font' -> Font' -> StyleTree (CSSBox x) ->
M Graphics/Layout/Inline.hs => Graphics/Layout/Inline.hs +23 -53
@@ 1,25 1,21 @@
{-# 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, positionChildren,
- fragmentSize, fragmentSize', fragmentPos, treeBox, FragmentTree(..),
- positionSubtree, subtreeInner, paragraphMap, layoutMap, treeMap) where
+module Graphics.Layout.Inline(paragraphMap, layoutMap, treeMap,
+ inlineMin, inlineSize, inlineChildren, layoutSize, layoutChildren,
+ treeBox, positionTree, treeInner, FragmentTree(..)) where
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.Text.Internal (Text(..))
-import qualified Data.Text as Txt
-import Data.Char (isSpace)
+ width, height, x_max, x_min, y_min, y_max)
import Data.Int (Int32)
import Graphics.Layout.Box hiding (min, max, width, height)
import qualified Graphics.Layout.Box as Box
-import Graphics.Layout.CSS.Font (Font', hbUnit)
+import Graphics.Layout.CSS.Font (hbUnit)
-- | Convert from Harfbuzz units to device pixels as a Double
hbScale :: Int32 -> Double
@@ 31,32 27,20 @@ c = fromDouble . hbScale
unscale :: CastDouble x => x -> Int32
unscale = floor . (*hbUnit) . toDouble
--- | Compute minimum width for some richtext.
-inlineMinWidth :: (CastDouble m, CastDouble n) =>
- Paragraph (a, PaddedBox m n, c) -> Double
-inlineMinWidth self = hbScale $ width $ layoutRich' self 0
-- | Compute minimum width & height for some richtext.
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 natural (single-line) width for some richtext.
-inlineNatWidth :: (CastDouble m, CastDouble n) =>
- Paragraph (a, PaddedBox m n, c) -> Double
-inlineNatWidth self = hbScale $ width $ layoutRich' self maxBound
--- | Compute height for rich text at given width.
-inlineHeight :: (CastDouble m, CastDouble n) =>
- Double -> Paragraph (a, PaddedBox m n, c) -> Double
-inlineHeight width self =
- hbScale $ height $ layoutRich' self $ round (hbUnit * width)
-
-- | Compute width & height of some richtext at configured width.
-inlineSize :: (CastDouble x, CastDouble y) => Paragraph a -> Size x y
-inlineSize self = layoutSize $ layoutRich 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 :: Eq a => Paragraph a -> [FragmentTree a]
-inlineChildren self = layoutChildren $ layoutRich 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) => ParagraphLayout a -> Size x y
@@ 72,6 56,7 @@ layoutRich' :: (CastDouble m, CastDouble n) =>
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
@@ 83,6 68,10 @@ lowerSpacing (Paragraph a b (RootBox c) d) = Paragraph a b (RootBox $ inner c) d
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)
@@ 162,25 151,6 @@ 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
--- | Alter userdata to hold positions.
-positionChildren :: (Double, Double) -> ParagraphLayout (a, b, c) ->
- ParagraphLayout (a, b, ((Double, Double), c))
-positionChildren pos self = self {
- paragraphFragments = [
- Fragment (a, b, (pos', c)) d (positionParents pos' e) f g h
- | frag@(Fragment (a, b, c) d e f g h) <- paragraphFragments self,
- let pos' = fragmentPos pos frag]
- }
-positionParents :: (Double, Double) -> [AncestorBox (a, b, c)] ->
- [AncestorBox (a, b, ((Double, Double), c))]
-positionParents pos (parent@AncestorBox { boxUserData = (a, b, c) }:parents) =
- parent { boxUserData = (a, b, (pos', c)) }:positionParents pos' parents
- where pos' = pos -- FIXME: Take into account borders.
-positionParents _ [] = []
-
-data FragmentTree x = Branch (AncestorBox x) [FragmentTree x]
- | Leaf (Fragment x)
-
reconstructTree :: Eq x => ParagraphLayout x -> [FragmentTree x]
reconstructTree ParagraphLayout { paragraphFragments = frags } =
reconstructTree' [frag {
@@ 204,20 174,20 @@ reconstructTree' frags@(Fragment {
sameBranch Fragment { fragmentAncestorBoxes = [] } = False
reconstructTree' [] = []
-positionSubtree :: (CastDouble m, CastDouble n) => (Double, Double) ->
+positionTree :: (CastDouble m, CastDouble n) => (Double, Double) ->
FragmentTree (a, PaddedBox m n, c) ->
FragmentTree (a, PaddedBox m n, ((Double, Double), c))
-positionSubtree (x, y) self@(Branch (AncestorBox (a, b, c) d e f g) childs) =
+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 (positionSubtree pos) childs
+ map (positionTree pos) childs
where
pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))
rect = treeRect self
-positionSubtree (x, y) self@(Leaf (Fragment (a, b, c) d _ f g h)) =
+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
-subtreeInner :: FragmentTree (a, b, c) -> c
-subtreeInner (Branch AncestorBox { boxUserData = (_, _, ret) } _) = ret
-subtreeInner (Leaf Fragment { fragmentUserData = (_, _, ret) }) = ret
+treeInner :: FragmentTree (a, b, c) -> c
+treeInner (Branch AncestorBox { boxUserData = (_, _, ret) } _) = ret
+treeInner (Leaf Fragment { fragmentUserData = (_, _, ret) }) = ret
M cattrap.cabal => cattrap.cabal +1 -1
@@ 27,7 27,7 @@ library
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,