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 = K (Size -> [DrawCommand]) b
-> K c d -> K (Either (Size -> [DrawCommand]) c) (Either b d)
forall a b c d. K a b -> K c d -> K (Either a c) (Either b d)
compK ([GCAttributes ColorName ColorName]
-> (Size -> [DrawCommand]) -> K (Size -> [DrawCommand]) b
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 :: (Size -> [DrawCommand]) -> K a b -> K a b
shapeK Size -> [DrawCommand]
shapeCmds K a b
f =
KSP a b -> K a b
forall hi ho. KSP hi ho -> K hi ho
K ((a -> Either (Size -> [DrawCommand]) a)
-> (Either b b -> b)
-> Fa
FResponse FRequest (Either (Size -> [DrawCommand]) a) (Either b b)
-> KSP a b
forall a b c d e f.
(a -> b) -> (c -> d) -> Fa e f b c -> Fa e f a d
prepostMapHigh' a -> Either (Size -> [DrawCommand]) a
forall a b. b -> Either a b
Right Either b b -> b
forall p. Either p p -> p
stripEither Fa
FResponse FRequest (Either (Size -> [DrawCommand]) a) (Either b b)
forall b. KSP (Either (Size -> [DrawCommand]) a) (Either b b)
dk)
where
K KSP (Either (Size -> [DrawCommand]) a) (Either b b)
dk = [GCAttributes ColorName ColorName]
-> (Size -> [DrawCommand])
-> K a b
-> K (Either (Size -> [DrawCommand]) a) (Either b b)
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 =
[GCAttributes ColorName ColorName]
-> ([GCAttributes Pixel FontId] -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
[GCAttributes ColorName ColorName]
-> ([GCAttributes Pixel FontId] -> f b ho) -> f b ho
convGCattrsK [GCAttributes ColorName ColorName]
gcattrs (\[GCAttributes Pixel FontId]
gcattrs' -> [GCAttributes Pixel FontId]
-> (Size -> [DrawCommand])
-> Maybe Size
-> K (Size -> [DrawCommand]) ho
forall ho.
[GCAttributes Pixel FontId]
-> (Size -> [DrawCommand])
-> Maybe Size
-> K (Size -> [DrawCommand]) ho
shapeP [GCAttributes Pixel FontId]
gcattrs' Size -> [DrawCommand]
shape Maybe Size
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' =
Size
-> Int
-> (PixmapId -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
Size -> Int -> (PixmapId -> f b ho) -> f b ho
createPixmap Size
size' Int
1 ((PixmapId -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho)
-> (PixmapId -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho
forall a b. (a -> b) -> a -> b
$ \PixmapId
pm ->
PixmapId
-> GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
PixmapId
-> GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> f b ho)
-> f b ho
pmCreateGC PixmapId
pm GCId
rootGC [GCFunction -> GCAttributes Pixel FontId
forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy, Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCForeground Pixel
pixel0] ((GCId -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho)
-> (GCId -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho
forall a b. (a -> b) -> a -> b
$ \GCId
gcclr ->
PixmapId
-> GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
PixmapId
-> GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> f b ho)
-> f b ho
pmCreateGC PixmapId
pm GCId
gcclr (Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCForeground Pixel
pixel1 GCAttributes Pixel FontId
-> [GCAttributes Pixel FontId] -> [GCAttributes Pixel FontId]
forall a. a -> [a] -> [a]
:
Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCBackground Pixel
pixel0 GCAttributes Pixel FontId
-> [GCAttributes Pixel FontId] -> [GCAttributes Pixel FontId]
forall a. a -> [a] -> [a]
:
[GCAttributes Pixel FontId]
gcattrs) ((GCId -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho)
-> (GCId -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho
forall a b. (a -> b) -> a -> b
$ \GCId
gc ->
[XCommand]
-> K (Size -> [DrawCommand]) ho -> K (Size -> [DrawCommand]) ho
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 (Int -> Int -> Size
pP Int
0 Int
0) PixmapId
pm ShapeOperation
ShapeSet,
PixmapId -> XCommand
FreePixmap PixmapId
pm,
GCId -> XCommand
FreeGC GCId
gcclr,
GCId -> XCommand
FreeGC GCId
gc] (K (Size -> [DrawCommand]) ho -> K (Size -> [DrawCommand]) ho)
-> K (Size -> [DrawCommand]) ho -> K (Size -> [DrawCommand]) ho
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' (Size -> Maybe Size
forall a. a -> Maybe a
Just Size
size')
in Cont
(K (Size -> [DrawCommand]) ho) (KEvent (Size -> [DrawCommand]))
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont
(K (Size -> [DrawCommand]) ho) (KEvent (Size -> [DrawCommand]))
-> Cont
(K (Size -> [DrawCommand]) ho) (KEvent (Size -> [DrawCommand]))
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 Maybe Size -> Maybe Size -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Size
forall a. Maybe a
Nothing -> (Size -> [DrawCommand]) -> Size -> K (Size -> [DrawCommand]) ho
reshape Size -> [DrawCommand]
shape' (Maybe Size -> Size
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)]