M Graphics/Layout/CSS.hs => Graphics/Layout/CSS.hs +21 -13
@@ 21,41 21,48 @@ import Graphics.Layout.Inline.CSS
import Data.Char (isSpace)
import Graphics.Layout.CSS.Parse
+import Data.Maybe (fromMaybe)
instance (PropertyParser x, Zero m, Zero n) => Default (UserData m n x) where
def = ((placeholderFont, 0), zero, temp)
+inner' :: PropertyParser x => Font' -> CSSBox x -> x
+inner' f self = foldr apply (inner self) $ innerProperties self
+ where apply (k, v) ret = fromMaybe ret $
+ longhand (innerParent self) ret k $ finalizeLengths f v
+
-- | Desugar parsed CSS into more generic layout parameters.
finalizeCSS :: PropertyParser x => Font' -> Font' -> StyleTree (CSSBox x) ->
LayoutItem Length Length x
finalizeCSS root parent StyleTree { style = self'@CSSBox { display = None } } =
- LayoutFlow (inner self') lengthBox []
+ LayoutFlow (inner' parent self') lengthBox []
finalizeCSS root parent self@StyleTree {
- style = self'@CSSBox { display = Grid, inner = val }, children = childs
- } = LayoutFlow val (finalizeBox self' font_) [
+ style = self'@CSSBox { display = Grid }, children = childs
+ } = LayoutFlow (inner' font_ self') (finalizeBox self' font_) [
finalizeGrid (gridStyles self') font_ (map cellStyles $ map style childs)
(finalizeChilds root font_ self' childs)]
where
font_ = pattern2font (font self') (font' self') parent root
finalizeCSS root parent self@StyleTree {
- style = self'@CSSBox { display = Table, captionBelow = False }, children = childs
- } = LayoutFlow (inner self') (finalizeBox self' font_)
+ style=self'@CSSBox {display=Table, captionBelow=False}, children=childs
+ } = LayoutFlow (inner' font_ self') (finalizeBox self' font_)
([finalizeCSS root font_ child { style = child' { display = Block } }
| child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs] ++
[finalizeTable root font_ (inner self') childs])
where
font_ = pattern2font (font self') (font' self') parent root
finalizeCSS root parent self@StyleTree {
- style = self'@CSSBox { display = Table, captionBelow = True }, children = childs
- } = LayoutFlow (inner self') (finalizeBox self' font_)
+ style = self'@CSSBox {display=Table, captionBelow=True}, children = childs
+ } = LayoutFlow (inner' font_ self') (finalizeBox self' font_)
(finalizeTable root font_ temp childs:
[finalizeCSS root font_ child { style = child' { display = Block } }
| child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs])
where
font_ = pattern2font (font self') (font' self') parent root
finalizeCSS root parent self@StyleTree {
- style = self'@CSSBox { inner = val }, children = childs
- } = LayoutFlow val (finalizeBox self' font_) (finalizeChilds root font_ self' childs)
+ style = self', children = childs
+ } = LayoutFlow (inner' font_ self') (finalizeBox self' font_)
+ (finalizeChilds root font_ self' childs)
where
font_ = pattern2font (font self') (font' self') parent root
finalizeCSS' sysfont self@StyleTree { style = self' } =
@@ 68,10 75,10 @@ finalizeChilds root parent style' (StyleTree { style = CSSBox { display = None }
finalizeChilds root parent style' childs
finalizeChilds root parent style' childs@(child:childs')
| isInlineTree childs, Just self <- finalizeParagraph (flattenTree0 childs) =
- [LayoutInline (inherit $ inner style') self paging]
+ [LayoutInline (inherit $ inner' parent style') self paging]
| (inlines@(_:_), blocks) <- spanInlines childs,
Just self <- finalizeParagraph (flattenTree0 inlines) =
- LayoutInline (inherit $ inner style') self paging :
+ LayoutInline (inherit $ inner' parent style') self paging :
finalizeChilds root parent style' blocks
| (StyleTree { style = CSSBox { display = Inline } }:childs') <- childs =
finalizeChilds root parent style' childs' -- Inline's all whitespace...
@@ 99,9 106,10 @@ finalizeChilds root parent style' childs@(child:childs')
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 [
+ TextSequence ((f, 0), zero, inherit $ inner' parent self) txt]
buildInline f i self childs =
- InlineBox ((f, i), finalizeBox self f, inner self)
+ InlineBox ((f, i), finalizeBox self f, inner' parent self)
(Box childs' $ flip applyFontInline f $ txtOpts self)
defaultBoxOptions -- Fill in during layout.
where childs' = applyBidi (inlineStyles self) childs
M Graphics/Layout/CSS/Length.hs => Graphics/Layout/CSS/Length.hs +13 -3
@@ 1,12 1,12 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Infrastructure for parsing & desugaring length units & keywords,
-- in reference to the selected font.
-module Graphics.Layout.CSS.Length(Unitted, auto, parseLength, parseLength',
- n2f, finalizeLength, px2pt, Font'(..)) where
+module Graphics.Layout.CSS.Length(Unitted, auto, parseLength, parseLength', units,
+ n2f, finalizeLength, finalizeLengths, px2pt, Font'(..)) where
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import qualified Data.Text as Txt
-import Data.Scientific (toRealFloat)
+import Data.Scientific (toRealFloat, fromFloatDigits)
import Debug.Trace (trace) -- For warnings.
import Data.Text.Glyphize (Font)
import Graphics.Text.Font.Choose (Pattern(..))
@@ 27,6 27,7 @@ parseLength [Percentage _ x] = Just (n2f x,"%")
parseLength [Dimension _ x unit]
| n2f x == 0 && unit == "" = Just (0,"px")
| unit `elem` units = Just (n2f x,unit)
+parseLength [Number _ x] | n2f x == 0 = Just (0,"px")
parseLength [Ident "auto"] = Just (0,"auto")
parseLength [Ident "initial"] = Just (0,"auto")
parseLength _ = Nothing
@@ 76,6 77,15 @@ finalizeLength (_,unit) _ = trace ("Invalid unit " ++ Txt.unpack unit) $ Pixels
-- | Convert from a computed length to the "pt" unit.
px2pt f x = x / scale f / 96 * 72
+-- | Convert any length-units in the given CSS tokens to device pixels
+finalizeLengths :: Font' -> [Token] -> [Token]
+finalizeLengths f (Dimension _ x unit:toks)
+ | unit `elem` units, Pixels y <- finalizeLength (n2f x,unit) f =
+ Dimension "" (NVNumber $ fromFloatDigits y) "px":finalizeLengths f toks
+finalizeLengths f (Number a b:ts)|n2f b==0=Dimension a b "px":finalizeLengths f ts
+finalizeLengths f (tok:toks) = tok:finalizeLengths f toks
+finalizeLengths _ [] = []
+
-- | A Harfbuzz font with sizing parameters.
data Font' = Font' {
-- | The Harfbuzz font used to shape text & query character-size information.
M Graphics/Layout/CSS/Parse.hs => Graphics/Layout/CSS/Parse.hs +35 -78
@@ 11,13 11,15 @@ 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.Length (Unitted, parseLength', parseLength, auto, units)
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
+import Data.Text (Text)
+import Debug.Trace (trace) -- For debug warnings.
-- | Parsed CSS properties relevant to layout.
data CSSBox a = CSSBox {
@@ 34,6 36,10 @@ data CSSBox a = CSSBox {
font' :: CSSFont,
-- | Caller-specified data, to parse additional CSS properties.
inner :: a,
+ -- | Properties to lower size units before passing onto to `inner`
+ innerProperties :: [(Text, [Token])],
+ -- | Parent to use when parsing length-expanded inner properties.
+ innerParent :: a,
-- | Grid-related CSS properties.
gridStyles :: CSSGrid,
-- | Grid item related CSS properties.
@@ 80,6 86,9 @@ instance PropertyParser a => PropertyParser (CSSBox a) where
font = temp,
font' = temp,
inner = temp,
+ innerProperties = [],
+ innerParent = trace ("Parent not overriden upon " ++
+ "buffering inner properties for length resolution!") temp,
gridStyles = temp,
cellStyles = temp,
inlineStyles = temp,
@@ 96,6 105,8 @@ instance PropertyParser a => PropertyParser (CSSBox a) where
font = inherit $ font parent,
font' = inherit $ font' parent,
inner = inherit $ inner parent,
+ innerProperties = [],
+ innerParent = inner parent,
gridStyles = inherit $ gridStyles parent,
cellStyles = inherit $ cellStyles parent,
inlineStyles = inherit $ inlineStyles parent,
@@ 266,6 277,12 @@ instance PropertyParser a => PropertyParser (CSSBox a) where
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
+ | (d', _:_)<-testLengthProp d, Just _<-longhand (inner a) (inner b) c d' =
+ Just b {
+ innerProperties = (c, d):innerProperties b,
+ innerParent = inner a
+ }
longhand a b c d | Just inner' <- longhand (inner a) (inner b) c d = Just b {
inner = inner'
}
@@ 346,88 363,28 @@ instance PropertyParser a => PropertyParser (CSSBox a) where
[("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
+ shorthand self k v | ret@(_:_) <- shorthand (inner self) k v = ret
+ shorthand self k v
+ | (v', ls)<-testLengthProp v, ret@(_:_)<-shorthand (inner self) k v' =
+ [(key, map (restore ls) value) | (key, value) <- ret]
+ where
+ restore ls (Dimension _ (NVInteger x) "px") | x' < length ls = ls !! x'
+ where x' = fromInteger x
+ restore _ ret = ret
+ shorthand self k v | Just _ <- longhand self self k v = [(k, v)]
+ | otherwise = []
validProp self key value = isJust $ longhand self self key value
+
+testLengthProp (tok@(Dimension _ _ unit):toks) | unit `elem` units =
+ let (toks', lengths) = testLengthProp toks
+ in (Dimension "" (NVInteger $ toInteger $ succ $ length lengths) "px":toks',
+ tok:lengths)
+testLengthProp (tok:toks) = let (toks',ls) = testLengthProp toks in (tok:toks',ls)
+testLengthProp [] = ([], [])
M Graphics/Layout/Inline.hs => Graphics/Layout/Inline.hs +11 -8
@@ 9,7 9,7 @@ import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),
Fragment(..), ParagraphLayout(..), AncestorBox(..),
InnerNode(..), Box(..), RootNode(..),
layoutRich, boxSpacing, BoxSpacing(..),
- activateBoxSpacing)
+ activateBoxSpacing, paragraphSafeWidth)
import Data.Text.ParagraphLayout.Rect (Rect(..),
width, height, x_max, x_min, y_min, y_max)
import Data.Int (Int32)
@@ 32,12 32,12 @@ unscale = floor . (*hbUnit) . toDouble
-- | 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
+inlineMin = layoutSize' . flip layoutRich' 0
-- | Compute width & height of some richtext at configured width.
inlineSize :: (CastDouble x, CastDouble y) =>
Paragraph (a, PaddedBox x y, c) -> Size x y
-inlineSize self = layoutSize $ layoutRich $ lowerSpacing self
+inlineSize self@(Paragraph _ _ _ opts) =
+ layoutSize' . layoutRich' self $ paragraphMaxWidth opts
-- | Retrieve children out of some richtext,
-- associating given userdata with them.
inlineChildren :: (CastDouble x, CastDouble y, Eq x, Eq y, Eq a, Eq c) =>
@@ 46,17 46,20 @@ 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
-layoutSize self = Size (c $ width r) (c $ height r)
- where r = paragraphRect self
+layoutSize = layoutSize' . paragraphRect
+layoutSize' r = Size (c $ width r) (c $ height r)
-- | Retrieve a laid-out paragraph's children & associate with given userdata.
layoutChildren :: Eq a => ParagraphLayout a -> [FragmentTree a]
layoutChildren self = reconstructTree self
-- | Layout a paragraph at given width & retrieve resulting rect.
+-- LEGACY.
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 }
+layoutRich' (Paragraph a b c d) width =
+ (paragraphRect layout) { x_size = paragraphSafeWidth layout}
+ where
+ layout = layoutRich$lowerSpacing$Paragraph a b c d {paragraphMaxWidth=width}
-- | Copy surrounding whitespace into Balkon properties.
lowerSpacing :: (CastDouble m, CastDouble n) =>