5 files changed, 117 insertions(+), 59 deletions(-)

M Graphics/Layout.hs
M Graphics/Layout/CSS.hs
M Graphics/Layout/CSS/Parse.hs
M Graphics/Layout/Inline.hs
M cattrap.cabal

@@ 39,7 39,7 @@ import Data.Text.Array (Array(..))
 import Unsafe.Coerce (unsafeCoerce)
 
 -- | Additional data routed through Balkon.
-type UserData m n x = ((Font', Int), PaddedBox m n, x)
+type UserData m n x = ((Font', Int), Either (PaddedBox m n) (LayoutItem m n x), x)
 
 -- | A tree of different layout algorithms.
 -- More to come...


@@ 69,7 69,7 @@ instance (Zero m, CastDouble m, NFData m, Zero n, CastDouble n, NFData n) =>
     rnf = rnf . layoutGetBox -- Avoid auxiliary properties that don't cleanly `rnf`
 
 -- | Retrieve the surrounding box for a layout item.
-layoutGetBox :: (Zero m, Zero n, CastDouble m, CastDouble n) =>
+layoutGetBox, b :: (Zero m, Zero n, CastDouble m, CastDouble n) =>
         LayoutItem m n x -> PaddedBox m n
 layoutGetBox (LayoutFlow _ ret _) = ret
 layoutGetBox (LayoutGrid _ self _ _) = zero {


@@ 81,14 81,19 @@ layoutGetBox (LayoutGrid _ self _ _) = zero {
             (fromDouble $ trackNat toDouble $ block self)
 }
 layoutGetBox (LayoutInline _ self _) = zero {
-    B.min = inlineMin self, B.size = inlineSize self, B.max = inlineSize self
-}
+    B.min = inlineMin b self, B.size = inlineSize b self, B.max = inlineSize b self
+  }
 layoutGetBox (LayoutInline' _ self _) = zero {
     B.min = layoutSize self, B.size = layoutSize self, B.max = layoutSize self
 }
-layoutGetBox (LayoutSpan self) = treeBox self
+layoutGetBox (LayoutSpan self) = treeBox $ treeMap layoutGetBoxRight self
 layoutGetBox (LayoutConst _ ret _) = ret
 layoutGetBox (LayoutFlex _ self) = flexGetBox layoutGetBox' self
+
+b = layoutGetBox
+layoutGetBoxRight (Right self) = layoutGetBox self
+layoutGetBoxRight (Left ret) = ret
+
 layoutGetBox' :: (Zero m, Zero n, CastDouble m, CastDouble n) =>
         LayoutItem m n x -> PaddedBox Double Double
 layoutGetBox' = mapX' toDouble . mapY' toDouble . layoutGetBox


@@ 97,7 102,7 @@ layoutGetChilds (LayoutFlow _ _ ret) = ret
 layoutGetChilds (LayoutGrid _ _ _ ret) = ret
 layoutGetChilds (LayoutSpan (Leaf _)) = []
 layoutGetChilds (LayoutSpan (Branch _ ret)) = map LayoutSpan ret
-layoutGetChilds (LayoutInline _ self _) = map LayoutSpan $ inlineChildren self
+layoutGetChilds (LayoutInline _ self _) = map LayoutSpan $ inlineChildren b self
 layoutGetChilds (LayoutInline' _ self _) = map LayoutSpan $ layoutChildren self
 layoutGetChilds (LayoutConst _ _ childs) = childs
 layoutGetChilds (LayoutFlex _ x) = map Fl.flexInner $ concat $ Fl.children x


@@ 219,17 224,27 @@ boxWidth parent (LayoutGrid val self cells childs) = LayoutGrid val self' cells'
     }
     outerwidth = inline $ size parent
     widths = sizeTrackMaxs (inline $ size parent) $ inline self
-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 p (LayoutInline' a b c) =
-    LayoutInline' a (layoutMap (mapX' $ lowerLength $ B.inline $ B.size p) b) c
+boxWidth parent self@(LayoutInline val (Paragraph a b c d) paging) =
+    LayoutInline val (paragraphMap inner $ Paragraph a b c d {
+        paragraphMaxWidth = round $ B.inline $ B.size parent
+      }) paging
+  where
+    inner (Left a) = Left $ resolveWidth a
+    inner (Right a) = Right $ boxWidth (resolveWidth $ layoutGetBox self) a
+    resolveWidth = mapX' $ lowerLength $ B.inline $ B.size parent
+boxWidth parent self@(LayoutInline' a b c) = LayoutInline' a (layoutMap inner b) c
+  where
+    inner (Left a) = Left $ resolveWidth a
+    inner (Right a) = Right $ boxWidth (resolveWidth $ layoutGetBox self) a
+    resolveWidth = mapX' $ lowerLength $ B.inline $ B.size parent
 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'
+boxWidth parent self@(LayoutSpan self') = LayoutSpan $ treeMap inner self'
+  where
+    inner (Left a) = Left $ resolveWidth a
+    inner (Right a) = Right $ boxWidth (resolveWidth $ layoutGetBox self) a
+    resolveWidth = mapX' $ lowerLength $ B.inline $ B.size parent
 boxWidth parent (LayoutFlex a b) = LayoutFlex a $ flexMap (boxWidth parent) b
 
 -- | Update a (sub)tree to compute & cache ideal legible height.


@@ 326,15 341,26 @@ boxHeight parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' cell
     lowerSize (Left x) = Left $ lowerLength width x
     lowerSize (Right x) = Right x
     width = inline $ size parent
-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 parent self@(LayoutInline val self' paging) =
+    LayoutInline val (paragraphMap inner self') paging
+  where
+    inner (Left a) = Left $ resolveHeight a
+    inner (Right a) = Right $ boxHeight (resolveHeight $ layoutGetBox self) a
+    resolveHeight = mapY' $ lowerLength $ B.inline $ B.size parent
+boxHeight parent self@(LayoutInline' val self' paging) =
+    LayoutInline' val (layoutMap inner self') paging
+  where
+    inner (Left a) = Left $ resolveHeight a
+    inner (Right a) = Right $ boxHeight (resolveHeight $ layoutGetBox self) a
+    resolveHeight = mapY' $ lowerLength $ B.inline $ B.size parent
 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'
+boxHeight parent self@(LayoutSpan self') = LayoutSpan $ treeMap inner self'
+  where
+    inner (Left a) = Left $ resolveHeight a
+    inner (Right a) = Right $ boxHeight (resolveHeight $ layoutGetBox self) a
+    resolveHeight = mapY' $ lowerLength $ B.inline $ B.size parent
 boxHeight p (LayoutFlex a b) = LayoutFlex a $
     flexResolve (innerMain . layoutGetBox) (width p) $ flexMap (boxHeight p) b
 


@@ 421,7 447,10 @@ 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 $ parMap' (boxPosition pos) childs
-boxPosition pos (LayoutSpan self) = LayoutSpan $ positionTree pos self
+boxPosition pos (LayoutSpan self) = LayoutSpan $ positionTree pos inner self
+  where
+    inner _ (Left ret) = Left ret
+    inner pos' (Right kid) = Right $ boxPosition pos' kid
 -- | Compute sizes & position information for all nodes in the (sub)tree.
 boxLayout :: (PropertyParser x, Eq x) => PaddedBox Double Double ->
         LayoutItem Length Length x -> Bool -> 


@@ 443,7 472,7 @@ boxLayout parent self paginate = self9
 -- | Compute a mapping from a layout tree indicating which glyphs for which fonts
 -- are required.
 -- Useful for assembling glyph atlases.
-glyphsPerFont :: (CastDouble x, CastDouble y, Eq x, Eq y, Eq z) =>
+glyphsPerFont :: (CastDouble x, CastDouble y, Eq x, Eq y, Eq z, Zero x, Zero y) =>
         LayoutItem x y z -> M.Map (Pattern, Double) IS.IntSet
 glyphsPerFont (LayoutSpan self@(Leaf _)) | (_:_) <- glyphs =
         (pattern font, fontSize font) `M.singleton` IS.fromList glyphs

@@ 10,7 10,7 @@ import qualified Data.Text as Txt
 import Stylist (PropertyParser(..))
 import Stylist.Tree (StyleTree(..))
 import Data.Text.ParagraphLayout.Rich (constructParagraph, defaultBoxOptions,
-        LineHeight(..), InnerNode(..), Box(..), RootNode(..))
+        LineHeight(..), InnerNode(..), Box(..), RootNode(..), strut)
 
 import Graphics.Layout.Box as B
 import Graphics.Layout


@@ 27,7 27,7 @@ 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)
+    def = ((placeholderFont, 0), Left zero, temp)
 
 -- | Resolves length units in properties handled by downstream components.
 inner' :: PropertyParser x => Font' -> CSSBox x -> x


@@ 109,6 109,7 @@ finalizeChilds root parent style' childs@(child:_)
     isInlineTree = all isInlineTree0
     isInlineTree0 StyleTree { style = CSSBox { display = Inline }, children = childs } =
         isInlineTree childs
+    isInlineTree0 StyleTree { style = CSSBox { display = Inline' _ } } = True
     isInlineTree0 _ = False
     spanInlines childs = case span isInlineTree0 childs of
         (inlines, (StyleTree {


@@ 116,21 117,28 @@ finalizeChilds root parent style' childs@(child:_)
           }:blocks)) -> let (inlines', blocks') = spanInlines tail
             in (inlines ++ inlines', blocks' ++ blocks)
         ret -> ret
-    flattenTree0 childs
+    flattenTree0 = strut def . flattenTree0'
+    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 self@CSSBox { display = Inline' disp' } kids) =
+        buildInline' (pattern2font (font self) (font' self) p root) i
+            (Right $ finalizeCSS root p $ StyleTree self { display = disp' } kids)
+            self []
     flattenTree p (i, StyleTree self child@(_:_)) =
         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' parent self) txt]
+            TextSequence ((f, 0), Left zero, inherit $ inner' parent self) txt]
     buildInline f i self childs =
-        InlineBox ((f, i), finalizeBox self f, inner' parent self)
+        buildInline' f i (Left $ finalizeBox self f) self childs
+    buildInline' f i val self childs =
+        InlineBox ((f, i), val, inner' parent self)
                 (Box childs' $ flip applyFontInline f $ txtOpts self)
                 $ resolveBoxOpts f (tableOptions self)
       where childs' = applyBidi (inlineStyles self) childs

@@ 73,7 73,7 @@ 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 | Flex deriving Eq
+    TableColumn | TableColumnGroup | TableCaption | Flex | Inline' Display deriving Eq
 -- | Can the display value contain table-rows?
 rowContainer CSSBox { display = d } =
     d `elem` [Table, TableHeaderGroup, TableRowGroup, TableFooterGroup]


@@ 263,6 263,19 @@ instance PropertyParser a => PropertyParser (CSSBox a) where
         Just self { display=TableCaption }
     longhand _ self "display" [Ident "inline"] = Just self { display = Inline }
     longhand _ self "display" [Ident "flex"] = Just self { display = Flex }
+    longhand _ self "display" [Ident "inline-block"] = Just self { display = Inline' Block }
+    longhand _ self "display" [Ident "inline", Ident "block"] =
+        Just self { display = Inline' Block }
+    longhand _ self "display" [Ident "inline-flex"] = Just self { display = Inline' Flex }
+    longhand _ self "display" [Ident "inline", Ident "flex"] =
+        Just self { display = Inline' Flex }
+    longhand _ self "display" [Ident "inline-grid"] = Just self { display = Inline' Grid }
+    longhand _ self "display" [Ident "inline", Ident "grid"] =
+        Just self { display = Inline' Grid }
+    longhand _ self "display" [Ident "inline-table"] = Just self { display = Inline' Table }
+    longhand _ self "display" [Ident "inline", Ident "table"] =
+        Just self { display = Inline' Table}
+    longhand p self "display" (Ident "block":v) = longhand p self "display" v
     longhand _ self "display" [Ident "initial"] = Just self { display = Inline }
 
     longhand _ self "orphans" [Number _ (NVInteger x)] =

@@ 33,19 33,21 @@ unscale :: CastDouble x => x -> Int32
 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 = layoutSize' . flip layoutRich' 0
+inlineMin :: (CastDouble x, CastDouble y) => (z -> PaddedBox x y) ->
+        Paragraph (a, Either (PaddedBox x y) z, c) -> Size x y
+inlineMin cb self = layoutSize' $ layoutRich' cb self 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@(Paragraph _ _ _ opts) =
-    layoutSize' . layoutRich' self $ paragraphMaxWidth opts
+inlineSize :: (CastDouble x, CastDouble y) => (z -> PaddedBox x y) ->
+        Paragraph (a, Either (PaddedBox x y) z, c) -> Size x y
+inlineSize cb self@(Paragraph _ _ _ opts) =
+    layoutSize' . layoutRich' cb 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) =>
-        Paragraph (a, PaddedBox x y, c) -> [FragmentTree (a, PaddedBox x y, c)]
-inlineChildren self = layoutChildren $ layoutRich $ lowerSpacing self
+inlineChildren :: (CastDouble x, CastDouble y, Eq x, Eq y, Eq a, Eq c, Eq z) =>
+        (z -> PaddedBox x y) ->
+        Paragraph (a, Either (PaddedBox x y) z, c) ->
+        [FragmentTree (a, Either (PaddedBox x y) z, c)]
+inlineChildren cb self = layoutChildren $ layoutRich $ lowerSpacing cb self
 
 -- | Retrieve a laid-out paragraph's rect & convert to CatTrap types.
 layoutSize :: (CastDouble x, CastDouble y) => ParagraphLayout a -> Size x y


@@ 57,23 59,26 @@ 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 =
+layoutRich' :: (CastDouble m, CastDouble n) => (x -> PaddedBox m n) ->
+        Paragraph (a, Either (PaddedBox m n) x, c) -> Int32 -> Rect Int32
+layoutRich' cb (Paragraph a b c d) width =
     (paragraphRect layout) { x_size = paragraphSafeWidth layout}
   where
-    layout = layoutRich$lowerSpacing$Paragraph a b c d {paragraphMaxWidth=width}
+    layout = layoutRich $ lowerSpacing cb $ 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
+lowerSpacing :: (CastDouble m, CastDouble n) => (x -> PaddedBox m n) ->
+    Paragraph (a, Either (PaddedBox m n) x, c) ->
+    Paragraph (a, Either (PaddedBox m n) x, c)
+lowerSpacing 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, _) child opts) = InlineBox e (inner child) $
         flip activateBoxSpacing opts $
             BoxSpacingLeftRight (leftSpace box) (rightSpace box)
-      where box = mapX' unscale $ mapY' unscale f
+      where box = mapX' unscale $ mapY' unscale $ mapRight cb f
     inner' self@(TextSequence _ _) = self
 
 


@@ 120,13 125,9 @@ fragmentSize :: (CastDouble x, CastDouble 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 :: FragmentTree (a, b, 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.


@@ 182,16 183,16 @@ reconstructTree' frags@(Fragment {
 reconstructTree' [] = []
 
 -- | Add an X,Y offset to all positions, annotating the userdata.
-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
+positionTree :: (Double, Double) -> ((Double, Double) -> b -> b') ->
+        FragmentTree (a, b, c) -> FragmentTree (a, b', ((Double, Double), c))
+positionTree (x, y) cb self@(Branch (AncestorBox (a, b, c) d e f g) childs) =
+    Branch (AncestorBox (a, cb pos b, (pos, c)) d e f g) $
+        map (positionTree pos cb) 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 i)) =
-    Leaf (Fragment (a, b, (pos, c)) d [] f g h i)
+positionTree (x, y) cb self@(Leaf (Fragment (a, b, c) d _ f g h i)) =
+    Leaf (Fragment (a, cb pos b, (pos, c)) d [] f g h i)
   where
     pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))
     rect = treeRect self


@@ 234,3 235,10 @@ union a b = Rect x_low y_high dx (-dy) where
     y_high = y_max a `max` y_max b
     dx = x_high - x_low
     dy = y_high - y_low
+
+------
+--- Supporting utils
+------
+
+mapRight cb (Right self) = cb self
+mapRight _ (Left ret) = ret

@@ 2,7 2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                cattrap
-version:             0.4.0.0
+version:             0.5.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/