5 files changed, 115 insertions(+), 15 deletions(-)

M Graphics/Layout.hs
M Graphics/Layout/Box.hs
M Graphics/Layout/CSS.hs
M Graphics/Layout/CSS/Internal.hs
M cattrap.cabal

@@ 1,30 1,50 @@
 {-# LANGUAGE OverloadedStrings, RecordWildCards #-}
 module Graphics.Layout where
 
+import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..), Fragment)
+
 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 Data.Maybe (fromMaybe)
 
 data LayoutItem m n x =
     LayoutFlow x (PaddedBox m n) [LayoutItem m n x]
     | LayoutGrid x (Grid m n) [(GridItem m n, LayoutItem m n x)]
+    | LayoutInline x Paragraph [x] -- Balkon holds children.
+    | LayoutSpan x Fragment
 -- More to come...
 
+layoutGetBox :: (Zero m, Zero n, CastDouble m, CastDouble n) =>
+        LayoutItem m n x -> PaddedBox m n
 layoutGetBox (LayoutFlow _ ret _) = ret
 layoutGetBox (LayoutGrid _ self _) = zero {
     B.min = containerMin self,
     B.size = containerSize self,
     B.max = containerMax self
 }
-setCellBox' (child, cell) = cell { gridItemBox = layoutGetBox child }
+layoutGetBox (LayoutInline _ self _) = zero {
+    B.min = inlineSize self, B.size = inlineSize self, B.max = inlineSize self
+}
+layoutGetBox (LayoutSpan _ self) = zero {
+    B.min = fragmentSize self, B.size = fragmentSize self, B.max = fragmentSize self
+}
 layoutGetChilds (LayoutFlow _ _ ret) = ret
 layoutGetChilds (LayoutGrid _ _ ret) = map snd ret
+layoutGetChilds (LayoutSpan _ _) = []
+layoutGetChilds (LayoutInline _ self vals) =
+    map (uncurry LayoutSpan) $ inlineChildren vals self
 layoutGetInner (LayoutFlow ret _ _) = ret
 layoutGetInner (LayoutGrid ret _ _) = ret
+layoutGetInner (LayoutInline ret _ _) = ret
+layoutGetInner (LayoutSpan ret _) = ret
+
+setCellBox' (child, cell) = cell { gridItemBox = layoutGetBox child }
 
-boxMinWidth :: Zero y => Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x)
+boxMinWidth :: (Zero y, CastDouble y) =>
+        Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x)
 boxMinWidth parent (LayoutFlow val self childs) = (min', LayoutFlow val self' childs')
   where
     self' = self {B.min = Size (Pixels min') (block $ B.min self) }


@@ 52,7 72,10 @@ boxMinWidth parent (LayoutGrid val self childs) =
         (GridItem {..}, _) <- childs]) parent
     zeroBox :: PaddedBox Double Double
     zeroBox = zero
-boxNatWidth :: Zero y => Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x)
+boxMinWidth _ self@(LayoutInline _ self' _) = (inlineMinWidth self', self)
+boxMinWidth _ self@(LayoutSpan _ self') = (B.inline $ fragmentSize' self', self)
+boxNatWidth :: (Zero y, CastDouble y) =>
+        Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x)
 boxNatWidth parent (LayoutFlow val self childs) = (size', LayoutFlow val self childs')
   -- NOTE: Need to preserve auto/percentage in actual width calculation.
   -- self' doesn't preserve this. CatTrap will need a decent refactor!


@@ 84,6 107,8 @@ boxNatWidth parent (LayoutGrid val self childs) =
         (GridItem {..}, _) <- childs]) parent
     zeroBox :: PaddedBox Double Double
     zeroBox = zero
+boxNatWidth _ self@(LayoutInline _ self' _) = (inlineNatWidth self', self)
+boxNatWidth _ self@(LayoutSpan _ self') = (B.inline $ fragmentSize' self', self)
 boxMaxWidth :: PaddedBox a Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x)
 boxMaxWidth parent (LayoutFlow val self childs) = (max', LayoutFlow val self' childs)
   where


@@ 94,7 119,9 @@ boxMaxWidth parent (LayoutGrid val self childs) =
   where
     self' = self { containerMax = Size (Pixels max') (block $ containerMax self) }
     (max', _) = gridMaxWidths parent self $ colBounds self
-boxWidth :: Zero y => PaddedBox b Double -> LayoutItem y Length x ->
+boxMaxWidth parent self@(LayoutInline _ _ _) = (B.inline $ B.max parent, self)
+boxMaxWidth parent self@(LayoutSpan _ self') = (B.inline $ fragmentSize' self', self)
+boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length x ->
         (Double, LayoutItem y Double x)
 boxWidth parent (LayoutFlow val self childs) = (size', LayoutFlow val self' childs')
   where


@@ 129,6 156,11 @@ boxWidth parent (LayoutGrid val self childs) = (size', LayoutGrid val self' chil
       }
     outerwidth = inline $ size parent
     (size', widths) = gridWidths parent self $ colBounds self
+boxWidth parent (LayoutInline val (Paragraph a b c d) vals) =
+    (width, LayoutInline val (Paragraph a b c d { paragraphMaxWidth = round width }) vals)
+  where width = B.inline $ B.size parent
+boxWidth parent (LayoutSpan val self') =
+    (B.inline $ fragmentSize' self', LayoutSpan val self')
 
 boxNatHeight :: Double -> LayoutItem Length Double x -> (Double, LayoutItem Length Double x)
 boxNatHeight parent (LayoutFlow val self childs) = (size', LayoutFlow val self' childs')


@@ 153,6 185,8 @@ boxNatHeight parent (LayoutGrid val self childs) =
     cells = map setCellBox' $ zip childs' $ map fst childs
     childs' = map snd $ map (boxNatHeight width) $ map snd childs
     width = inline $ containerSize self
+boxNatHeight parent self@(LayoutInline _ self' _) = (inlineHeight parent self', self)
+boxNatHeight parent self@(LayoutSpan _ self') = (B.block $ fragmentSize' self', self)
 boxMinHeight :: Double -> LayoutItem Length Double x -> (Double, LayoutItem Length Double x)
 boxMinHeight parent (LayoutFlow val self childs) = (min', LayoutFlow val self' childs')
   where


@@ 179,6 213,8 @@ boxMinHeight parent (LayoutGrid val self childs) = (min', LayoutGrid val self' c
         startCol = startCol cell, endCol = endCol cell, alignment = alignment cell
       } | (cell, _) <- childs]
     width = inline $ containerSize self
+boxMinHeight parent self@(LayoutInline _ self' _) = (inlineHeight parent self', self)
+boxMinHeight parent self@(LayoutSpan _ self') = (B.block $ fragmentSize' self', self)
 boxMaxHeight :: PaddedBox Double Double -> LayoutItem Length Double x ->
         (Double, LayoutItem Length Double x)
 boxMaxHeight parent (LayoutFlow val self childs) = (max', LayoutFlow val self' childs')


@@ 207,6 243,10 @@ boxMaxHeight parent (LayoutGrid val self childs) = (max', LayoutGrid val self' c
       }
     (max', heights) = gridMaxHeights parent self $ rowBounds self
     width = inline $ size parent
+boxMaxHeight parent (LayoutInline val self' vals) =
+    (inlineHeight (B.inline $ B.size parent) self', LayoutInline val self' vals)
+boxMaxHeight parent (LayoutSpan val self') =
+    (B.block $ fragmentSize' self', LayoutSpan val self')
 boxHeight :: PaddedBox Double Double -> LayoutItem Length Double x ->
         (Double, LayoutItem Double Double x)
 boxHeight parent (LayoutFlow val self childs) = (size', LayoutFlow val self' childs')


@@ 238,6 278,9 @@ boxHeight parent (LayoutGrid val self childs) = (size', LayoutGrid val self' chi
     lowerSize (Left x) = Left $ lowerLength width x
     lowerSize (Right x) = Right x
     width = inline $ size parent
+boxHeight parent (LayoutInline val self' vals) =
+    (inlineHeight (B.inline $ B.size parent) self', LayoutInline val self' vals)
+boxHeight _ (LayoutSpan val self') = (B.block $ fragmentSize' self', LayoutSpan val self')
 
 boxPosition :: (Double, Double) -> LayoutItem Double Double x ->
     LayoutItem Double Double ((Double, Double), x)


@@ 251,6 294,10 @@ boxPosition pos@(x, y) (LayoutGrid val self childs) = LayoutGrid (pos, val) self
     childs' = map recurse $ zip pos' childs
     recurse ((Size x' y'), (cell, child)) = (cell, boxPosition (x + x', y + y') child)
     pos' = gridPosition self $ map fst childs
+boxPosition pos@(x, y) (LayoutInline val self vals) =
+    LayoutInline (pos, val) self $ map (\(x, y) -> (fragmentPos pos y, x)) $
+            inlineChildren vals self
+boxPosition pos (LayoutSpan val self) = LayoutSpan (pos, val) self -- No children...
 boxLayout :: PaddedBox Double Double -> LayoutItem Length Length x -> Bool ->
         LayoutItem Double Double ((Double, Double), x)
 boxLayout parent self paginate = self8

@@ 92,3 92,11 @@ instance (Zero m, Zero n) => Zero (PaddedBox m n) where
     border = Border zero zero zero zero,
     margin = Border zero zero zero zero
     }
+
+class CastDouble a where
+    fromDouble :: Double -> a
+fromIntegral' :: (Integral a, CastDouble b) => a -> b
+fromIntegral' = fromDouble . fromIntegral
+
+instance CastDouble Double where fromDouble = id
+instance CastDouble Length where fromDouble = Pixels

@@ 11,6 11,7 @@ import Graphics.Layout
 import Graphics.Text.Font.Choose (Pattern(..))
 import Graphics.Layout.CSS.Internal
 import Graphics.Layout.Grid.CSS
+import Graphics.Layout.Inline.CSS
 
 data CSSBox a = CSSBox {
     display :: Display,


@@ 21,12 22,13 @@ data CSSBox a = CSSBox {
     inner :: a,
     gridStyles :: CSSGrid,
     cellStyles :: CSSCell,
+    inlineStyles :: CSSInline,
     captionBelow :: Bool
 }
 data BoxSizing = BorderBox | ContentBox
 noborder = Border (0,"px") (0,"px") (0,"px") (0,"px")
 
-data Display = Block | Grid | Table |
+data Display = Block | Grid | Inline | Table |
     TableRow | TableHeaderGroup | TableRowGroup | TableFooterGroup | TableCell |
     TableColumn | TableColumnGroup | TableCaption deriving Eq
 rowContainer CSSBox { display = d } =


@@ 49,6 51,7 @@ instance PropertyParser a => PropertyParser (CSSBox a) where
         inner = temp,
         gridStyles = temp,
         cellStyles = temp,
+        inlineStyles = temp,
         captionBelow = False
       }
     inherit parent = CSSBox {


@@ 60,6 63,7 @@ instance PropertyParser a => PropertyParser (CSSBox a) where
         inner = inherit $ inner parent,
         gridStyles = inherit $ gridStyles parent,
         cellStyles = inherit $ cellStyles parent,
+        inlineStyles = inherit $ inlineStyles parent,
         captionBelow = captionBelow parent
       }
 


@@ 124,7 128,8 @@ instance PropertyParser a => PropertyParser (CSSBox a) where
         Just self { display = TableColumn }
     longhand CSSBox { display = Table } self "display" [Ident "table-caption"] =
         Just self { display=TableCaption }
-    longhand _ self "display" [Ident "initial"] = Just self {display = Block }
+    longhand _ self "display" [Ident "inline"] = Just self { display = Inline }
+    longhand _ self "display" [Ident "initial"] = Just self { display = Block }
 
     longhand _ self "caption-side" [Ident "top"] = Just self { captionBelow = False }
     longhand _ self "caption-side" [Ident "bottom"] = Just self { captionBelow = True }


@@ 139,6 144,12 @@ instance PropertyParser a => PropertyParser (CSSBox a) where
     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'
       }


@@ 164,7 175,7 @@ finalizeCSS root parent self@StyleTree {
 finalizeCSS root parent self@StyleTree {
         style = self'@CSSBox { display = Table, captionBelow = True }, children = childs
     } = LayoutFlow (inner self') (finalizeBox self' font_)
-        (finalizeTable root font_ (inner self') childs:
+        (finalizeTable root font_ temp childs:
         [finalizeCSS root font_ child { style = child' { display = Block } }
             | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs])
   where


@@ 177,6 188,34 @@ finalizeCSS root parent self@StyleTree {
 finalizeCSS' sysfont self@StyleTree { style = self' } =
     finalizeCSS (pattern2font (font self') (font' self') sysfont sysfont) sysfont self
 
+finalizeChilds :: PropertyParser x => Font' -> Font' -> [StyleTree (CSSBox x)] ->
+        [LayoutItem Length Length x]
+finalizeChilds root parent childs@(child:childs')
+    | isInlineTree childs =
+        -- FIXME propagate display properties, how to handle the hierarchy.
+        [LayoutInline temp (finalizeParagraph (flattenTree childs) parent) (repeat temp)]
+    | (inlines@(_:_), blocks) <- spanInlines childs =
+        LayoutInline temp (finalizeParagraph (flattenTree childs) parent) []
+            :finalizeChilds root parent blocks
+    | otherwise = finalizeCSS root parent child : finalizeChilds root parent childs'
+  where
+    isInlineTree = all (isInlineTree . children)
+    isInlineTree0 StyleTree { style = CSSBox { display = Inline }, children = childs } =
+        isInlineTree childs
+    isInlineTree0 _ = False
+    spanInlines childs = case span isInlineTree0 childs of
+        (inlines, (StyleTree {
+            style = CSSBox { display = Inline }, children = tail
+          }: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 "" []
+finalizeChilds _ _ [] = []
+
 finalizeBox self@CSSBox { cssBox = box } font_ =
     mapY' (flip finalizeLength font_) $ mapX' (flip finalizeLength font_) box
 

@@ 64,6 64,7 @@ finalizeLength (_,"max-content") _ = Preferred
 finalizeLength (_,unit) _ = trace ("Invalid unit " ++ Txt.unpack unit) $ Pixels 0
 
 data Font' = Font' {
+    hbFont :: Maybe Font, -- Optional for sake of demo script, FIXME better solution?
     fontHeight :: Char -> Double,
     fontAdvance :: Char -> Double,
     fontSize :: Double,


@@ 76,14 77,16 @@ data Font' = Font' {
     vmin :: Double,
     scale :: Double
 }
-placeholderFont = Font' (const 0) (const 0) 0 0 0 0  0 0 0 0  1
+placeholderFont = Font' Nothing (const 0) (const 0) 0 0 0 0  0 0 0 0  1
+ppem f = fontSize f/scale f
 
-pattern2hbfont :: Pattern -> [Variation] -> Font
-pattern2hbfont pat variations = createFontWithOptions options face
+pattern2hbfont :: Pattern -> Word -> [Variation] -> Font
+pattern2hbfont pat ppem variations = createFontWithOptions options face
   where
     bytes = unsafePerformIO $ B.readFile $ getValue0 "file" pat
     face = createFace bytes $ toEnum $ fromMaybe 0 $ getValue' "index" pat
-    options = foldl value2opt defaultFontOptions $ normalizePattern pat
+    options = foldl value2opt defaultFontOptions { optionPPEm = Just (ppem, ppem) } $
+                normalizePattern pat
 
     value2opt opts ("slant", (_, ValueInt x):_) = opts {
         optionSynthSlant = Just $ realToFrac x


@@ 93,6 96,7 @@ pattern2hbfont pat variations = createFontWithOptions options face
 
 pattern2font :: Pattern -> CSSFont -> Font' -> Font' -> Font'
 pattern2font pat styles parent root = Font' {
+        hbFont = Just font',
         fontHeight = height' . fontGlyphExtents font' . fontGlyph',
         fontAdvance = fromIntegral . fontGlyphHAdvance font' . fontGlyph',
         fontSize = fontSize',


@@ 109,12 113,13 @@ pattern2font pat styles parent root = Font' {
         height' (Just x) = fromIntegral $ HB.height x
         height' Nothing = fontSize'
         lineheight' | snd (cssLineheight styles) == "normal",
-            Just extents <- fontHExtents font' = fromIntegral $ lineGap extents
+            Just extents <- fontHExtents font' = (fromIntegral $ lineGap extents)/ppem
             | otherwise = lowerLength' (cssLineheight styles) parent
         fontSize' = lowerLength' (cssFontSize styles) parent
         lowerLength' a = lowerLength (fontSize parent) . finalizeLength a
         fontGlyph' ch = fromMaybe 0 $ fontGlyph font' ch Nothing
-        font' = pattern2hbfont pat $ variations' fontSize' styles
+        font' = pattern2hbfont pat (round ppem) $ variations' fontSize' styles
+        ppem = fontSize'/scale root
 
 data CSSFont = CSSFont {
     cssFontSize :: Unitted,

@@ 19,10 19,11 @@ cabal-version:       >=1.10
 library
   exposed-modules:     Graphics.Layout, Graphics.Layout.CSS, Graphics.Layout.Flow,
                         Graphics.Layout.Grid, Graphics.Layout.Box, Graphics.Layout.Arithmetic,
-                        Graphics.Layout.CSS.Internal, Graphics.Layout.Grid.CSS
+                        Graphics.Layout.CSS.Internal, Graphics.Layout.Grid.CSS,
+                        Graphics.Layout.Inline, Graphics.Layout.Inline.CSS
   -- other-modules:
   -- other-extensions:
-  build-depends:       base >=4.12 && <4.16, css-syntax, scientific, text, stylist-traits, fontconfig-pure, harfbuzz-pure, bytestring
+  build-depends:       base >=4.12 && <4.16, css-syntax, scientific, text, stylist-traits, fontconfig-pure, harfbuzz-pure, bytestring, balkon
   -- hs-source-dirs:
   default-language:    Haskell2010
   ghc-options:         -Wincomplete-patterns