diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -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 -} diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs --- a/Graphics/Layout/Box.hs +++ b/Graphics/Layout/Box.hs @@ -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. diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -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. diff --git a/Graphics/Layout/CSS/Font.hs b/Graphics/Layout/CSS/Font.hs --- a/Graphics/Layout/CSS/Font.hs +++ b/Graphics/Layout/CSS/Font.hs @@ -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 diff --git a/Graphics/Layout/CSS/Length.hs b/Graphics/Layout/CSS/Length.hs --- a/Graphics/Layout/CSS/Length.hs +++ b/Graphics/Layout/CSS/Length.hs @@ -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 diff --git a/Graphics/Layout/CSS/Parse.hs b/Graphics/Layout/CSS/Parse.hs new file mode 100644 --- /dev/null +++ b/Graphics/Layout/CSS/Parse.hs @@ -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 diff --git a/Graphics/Layout/Grid/CSS.hs b/Graphics/Layout/Grid/CSS.hs --- a/Graphics/Layout/Grid/CSS.hs +++ b/Graphics/Layout/Grid/CSS.hs @@ -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") diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs --- a/Graphics/Layout/Inline.hs +++ b/Graphics/Layout/Inline.hs @@ -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 diff --git a/Graphics/Layout/Inline/CSS.hs b/Graphics/Layout/Inline/CSS.hs --- a/Graphics/Layout/Inline/CSS.hs +++ b/Graphics/Layout/Inline/CSS.hs @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/cattrap.cabal b/cattrap.cabal --- a/cattrap.cabal +++ b/cattrap.cabal @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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