module Convgc(convGCattrsK) where
import Color
import LoadFont
import Xtypes
import EitherUtils()
convGCattrsK :: [GCAttributes ColorName ColorName]
-> ([GCAttributes Pixel FontId] -> f hi ho) -> f hi ho
convGCattrsK [GCAttributes ColorName ColorName]
attrs = forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
[GCAttributes ColorName ColorName]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> f hi ho)
-> f hi ho
gcattrsK [GCAttributes ColorName ColorName]
attrs []
gcattrsK :: [GCAttributes ColorName ColorName]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> f hi ho)
-> f hi ho
gcattrsK [] [GCAttributes Pixel FontId]
outattrs [GCAttributes Pixel FontId] -> f hi ho
dr = [GCAttributes Pixel FontId] -> f hi ho
dr (forall a. [a] -> [a]
reverse [GCAttributes Pixel FontId]
outattrs)
gcattrsK (GCAttributes ColorName ColorName
attr : [GCAttributes ColorName ColorName]
attrs) [GCAttributes Pixel FontId]
outattrs [GCAttributes Pixel FontId] -> f hi ho
dr =
let cp :: GCAttributes Pixel FontId -> f hi ho
cp GCAttributes Pixel FontId
attr' = [GCAttributes ColorName ColorName]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> f hi ho)
-> f hi ho
gcattrsK [GCAttributes ColorName ColorName]
attrs (GCAttributes Pixel FontId
attr' forall a. a -> [a] -> [a]
: [GCAttributes Pixel FontId]
outattrs) [GCAttributes Pixel FontId] -> f hi ho
dr
in case GCAttributes ColorName ColorName
attr of
GCForeground ColorName
colname ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> ColorName -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap ColorName
colname forall a b. (a -> b) -> a -> b
$ \Pixel
fg ->
[GCAttributes ColorName ColorName]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> f hi ho)
-> f hi ho
gcattrsK [GCAttributes ColorName ColorName]
attrs (forall a b. a -> GCAttributes a b
GCForeground Pixel
fg forall a. a -> [a] -> [a]
: [GCAttributes Pixel FontId]
outattrs) [GCAttributes Pixel FontId] -> f hi ho
dr
GCBackground ColorName
colname ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColormapId -> ColorName -> Cont (f hi ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap ColorName
colname forall a b. (a -> b) -> a -> b
$ \Pixel
fg ->
[GCAttributes ColorName ColorName]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> f hi ho)
-> f hi ho
gcattrsK [GCAttributes ColorName ColorName]
attrs (forall a b. a -> GCAttributes a b
GCBackground Pixel
fg forall a. a -> [a] -> [a]
: [GCAttributes Pixel FontId]
outattrs) [GCAttributes Pixel FontId] -> f hi ho
dr
GCFont ColorName
fname ->
forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
ColorName -> (FontId -> f hi ho) -> f hi ho
loadFont ColorName
fname forall a b. (a -> b) -> a -> b
$ \FontId
font ->
[GCAttributes ColorName ColorName]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> f hi ho)
-> f hi ho
gcattrsK [GCAttributes ColorName ColorName]
attrs (forall a b. b -> GCAttributes a b
GCFont FontId
font forall a. a -> [a] -> [a]
: [GCAttributes Pixel FontId]
outattrs) [GCAttributes Pixel FontId] -> f hi ho
dr
GCFunction GCFunction
f -> GCAttributes Pixel FontId -> f hi ho
cp (forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
f)
GCLineWidth Width
w -> GCAttributes Pixel FontId -> f hi ho
cp (forall a b. Width -> GCAttributes a b
GCLineWidth Width
w)
GCLineStyle GCLineStyle
s -> GCAttributes Pixel FontId -> f hi ho
cp (forall a b. GCLineStyle -> GCAttributes a b
GCLineStyle GCLineStyle
s)
GCCapStyle GCCapStyle
s -> GCAttributes Pixel FontId -> f hi ho
cp (forall a b. GCCapStyle -> GCAttributes a b
GCCapStyle GCCapStyle
s)
GCJoinStyle GCJoinStyle
s -> GCAttributes Pixel FontId -> f hi ho
cp (forall a b. GCJoinStyle -> GCAttributes a b
GCJoinStyle GCJoinStyle
s)
GCSubwindowMode GCSubwindowMode
m -> GCAttributes Pixel FontId -> f hi ho
cp (forall a b. GCSubwindowMode -> GCAttributes a b
GCSubwindowMode GCSubwindowMode
m)
GCGraphicsExposures Bool
b -> GCAttributes Pixel FontId -> f hi ho
cp (forall a b. Bool -> GCAttributes a b
GCGraphicsExposures Bool
b)