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 = 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{-kk-} ((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)]