diff options
Diffstat (limited to 'lib/Phi/Border.hs')
-rw-r--r-- | lib/Phi/Border.hs | 67 |
1 files changed, 50 insertions, 17 deletions
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs index c9b582e..c6e7531 100644 --- a/lib/Phi/Border.hs +++ b/lib/Phi/Border.hs @@ -53,19 +53,21 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0 , borderWeight = 1 } -data Border w d = (Widget w d) => Border !BorderConfig !w -deriving instance Show (Border w d) -deriving instance Eq (Border w d) +data Border w s c = (Widget w s c) => Border !BorderConfig !w +deriving instance Show (Border w s c) +deriving instance Eq (Border w s c) -instance Eq d => Widget (Border w d) d where +data BorderCache w s c = (Widget w s c) => BorderCache !c + +instance Eq s => Widget (Border w s c) s (BorderCache w s c) where initWidget (Border _ w) = initWidget w - minSize (Border config w) d height screen = + minSize (Border config w) s height screen = case True of _ | childSize == 0 -> 0 | otherwise -> max (borderH m+2*(bw+cr)) (childSize + borderH p + 2*bw + borderH m) where - childSize = minSize w d height' screen + childSize = minSize w s height' screen m = margin config bw = borderWidth config @@ -75,9 +77,9 @@ instance Eq d => Widget (Border w d) d where weight (Border config _) = borderWeight config - layout (Border config w) d width height screen = case True of - _ | width' > 0 -> layout w d width' height' screen - | otherwise -> d + layout (Border config w) s width height screen = case True of + _ | width' > 0 -> layout w s width' height' screen + | otherwise -> s where m = margin config bw = borderWidth config @@ -86,18 +88,49 @@ instance Eq d => Widget (Border w d) d where width' = width - borderH m - 2*bw - borderH p height' = height - borderV m - 2*bw - borderV p - render (Border config w) d x y width height screen = when (width > borderH m - 2*bw - borderH p) $ do - drawBorder config 0 0 width height - clip - translate (fromIntegral dx) (fromIntegral dy) - render w d (x+dx) (y+dy) width' height' screen - return () + render (Border config w) s x y width height screen = case () of + _ | (width > borderH m - 2*bw - borderH p) -> do + border <- createImageSurface FormatARGB32 width height + renderWith border $ do + setOperator OperatorClear + paint + setOperator OperatorOver + drawBorder config 0 0 width height + surfaces <- render w s (x+dx) (y+dy) width' height' screen + let surfaces' = (True, 0, Nothing):(map (\(updated, SurfaceSlice x surf) -> (updated, x+dx, Just surf)) surfaces)++[(True, width-rightWidth, Nothing)] + surfacesWidths = zipWith (\(updated, x, surf) (_, x', _) -> (updated, x, x'-x, surf)) surfaces' (tail surfaces' ++ [(False, width, Nothing)]) + forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do + surf' <- createImageSurface FormatARGB32 surfWidth height + renderWith surf' $ do + setOperator OperatorClear + paint + setOperator OperatorOver + + save + translate (fromIntegral (-x)) 0 + withPatternForSurface border setSource + paint + restore + + case surf of + Just surface -> do + translate 0 (fromIntegral dy) + withPatternForSurface surface setSource + paint + Nothing -> return () + + return (updated, SurfaceSlice x surf') + | otherwise -> do + surface <- createImageSurface FormatARGB32 width height + return [(True, SurfaceSlice 0 surface)] where m = margin config bw = borderWidth config p = padding config - dx = borderLeft m + bw + borderLeft p + leftWidth = borderLeft m + bw + borderLeft p + rightWidth = borderRight m + bw + borderRight p + dx = leftWidth dy = borderTop m + bw + borderTop p width' = width - borderH m - 2*bw - borderH p height' = height - borderV m - 2*bw - borderV p @@ -139,5 +172,5 @@ roundRectangle x y width height radius = do arc (x + radius) (y + radius) radius pi (pi*3/2) closePath -border :: (Widget w d) => BorderConfig -> w -> Border w d +border :: (Widget w s c) => BorderConfig -> w -> Border w s c border = Border |