module ShapeK(dynShapeK, shapeK) where
import Command(XCommand(FreeGC,FreePixmap,ShapeCombineMask,DrawMany))
import XDraw
import CompFfun(prepostMapHigh')
import Convgc
import LayoutRequest(LayoutResponse(..))
import FRequest
import Gc
import Fudget
import Xcommand
import NullF
import ParK
import Pixmap
import EitherUtils(stripEither)
import Data.Maybe(fromJust)
import Geometry(pP,Rect(..),origin,Size)
import Xtypes
dynShapeK :: [GCAttributes ColorName ColorName]
-> (Size -> [DrawCommand])
-> K c d
-> K (Either (Size -> [DrawCommand]) c) (Either b d)
dynShapeK [GCAttributes ColorName ColorName]
gcattrs Size -> [DrawCommand]
shapeCmds K c d
f = forall a b c d. K a b -> K c d -> K (Either a c) (Either b d)
compK (forall {ho}.
[GCAttributes ColorName ColorName]
-> (Size -> [DrawCommand]) -> K (Size -> [DrawCommand]) ho
shapeK1 [GCAttributes ColorName ColorName]
gcattrs Size -> [DrawCommand]
shapeCmds) K c d
f
shapeK :: (Size -> [DrawCommand]) -> K a b -> K a b
shapeK :: forall a b. (Size -> [DrawCommand]) -> K a b -> K a b
shapeK Size -> [DrawCommand]
shapeCmds K a b
f =
forall hi ho. KSP hi ho -> K hi ho
K (forall a b c d e f.
(a -> b) -> (c -> d) -> Fa e f b c -> Fa e f a d
prepostMapHigh' forall a b. b -> Either a b
Right forall {a}. Either a a -> a
stripEither forall {b}. KSP (Either (Size -> [DrawCommand]) a) (Either b b)
dk)
where
K KSP (Either (Size -> [DrawCommand]) a) (Either b b)
dk = forall {c} {d} {b}.
[GCAttributes ColorName ColorName]
-> (Size -> [DrawCommand])
-> K c d
-> K (Either (Size -> [DrawCommand]) c) (Either b d)
dynShapeK [] Size -> [DrawCommand]
shapeCmds K a b
f
shapeK1 :: [GCAttributes ColorName ColorName]
-> (Size -> [DrawCommand]) -> K (Size -> [DrawCommand]) ho
shapeK1 [GCAttributes ColorName ColorName]
gcattrs Size -> [DrawCommand]
shape =
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
[GCAttributes ColorName ColorName]
-> ([GCAttributes Pixel FontId] -> f hi ho) -> f hi ho
convGCattrsK [GCAttributes ColorName ColorName]
gcattrs (\[GCAttributes Pixel FontId]
gcattrs' -> forall {ho}.
[GCAttributes Pixel FontId]
-> (Size -> [DrawCommand])
-> Maybe Size
-> K (Size -> [DrawCommand]) ho
shapeP [GCAttributes Pixel FontId]
gcattrs' Size -> [DrawCommand]
shape forall a. Maybe a
Nothing)
shapeP :: [GCAttributes Pixel FontId]
-> (Size -> [DrawCommand])
-> Maybe Size
-> K (Size -> [DrawCommand]) ho
shapeP [GCAttributes Pixel FontId]
gcattrs Size -> [DrawCommand]
shape Maybe Size
size =
let reshape :: (Size -> [DrawCommand]) -> Size -> K (Size -> [DrawCommand]) ho
reshape Size -> [DrawCommand]
shape' Size
size' =
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
Size -> Depth -> (PixmapId -> f hi ho) -> f hi ho
createPixmap Size
size' Depth
1 forall a b. (a -> b) -> a -> b
$ \PixmapId
pm ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
PixmapId
-> GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> f hi ho)
-> f hi ho
pmCreateGC PixmapId
pm GCId
rootGC [forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy, forall a b. a -> GCAttributes a b
GCForeground Pixel
pixel0] forall a b. (a -> b) -> a -> b
$ \GCId
gcclr ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
PixmapId
-> GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> f hi ho)
-> f hi ho
pmCreateGC PixmapId
pm GCId
gcclr (forall a b. a -> GCAttributes a b
GCForeground Pixel
pixel1 forall a. a -> [a] -> [a]
:
forall a b. a -> GCAttributes a b
GCBackground Pixel
pixel0 forall a. a -> [a] -> [a]
:
[GCAttributes Pixel FontId]
gcattrs) forall a b. (a -> b) -> a -> b
$ \GCId
gc ->
forall {i} {o}. [XCommand] -> K i o -> K i o
xcommandsK [PixmapId
-> Size -> (Size -> [DrawCommand]) -> GCId -> GCId -> XCommand
drawshape PixmapId
pm Size
size' Size -> [DrawCommand]
shape' GCId
gc GCId
gcclr,
ShapeKind -> Size -> PixmapId -> ShapeOperation -> XCommand
ShapeCombineMask ShapeKind
ShapeBounding (Depth -> Depth -> Size
pP Depth
0 Depth
0) PixmapId
pm ShapeOperation
ShapeSet,
PixmapId -> XCommand
FreePixmap PixmapId
pm,
GCId -> XCommand
FreeGC GCId
gcclr,
GCId -> XCommand
FreeGC GCId
gc] forall a b. (a -> b) -> a -> b
$
[GCAttributes Pixel FontId]
-> (Size -> [DrawCommand])
-> Maybe Size
-> K (Size -> [DrawCommand]) ho
shapeP [GCAttributes Pixel FontId]
gcattrs Size -> [DrawCommand]
shape' (forall a. a -> Maybe a
Just Size
size')
in forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ \KEvent (Size -> [DrawCommand])
msg ->
case KEvent (Size -> [DrawCommand])
msg of
Low (LEvt (LayoutSize Size
size')) -> (Size -> [DrawCommand]) -> Size -> K (Size -> [DrawCommand]) ho
reshape Size -> [DrawCommand]
shape Size
size'
High Size -> [DrawCommand]
shape' | Maybe Size
size forall a. Eq a => a -> a -> Bool
/= forall a. Maybe a
Nothing -> (Size -> [DrawCommand]) -> Size -> K (Size -> [DrawCommand]) ho
reshape Size -> [DrawCommand]
shape' (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Size
size)
KEvent (Size -> [DrawCommand])
_ -> [GCAttributes Pixel FontId]
-> (Size -> [DrawCommand])
-> Maybe Size
-> K (Size -> [DrawCommand]) ho
shapeP [GCAttributes Pixel FontId]
gcattrs Size -> [DrawCommand]
shape Maybe Size
size
drawshape :: PixmapId
-> Size -> (Size -> [DrawCommand]) -> GCId -> GCId -> XCommand
drawshape PixmapId
pm Size
size Size -> [DrawCommand]
shapeCmds GCId
gc GCId
gcclr =
Drawable -> [(GCId, [DrawCommand])] -> XCommand
DrawMany (PixmapId -> Drawable
Pixmap PixmapId
pm) [
(GCId
gcclr,[Rect -> DrawCommand
FillRectangle (Size -> Size -> Rect
Rect Size
origin Size
size)]),
(GCId
gc,Size -> [DrawCommand]
shapeCmds Size
size)]