module ShapeK(dynShapeK, shapeK) where
import Command(XCommand(FreeGC,FreePixmap,ShapeCombineMask,DrawMany))
import XDraw
import CompFfun(prepostMapHigh')
import Convgc
--import Event
import LayoutRequest(LayoutResponse(..))
import FRequest
import Gc
import Fudget
--import FudgetIO
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{-kk-} (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)]