module Color(tryAllocColor,tryAllocColorF,
	     allocColor,allocColorF,
	     allocColorPixel,allocColorPixelF,
             tryAllocNamedColor,tryAllocNamedColorF,
	     allocNamedColor,allocNamedColorF,
	     allocNamedColorPixel,allocNamedColorPixelF,
	     allocNamedColorDef,
	     allocNamedColorDefPixel,
	     queryColor,queryColorF
             ) where
import Command
import Event
--import Fudget
import Xrequest
import Xtypes
import Cont
--import NullF(F,K)
import StdIoUtil(echoStderrK)
--import ContinuationIO(stderr)

genTryAlloc :: t -> (t -> (XResponse -> Maybe (Maybe Color)) -> t) -> t
genTryAlloc t
cmd t -> (XResponse -> Maybe (Maybe Color)) -> t
xr =
    let expected :: XResponse -> Maybe (Maybe Color)
expected (ColorAllocated Maybe Color
color) = Maybe Color -> Maybe (Maybe Color)
forall a. a -> Maybe a
Just Maybe Color
color
        expected XResponse
_ = Maybe (Maybe Color)
forall a. Maybe a
Nothing
    in t -> (XResponse -> Maybe (Maybe Color)) -> t
xr t
cmd XResponse -> Maybe (Maybe Color)
expected

genTryAllocColor :: (XRequest -> (XResponse -> Maybe (Maybe Color)) -> t)
-> ColormapId -> RGB -> t
genTryAllocColor XRequest -> (XResponse -> Maybe (Maybe Color)) -> t
xr ColormapId
cmap RGB
rgb = XRequest
-> (XRequest -> (XResponse -> Maybe (Maybe Color)) -> t) -> t
forall t t.
t -> (t -> (XResponse -> Maybe (Maybe Color)) -> t) -> t
genTryAlloc (ColormapId -> RGB -> XRequest
AllocColor ColormapId
cmap RGB
rgb) XRequest -> (XResponse -> Maybe (Maybe Color)) -> t
xr
genTryAllocNamedColor :: (XRequest -> (XResponse -> Maybe (Maybe Color)) -> t)
-> ColormapId -> ColorName -> t
genTryAllocNamedColor XRequest -> (XResponse -> Maybe (Maybe Color)) -> t
xr ColormapId
cmap ColorName
cname = XRequest
-> (XRequest -> (XResponse -> Maybe (Maybe Color)) -> t) -> t
forall t t.
t -> (t -> (XResponse -> Maybe (Maybe Color)) -> t) -> t
genTryAlloc (ColormapId -> ColorName -> XRequest
AllocNamedColor ColormapId
cmap ColorName
cname) XRequest -> (XResponse -> Maybe (Maybe Color)) -> t
xr

tryAllocColor :: ColormapId -> RGB -> (Maybe Color -> f b ho) -> f b ho
tryAllocColor ColormapId
x = (XRequest
 -> (XResponse -> Maybe (Maybe Color))
 -> (Maybe Color -> f b ho)
 -> f b ho)
-> ColormapId -> RGB -> (Maybe Color -> f b ho) -> f b ho
forall t.
(XRequest -> (XResponse -> Maybe (Maybe Color)) -> t)
-> ColormapId -> RGB -> t
genTryAllocColor XRequest
-> (XResponse -> Maybe (Maybe Color))
-> (Maybe Color -> f b ho)
-> f b ho
forall (f :: * -> * -> *) ans b ho.
FudgetIO f =>
XRequest -> (XResponse -> Maybe ans) -> (ans -> f b ho) -> f b ho
xrequest ColormapId
x
tryAllocColorF :: ColormapId -> RGB -> Cont (F b c) (Maybe Color)
tryAllocColorF = (XRequest
 -> (XResponse -> Maybe (Maybe Color))
 -> Cont (F b c) (Maybe Color))
-> ColormapId -> RGB -> Cont (F b c) (Maybe Color)
forall t.
(XRequest -> (XResponse -> Maybe (Maybe Color)) -> t)
-> ColormapId -> RGB -> t
genTryAllocColor XRequest
-> (XResponse -> Maybe (Maybe Color)) -> Cont (F b c) (Maybe Color)
forall a b c. XRequest -> (XResponse -> Maybe a) -> Cont (F b c) a
xrequestF

tryAllocNamedColor :: ColormapId -> ColorName -> (Maybe Color -> f b ho) -> f b ho
tryAllocNamedColor ColormapId
x = (XRequest
 -> (XResponse -> Maybe (Maybe Color))
 -> (Maybe Color -> f b ho)
 -> f b ho)
-> ColormapId -> ColorName -> (Maybe Color -> f b ho) -> f b ho
forall t.
(XRequest -> (XResponse -> Maybe (Maybe Color)) -> t)
-> ColormapId -> ColorName -> t
genTryAllocNamedColor XRequest
-> (XResponse -> Maybe (Maybe Color))
-> (Maybe Color -> f b ho)
-> f b ho
forall (f :: * -> * -> *) ans b ho.
FudgetIO f =>
XRequest -> (XResponse -> Maybe ans) -> (ans -> f b ho) -> f b ho
xrequest ColormapId
x
tryAllocNamedColorF :: ColormapId -> ColorName -> Cont (F b c) (Maybe Color)
tryAllocNamedColorF = (XRequest
 -> (XResponse -> Maybe (Maybe Color))
 -> Cont (F b c) (Maybe Color))
-> ColormapId -> ColorName -> Cont (F b c) (Maybe Color)
forall t.
(XRequest -> (XResponse -> Maybe (Maybe Color)) -> t)
-> ColormapId -> ColorName -> t
genTryAllocNamedColor XRequest
-> (XResponse -> Maybe (Maybe Color)) -> Cont (F b c) (Maybe Color)
forall a b c. XRequest -> (XResponse -> Maybe a) -> Cont (F b c) a
xrequestF

--allocNamedColorDef :: ColormapId -> ColorName -> ColorName -> Cont (K a b) Color
allocNamedColorDef :: ColormapId -> ColorName -> ColorName -> Cont (f b ho) Color
allocNamedColorDef ColormapId
cmap ColorName
cname ColorName
fallback = 
    Cont (f b ho) (Maybe Color)
-> Cont (f b ho) Color -> Cont (f b ho) Color
forall c a. Cont c (Maybe a) -> Cont c a -> Cont c a
tryGet (ColormapId -> ColorName -> Cont (f b ho) (Maybe Color)
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> (Maybe Color -> f b ho) -> f b ho
tryAllocNamedColor ColormapId
cmap ColorName
cname)
	   (ColorName -> f b ho -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColorName -> f b ho -> f b ho
echoStderrK
		      (ColorName
"Warning, cannot allocate background color \""ColorName -> ColorName -> ColorName
forall a. [a] -> [a] -> [a]
++ColorName
cnameColorName -> ColorName -> ColorName
forall a. [a] -> [a] -> [a]
++
		      -- backround ??
		       ColorName
"\", using \""ColorName -> ColorName -> ColorName
forall a. [a] -> [a] -> [a]
++ColorName
fallbackColorName -> ColorName -> ColorName
forall a. [a] -> [a] -> [a]
++ColorName
"\" instead.") (f b ho -> f b ho) -> Cont (f b ho) Color -> Cont (f b ho) Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
	    ColormapId -> ColorName -> Cont (f b ho) Color
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> Cont (f b ho) Color
allocNamedColor ColormapId
cmap ColorName
fallback)

--allocNamedColorDefPixel :: ColormapId -> ColorName -> ColorName -> Cont (K a b) Pixel
allocNamedColorDefPixel :: ColormapId -> ColorName -> ColorName -> (Pixel -> f b ho) -> f b ho
allocNamedColorDefPixel ColormapId
cmap ColorName
cname ColorName
fallback = ColormapId -> ColorName -> ColorName -> Cont (f b ho) Color
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> ColorName -> Cont (f b ho) Color
allocNamedColorDef ColormapId
cmap ColorName
cname ColorName
fallback
  Cont (f b ho) Color
-> ((Pixel -> f b ho) -> Color -> f b ho)
-> (Pixel -> f b ho)
-> f b ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Pixel -> f b ho) -> (Color -> Pixel) -> Color -> f b ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Color -> Pixel
colorPixel)

safe :: (t -> a -> Cont c (Maybe a)) -> t -> a -> Cont c a
safe t -> a -> Cont c (Maybe a)
req t
cmap a
c = Cont c (Maybe a) -> c -> Cont c a
forall c a. Cont c (Maybe a) -> c -> Cont c a
tryM (t -> a -> Cont c (Maybe a)
req t
cmap a
c) (ColorName -> c
forall a. HasCallStack => ColorName -> a
error (ColorName
"Cannot allocate color: "ColorName -> ColorName -> ColorName
forall a. [a] -> [a] -> [a]
++a -> ColorName
forall a. Show a => a -> ColorName
show a
c))

pixel :: (a->b->Cont c Color) -> a->b->Cont c Pixel
pixel :: (a -> b -> Cont c Color) -> a -> b -> Cont c Pixel
pixel a -> b -> Cont c Color
req a
cmap b
c = a -> b -> Cont c Color
req a
cmap b
c Cont c Color -> ((Pixel -> c) -> Color -> c) -> Cont c Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Pixel -> c) -> (Color -> Pixel) -> Color -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Color -> Pixel
colorPixel)

allocNamedColor :: ColormapId -> ColorName -> Cont (f b ho) Color
allocNamedColor ColormapId
x = (ColormapId -> ColorName -> Cont (f b ho) (Maybe Color))
-> ColormapId -> ColorName -> Cont (f b ho) Color
forall a t c a.
Show a =>
(t -> a -> Cont c (Maybe a)) -> t -> a -> Cont c a
safe ColormapId -> ColorName -> Cont (f b ho) (Maybe Color)
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> (Maybe Color -> f b ho) -> f b ho
tryAllocNamedColor ColormapId
x
allocNamedColorF :: ColormapId -> ColorName -> Cont (F b c) Color
allocNamedColorF = (ColormapId -> ColorName -> Cont (F b c) (Maybe Color))
-> ColormapId -> ColorName -> Cont (F b c) Color
forall a t c a.
Show a =>
(t -> a -> Cont c (Maybe a)) -> t -> a -> Cont c a
safe ColormapId -> ColorName -> Cont (F b c) (Maybe Color)
forall b c. ColormapId -> ColorName -> Cont (F b c) (Maybe Color)
tryAllocNamedColorF

allocNamedColorPixel :: ColormapId -> ColorName -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
x = (ColormapId -> ColorName -> Cont (f b ho) Color)
-> ColormapId -> ColorName -> Cont (f b ho) Pixel
forall a b c. (a -> b -> Cont c Color) -> a -> b -> Cont c Pixel
pixel ColormapId -> ColorName -> Cont (f b ho) Color
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> ColorName -> Cont (f b ho) Color
allocNamedColor ColormapId
x
allocNamedColorPixelF :: ColormapId -> ColorName -> Cont (F b c) Pixel
allocNamedColorPixelF = (ColormapId -> ColorName -> Cont (F b c) Color)
-> ColormapId -> ColorName -> Cont (F b c) Pixel
forall a b c. (a -> b -> Cont c Color) -> a -> b -> Cont c Pixel
pixel ColormapId -> ColorName -> Cont (F b c) Color
forall b c. ColormapId -> ColorName -> Cont (F b c) Color
allocNamedColorF

allocColor :: ColormapId -> RGB -> Cont (f b ho) Color
allocColor ColormapId
x = (ColormapId -> RGB -> Cont (f b ho) (Maybe Color))
-> ColormapId -> RGB -> Cont (f b ho) Color
forall a t c a.
Show a =>
(t -> a -> Cont c (Maybe a)) -> t -> a -> Cont c a
safe ColormapId -> RGB -> Cont (f b ho) (Maybe Color)
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> RGB -> (Maybe Color -> f b ho) -> f b ho
tryAllocColor ColormapId
x
allocColorF :: ColormapId -> RGB -> Cont (F b c) Color
allocColorF = (ColormapId -> RGB -> Cont (F b c) (Maybe Color))
-> ColormapId -> RGB -> Cont (F b c) Color
forall a t c a.
Show a =>
(t -> a -> Cont c (Maybe a)) -> t -> a -> Cont c a
safe ColormapId -> RGB -> Cont (F b c) (Maybe Color)
forall b c. ColormapId -> RGB -> Cont (F b c) (Maybe Color)
tryAllocColorF

allocColorPixel :: ColormapId -> RGB -> Cont (f b ho) Pixel
allocColorPixel ColormapId
x = (ColormapId -> RGB -> Cont (f b ho) Color)
-> ColormapId -> RGB -> Cont (f b ho) Pixel
forall a b c. (a -> b -> Cont c Color) -> a -> b -> Cont c Pixel
pixel ColormapId -> RGB -> Cont (f b ho) Color
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> RGB -> Cont (f b ho) Color
allocColor ColormapId
x
allocColorPixelF :: ColormapId -> RGB -> Cont (F b c) Pixel
allocColorPixelF = (ColormapId -> RGB -> Cont (F b c) Color)
-> ColormapId -> RGB -> Cont (F b c) Pixel
forall a b c. (a -> b -> Cont c Color) -> a -> b -> Cont c Pixel
pixel ColormapId -> RGB -> Cont (F b c) Color
forall b c. ColormapId -> RGB -> Cont (F b c) Color
allocColorF

querycolor :: (XRequest -> (XResponse -> Maybe Color) -> t)
-> ColormapId -> Pixel -> t
querycolor XRequest -> (XResponse -> Maybe Color) -> t
xr ColormapId
cmap Pixel
pixel =
    let expected :: XResponse -> Maybe Color
expected (ColorQueried Color
c) = Color -> Maybe Color
forall a. a -> Maybe a
Just Color
c
        expected XResponse
_ = Maybe Color
forall a. Maybe a
Nothing
    in XRequest -> (XResponse -> Maybe Color) -> t
xr (ColormapId -> Pixel -> XRequest
QueryColor ColormapId
cmap Pixel
pixel) XResponse -> Maybe Color
expected

queryColorF :: ColormapId -> Pixel -> Cont (F b c) Color
queryColorF = (XRequest -> (XResponse -> Maybe Color) -> Cont (F b c) Color)
-> ColormapId -> Pixel -> Cont (F b c) Color
forall t.
(XRequest -> (XResponse -> Maybe Color) -> t)
-> ColormapId -> Pixel -> t
querycolor XRequest -> (XResponse -> Maybe Color) -> Cont (F b c) Color
forall a b c. XRequest -> (XResponse -> Maybe a) -> Cont (F b c) a
xrequestF
queryColor :: ColormapId -> Pixel -> (Color -> f b ho) -> f b ho
queryColor ColormapId
x = (XRequest
 -> (XResponse -> Maybe Color) -> (Color -> f b ho) -> f b ho)
-> ColormapId -> Pixel -> (Color -> f b ho) -> f b ho
forall t.
(XRequest -> (XResponse -> Maybe Color) -> t)
-> ColormapId -> Pixel -> t
querycolor XRequest
-> (XResponse -> Maybe Color) -> (Color -> f b ho) -> f b ho
forall (f :: * -> * -> *) ans b ho.
FudgetIO f =>
XRequest -> (XResponse -> Maybe ans) -> (ans -> f b ho) -> f b ho
xrequest ColormapId
x