{-# LANGUAGE CPP #-}
module GCAttrs(module GCAttrs,Cont(..)) where
--import Fudget
--import NullF(F,K)
import FudgetIO
import Xtypes
import EitherUtils(Cont(..))
import Font(FontStruct,font_id,font_range, font_prop, update_font_id)
import Color(tryAllocNamedColor,tryAllocColor)
import LoadFont(listFontsWithInfo,loadFont,loadQueryFont)
import FontProperty(fontProperty)
import CmdLineEnv(argKey)
import Utils(aboth,segments)
--import ListUtil(chopList,breakAt)

#include "exists.h"

data FontData
   = FID FontStruct
   | FS FontStruct

fdFontId :: FontData -> FontId
fdFontId (FID FontStruct
fs) = FontStruct -> FontId
forall per_char. FontStructF per_char -> FontId
font_id FontStruct
fs
fdFontId (FS FontStruct
fs) = FontStruct -> FontId
forall per_char. FontStructF per_char -> FontId
font_id FontStruct
fs

fontdata2struct :: FontData -> (FontStruct -> p) -> p
fontdata2struct (FS FontStruct
fs) FontStruct -> p
k = FontStruct -> p
k FontStruct
fs
fontdata2struct (FID FontStruct
fs) FontStruct -> p
k = FontStruct -> p
k FontStruct
fs

--newtype Name = Name String deriving (Eq,Show)
  -- The type Name is used instead of String since String is a type synonym
  -- and therefore can't be made an instance of a class.

#ifdef USE_EXIST_Q
data ColorSpec = EXISTS(a) TSTHACK((Show EQV(a),ColorGen EQV(a)) =>) ColorSpec EQV(a)
 -- deriving Show -- doesn't work because of a HBC bug
instance Show ColorSpec where showsPrec :: Int -> ColorSpec -> ShowS
showsPrec Int
n (ColorSpec a
c) = Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
n a
c

data FontSpec = EXISTS(a) TSTHACK((Show EQV(a),FontGen EQV(a)) =>) FontSpeci EQV(a)
 -- deriving Show -- doesn't work because of a HBC bug
instance Show FontSpec where showsPrec :: Int -> FontSpec -> ShowS
showsPrec Int
n (FontSpeci a
f) = Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
n a
f

colorSpec :: a -> ColorSpec
colorSpec a
x = a -> ColorSpec
forall a. (Show a, ColorGen a) => a -> ColorSpec
ColorSpec a
x
fontSpec :: a -> FontSpec
fontSpec a
x = a -> FontSpec
forall a. (Show a, FontGen a) => a -> FontSpec
FontSpeci a
x
#else
data ColorSpec = StringCS ColorName | RGBCS RGB | PixelCS Pixel | ListCS [ColorSpec] deriving (Show)
data FontSpec = StringFS FontName | FontIdFS FontId | FontStructFS FontStruct | ListFS [FontSpec] deriving (Show)
#endif

--data ColorFallback = CF ColorName ColorName

--type GCAttrsSpec = GCAttributes ColorSpec FontSpec

class ColorGen a where
  IFNOEXIST(colorSpec :: a -> ColorSpec)
  tryConvColorK :: FudgetIO f => a -> Cont (f i o) (Maybe Pixel)

  -- Methods with defaults, to be overidden only in the Char instance:
  IFNOEXIST(colorSpecList :: [a] -> ColorSpec)
  convColorListK :: FudgetIO f => [a] -> Cont (f i o) (Maybe Pixel)

  convColorListK = (a -> Cont (f i o) (Maybe Pixel))
-> [a] -> Cont (f i o) (Maybe Pixel)
forall t a b.
(t -> (Maybe a -> b) -> b) -> [t] -> (Maybe a -> b) -> b
convList a -> Cont (f i o) (Maybe Pixel)
forall a (f :: * -> * -> *) i o.
(ColorGen a, FudgetIO f) =>
a -> Cont (f i o) (Maybe Pixel)
tryConvColorK
  IFNOEXIST(colorSpecList = ListCS . map colorSpec)

convColorK :: a -> (Pixel -> f i o) -> f i o
convColorK a
c = a -> Cont (f i o) (Maybe Pixel)
forall a (f :: * -> * -> *) i o.
(ColorGen a, FudgetIO f) =>
a -> Cont (f i o) (Maybe Pixel)
tryConvColorK a
c Cont (f i o) (Maybe Pixel)
-> ((Pixel -> f i o) -> Maybe Pixel -> f i o)
-> (Pixel -> f i o)
-> f i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f i o -> (Pixel -> f i o) -> Maybe Pixel -> f i o
forall b a. b -> (a -> b) -> Maybe a -> b
maybe f i o
forall a. a
err
  where err :: a
err = String -> a
forall a. HasCallStack => String -> a
error (String
"Can't allocate color: "String -> ShowS
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
c)

class FontGen a where
  IFNOEXIST(fontSpec :: a -> FontSpec)
  tryConvFontK :: FudgetIO f => a -> Cont (f i o) (Maybe FontData)

  -- Methods with defaults, to be overidden only in the Char instance:
  IFNOEXIST(fontSpecList :: [a] -> FontSpec)
  convFontListK :: FudgetIO f => [a] -> Cont (f i o) (Maybe FontData)

  IFNOEXIST(fontSpecList = ListFS . map fontSpec)
  convFontListK  = (a -> Cont (f i o) (Maybe FontData))
-> [a] -> Cont (f i o) (Maybe FontData)
forall t a b.
(t -> (Maybe a -> b) -> b) -> [t] -> (Maybe a -> b) -> b
convList a -> Cont (f i o) (Maybe FontData)
forall a (f :: * -> * -> *) i o.
(FontGen a, FudgetIO f) =>
a -> Cont (f i o) (Maybe FontData)
tryConvFontK

convFontK :: a -> (FontData -> f i o) -> f i o
convFontK a
f FontData -> f i o
k = a -> Cont (f i o) (Maybe FontData)
forall a (f :: * -> * -> *) i o.
(FontGen a, FudgetIO f) =>
a -> Cont (f i o) (Maybe FontData)
tryConvFontK a
f Cont (f i o) (Maybe FontData) -> Cont (f i o) (Maybe FontData)
forall a b. (a -> b) -> a -> b
$ f i o -> (FontData -> f i o) -> Maybe FontData -> f i o
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Cont (f i o) (Maybe FontData)
forall a (f :: * -> * -> *) i o.
(FontGen a, FudgetIO f) =>
a -> Cont (f i o) (Maybe FontData)
tryConvFontK String
"fixed" Cont (f i o) (Maybe FontData) -> Cont (f i o) (Maybe FontData)
forall a b. (a -> b) -> a -> b
$ f i o -> (FontData -> f i o) -> Maybe FontData -> f i o
forall b a. b -> (a -> b) -> Maybe a -> b
maybe f i o
forall a. a
err FontData -> f i o
k) FontData -> f i o
k
  where err :: a
err = String -> a
forall a. HasCallStack => String -> a
error (String
"Can't load font: "String -> ShowS
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
f)

convList :: (t -> (Maybe a -> b) -> b) -> [t] -> (Maybe a -> b) -> b
convList t -> (Maybe a -> b) -> b
try [t]
xs Maybe a -> b
cont = [t] -> b
conv [t]
xs
  where conv :: [t] -> b
conv [] = Maybe a -> b
cont Maybe a
forall a. Maybe a
Nothing
        conv (t
x:[t]
xs) = t -> (Maybe a -> b) -> b
try t
x ((Maybe a -> b) -> b) -> (Maybe a -> b) -> b
forall a b. (a -> b) -> a -> b
$ b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([t] -> b
conv [t]
xs) (Maybe a -> b
cont (Maybe a -> b) -> (a -> Maybe a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)


#ifdef USE_EXIST_Q
instance ColorGen ColorSpec where tryConvColorK :: ColorSpec -> Cont (f i o) (Maybe Pixel)
tryConvColorK (ColorSpec a
c) = a -> Cont (f i o) (Maybe Pixel)
forall a (f :: * -> * -> *) i o.
(ColorGen a, FudgetIO f) =>
a -> Cont (f i o) (Maybe Pixel)
tryConvColorK a
c
instance FontGen FontSpec where tryConvFontK :: FontSpec -> Cont (f i o) (Maybe FontData)
tryConvFontK (FontSpeci a
c) = a -> Cont (f i o) (Maybe FontData)
forall a (f :: * -> * -> *) i o.
(FontGen a, FudgetIO f) =>
a -> Cont (f i o) (Maybe FontData)
tryConvFontK a
c
#else
instance ColorGen ColorSpec where
  colorSpec = id
  tryConvColorK cs =
    case cs of
      StringCS s -> tryConvColorK s
--      NameCS name -> tryConvColorK name
      PixelCS pixel -> tryConvColorK pixel
      RGBCS rgb -> tryConvColorK rgb
--      FallbackCS fb -> tryColorColorK fb
      ListCS cs -> tryConvColorK cs

instance FontGen FontSpec where
  fontSpec = id
  tryConvFontK fs =
    case fs of
--      NameFS (Name name) -> tryConvFontK name k
      StringFS name -> tryConvFontK name
      FontStructFS fstr -> tryConvFontK fstr
      ListFS fs -> tryConvFontK fs
#endif

--instance ColorGen ColorFallback where
--  IFNOEXIST(colorSpec = FallbackCS)
--  convColorK = convColorFallbackK

--convColorFallbackK (CF c1 c2) = allocNamedColorDefPixel defaultColormap c1 c2

instance ColorGen c => ColorGen [c] where
  IFNOEXIST(colorSpec = colorSpecList)
  tryConvColorK :: [c] -> Cont (f i o) (Maybe Pixel)
tryConvColorK = [c] -> Cont (f i o) (Maybe Pixel)
forall c (f :: * -> * -> *) i o.
(ColorGen c, FudgetIO f) =>
[c] -> Cont (f i o) (Maybe Pixel)
convColorListK

instance FontGen a => FontGen [a] where
  IFNOEXIST(fontSpec = fontSpecList)
  tryConvFontK :: [a] -> Cont (f i o) (Maybe FontData)
tryConvFontK = [a] -> Cont (f i o) (Maybe FontData)
forall a (f :: * -> * -> *) i o.
(FontGen a, FudgetIO f) =>
[a] -> Cont (f i o) (Maybe FontData)
convFontListK

-- To be able to allow Strings as color names, we have to make an instance for
-- Char. We actually don't want single Chars to be allowed as color names, but
-- to avoid run-time errors they are allowed (and treated as one-char Strings).
instance ColorGen Char where
  IFNOEXIST(colorSpec c = StringCS [c])
  IFNOEXIST(colorSpecList s = StringCS s)
  tryConvColorK :: Char -> Cont (f i o) (Maybe Pixel)
tryConvColorK Char
c = String -> Cont (f i o) (Maybe Pixel)
forall c (f :: * -> * -> *) i o.
(ColorGen c, FudgetIO f) =>
[c] -> Cont (f i o) (Maybe Pixel)
convColorListK [Char
c]
  convColorListK :: String -> Cont (f i o) (Maybe Pixel)
convColorListK String
s Maybe Pixel -> f i o
k = ColormapId -> String -> (Maybe Color -> f i o) -> f i o
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> String -> (Maybe Color -> f b ho) -> f b ho
tryAllocNamedColor ColormapId
defaultColormap String
s (Maybe Pixel -> f i o
k (Maybe Pixel -> f i o)
-> (Maybe Color -> Maybe Pixel) -> Maybe Color -> f i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> Pixel) -> Maybe Color -> Maybe Pixel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Color -> Pixel
colorPixel)

-- In the "auto mode":

-- if a font is less than 256 chars, load it as is
-- if a font is monospaced, reuse the FontStruct, inserting
--   a font ID obtained for the font via loadFont (as the font name was returned
--   by listFontsWithInfo, we are safe assuming that it exists)
-- if a font is proportional and large then keep its FID in order
--   to query the server for characters metrics.

getFontData :: FudgetIO f => [Char] -> Cont (f i o) (Maybe FontData)
getFontData :: String -> Cont (f i o) (Maybe FontData)
getFontData =
    case String
usefontstructs of
      String
"yes" -> String -> Cont (f i o) (Maybe FontData)
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> (Maybe FontData -> f b ho) -> f b ho
qf
      String
"no" -> String -> Cont (f i o) (Maybe FontData)
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> (Maybe FontData -> f b ho) -> f b ho
lf
      String
_ -> String -> Cont (f i o) (Maybe FontData)
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> (Maybe FontData -> f b ho) -> f b ho
autof
  where
    qf :: String -> (Maybe FontData -> f b ho) -> f b ho
qf String
fname Maybe FontData -> f b ho
k = String -> (Maybe FontStruct -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> (Maybe FontStruct -> f b ho) -> f b ho
loadQueryFont String
fname (Maybe FontData -> f b ho
k (Maybe FontData -> f b ho)
-> (Maybe FontStruct -> Maybe FontData)
-> Maybe FontStruct
-> f b ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FontStruct -> FontData) -> Maybe FontStruct -> Maybe FontData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FontStruct -> FontData
FS)
    lf :: String -> (Maybe FontData -> f b ho) -> f b ho
lf String
fname Maybe FontData -> f b ho
k = 
      String -> Int -> ([(String, FontStruct)] -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> Int -> ([(String, FontStruct)] -> f b ho) -> f b ho
listFontsWithInfo String
fname Int
1 (([(String, FontStruct)] -> f b ho) -> f b ho)
-> ([(String, FontStruct)] -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \ [(String, FontStruct)]
fis ->
      case [(String, FontStruct)]
fis of
        [] -> Maybe FontData -> f b ho
k Maybe FontData
forall a. Maybe a
Nothing
        (String
fn,FontStruct
fs):[(String, FontStruct)]
_ -> String -> (FontId -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> (FontId -> f b ho) -> f b ho
loadFont String
fname ((FontId -> f b ho) -> f b ho) -> (FontId -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \FontId
fid -> Maybe FontData -> f b ho
k (Maybe FontData -> f b ho) -> Maybe FontData -> f b ho
forall a b. (a -> b) -> a -> b
$ FontData -> Maybe FontData
forall a. a -> Maybe a
Just (FontData -> Maybe FontData) -> FontData -> Maybe FontData
forall a b. (a -> b) -> a -> b
$ FontStruct -> FontData
FID (FontStruct -> FontData) -> FontStruct -> FontData
forall a b. (a -> b) -> a -> b
$ FontStruct -> FontId -> FontStruct
forall per_char.
FontStructF per_char -> FontId -> FontStructF per_char
update_font_id FontStruct
fs FontId
fid
    autof :: String -> (Maybe FontData -> f b ho) -> f b ho
autof String
fname Maybe FontData -> f b ho
k =
      String -> Int -> ([(String, FontStruct)] -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> Int -> ([(String, FontStruct)] -> f b ho) -> f b ho
listFontsWithInfo String
fname Int
1 (([(String, FontStruct)] -> f b ho) -> f b ho)
-> ([(String, FontStruct)] -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \ [(String, FontStruct)]
fis ->
      case [(String, FontStruct)]
fis of
        [] -> Maybe FontData -> f b ho
k Maybe FontData
forall a. Maybe a
Nothing
	(String
fn,FontStruct
fs):[(String, FontStruct)]
_ -> let fprops :: [FontProp]
fprops = FontStruct -> [FontProp]
forall per_char. FontStructF per_char -> [FontProp]
font_prop FontStruct
fs
                     in  [FontProp] -> String -> (Maybe String -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
[FontProp] -> String -> (Maybe String -> f b ho) -> f b ho
fontProperty [FontProp]
fprops String
"SPACING" ((Maybe String -> f b ho) -> f b ho)
-> (Maybe String -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \Maybe String
spacing ->
                         [FontProp] -> String -> (Maybe String -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
[FontProp] -> String -> (Maybe String -> f b ho) -> f b ho
fontProperty [FontProp]
fprops String
"FONT" ((Maybe String -> f b ho) -> f b ho)
-> (Maybe String -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \Maybe String
font ->
                         if Int
char_countInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
256
	                   then String -> (Maybe FontData -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> (Maybe FontData -> f b ho) -> f b ho
qf String
fn Maybe FontData -> f b ho
k
                           else let fscons :: FontStruct -> FontData
fscons = if (Maybe String -> Maybe String -> Bool
fixed_width Maybe String
font Maybe String
spacing)
                                               then FontStruct -> FontData
FS
                                               else FontStruct -> FontData
FID
                                in  String -> (FontId -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> (FontId -> f b ho) -> f b ho
loadFont String
fname ((FontId -> f b ho) -> f b ho) -> (FontId -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \FontId
fid ->
                                    Maybe FontData -> f b ho
k (Maybe FontData -> f b ho) -> Maybe FontData -> f b ho
forall a b. (a -> b) -> a -> b
$ FontData -> Maybe FontData
forall a. a -> Maybe a
Just (FontData -> Maybe FontData) -> FontData -> Maybe FontData
forall a b. (a -> b) -> a -> b
$ FontStruct -> FontData
fscons (FontStruct -> FontData) -> FontStruct -> FontData
forall a b. (a -> b) -> a -> b
$ FontStruct -> FontId -> FontStruct
forall per_char.
FontStructF per_char -> FontId -> FontStructF per_char
update_font_id FontStruct
fs FontId
fid
	   where
	     char_count :: Int
char_count = Int
hiInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
lo
	     (Int
lo,Int
hi) = (Char -> Int) -> (Char, Char) -> (Int, Int)
forall t b. (t -> b) -> (t, t) -> (b, b)
aboth Char -> Int
forall a. Enum a => a -> Int
fromEnum (FontStruct -> (Char, Char)
forall per_char. FontStructF per_char -> (Char, Char)
font_range FontStruct
fs)

             fixed_width :: Maybe String -> Maybe String -> Bool
fixed_width Maybe String
fnt Maybe String
spcng = 
               let spc :: [String]
spc = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
segments (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'-') String
fn
                   spct :: [String]
spct = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
segments (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') String
fnt'
                   monosp :: [String]
monosp = [String
"m", String
"c", String
"M", String
"C"]
                   [String
fnt', String
spcng'] = (Maybe String -> String) -> [Maybe String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Maybe String
s -> case Maybe String
s of
                                                 Just String
c -> String
c
                                                 Maybe String
_      -> String
"\xFF") [Maybe String
fnt, Maybe String
spcng]
                   lspc :: Int
lspc = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
spc
                   lspct :: Int
lspct = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
spct
               in  String
spcng' String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
monosp Bool -> Bool -> Bool
||                     -- font property tells "monospaced"
                   Int
lspct Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
11 Bool -> Bool -> Bool
&& ([String]
spct [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
11) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
monosp Bool -> Bool -> Bool
|| -- from font property if XLFD
                   Int
lspc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
11 Bool -> Bool -> Bool
&& ([String]
spc [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
11) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
monosp Bool -> Bool -> Bool
||   -- from font name if XLFD
                   Int
lspc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& ([String] -> String
forall a. [a] -> a
head [String]
spc) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"fixed"          -- no XLFD, guess by font alias

{--
	     fixed_width = spc !! 11 `elem` ["m","c"]
--}
{--
	     fixed_width
               | (spacing == (Just c)) = c `elem` monosp
               | ((length spct) > 11) = (spct !! 11) `elem` monosp
               | ((length spc) > 11) = (spc !! 11) `elem` monosp
               | ((length spc) == 1) && ((head spc) == "fixed") = True
               | otherwise = False

	     fixed_width = if length spc>11
			   then spc !! 11 `elem` ["m","c"]
			   else --XFLD is missing, assume proportional, unless
			        --the name of the font is "fixed"
                                fn=="fixed"

	     spc = chopList (breakAt '-') fn
             spct = chopList (breakAt '-') font
             monosp = ["m", "c", "M", "C"]
--}

instance FontGen Char where
  IFNOEXIST(fontSpec c = StringFS [c])
  IFNOEXIST(fontSpecList s = StringFS s)
  tryConvFontK :: Char -> Cont (f i o) (Maybe FontData)
tryConvFontK Char
f = String -> Cont (f i o) (Maybe FontData)
forall a (f :: * -> * -> *) i o.
(FontGen a, FudgetIO f) =>
[a] -> Cont (f i o) (Maybe FontData)
convFontListK [Char
f]
  convFontListK :: String -> Cont (f i o) (Maybe FontData)
convFontListK = String -> Cont (f i o) (Maybe FontData)
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
String -> (Maybe FontData -> f b ho) -> f b ho
getFontData

--instance ColorGen Name where
--  IFNOEXIST(colorSpec = NameCS)
--  tryConvColorK (Name s) = tryConvColorK s

tryConvColorRGBK :: RGB -> (Maybe Pixel -> f b ho) -> f b ho
tryConvColorRGBK RGB
rgb Maybe Pixel -> f b ho
k = ColormapId -> RGB -> (Maybe Color -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> RGB -> (Maybe Color -> f b ho) -> f b ho
tryAllocColor ColormapId
defaultColormap RGB
rgb (Maybe Pixel -> f b ho
k (Maybe Pixel -> f b ho)
-> (Maybe Color -> Maybe Pixel) -> Maybe Color -> f b ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> Pixel) -> Maybe Color -> Maybe Pixel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Color -> Pixel
colorPixel)

instance ColorGen RGB where
  IFNOEXIST(colorSpec = RGBCS)
  tryConvColorK :: RGB -> Cont (f i o) (Maybe Pixel)
tryConvColorK = RGB -> Cont (f i o) (Maybe Pixel)
forall (f :: * -> * -> *) i o.
FudgetIO f =>
RGB -> Cont (f i o) (Maybe Pixel)
tryConvColorRGBK

--instance FontGen Name where
--  IFNOEXIST(fontSpec = NameFS)
--  convFontK (Name s) = safeLoadQueryFont s
  
instance ColorGen Pixel where
  IFNOEXIST(colorSpec = PixelCS)
  tryConvColorK :: Pixel -> Cont (f i o) (Maybe Pixel)
tryConvColorK Pixel
p Maybe Pixel -> f i o
k = Maybe Pixel -> f i o
k (Pixel -> Maybe Pixel
forall a. a -> Maybe a
Just Pixel
p)

instance FontGen FontStruct where
  IFNOEXIST(fontSpec = FontStructFS)
  tryConvFontK :: FontStruct -> Cont (f i o) (Maybe FontData)
tryConvFontK FontStruct
fs Maybe FontData -> f i o
k = Maybe FontData -> f i o
k (FontData -> Maybe FontData
forall a. a -> Maybe a
Just (FontStruct -> FontData
FS FontStruct
fs))

{--

instance FontGen FontId where
  IFNOEXIST(fontSpec = FontIdFS)
  tryConvFontK fs k = k (Just (FID fs))

--}

--convGCSpecK :: GCSpec -> (GCAttributeList->FontStruct->K i o) -> K i o
convGCSpecK :: FontData
-> [GCAttributes a a]
-> ([GCAttributes Pixel FontId] -> FontData -> f i o)
-> f i o
convGCSpecK FontData
fs [GCAttributes a a]
attrs = FontData
-> [GCAttributes a a]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> FontData -> f i o)
-> f i o
forall a (f :: * -> * -> *) a i o.
(ColorGen a, FudgetIO f, FontGen a, Show a, Show a) =>
FontData
-> [GCAttributes a a]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> FontData -> f i o)
-> f i o
gcattrsK FontData
fs [GCAttributes a a]
attrs []
  where
    gcattrsK :: FontData
-> [GCAttributes a a]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> FontData -> f i o)
-> f i o
gcattrsK FontData
fs [] [GCAttributes Pixel FontId]
outattrs [GCAttributes Pixel FontId] -> FontData -> f i o
dr = [GCAttributes Pixel FontId] -> FontData -> f i o
dr ([GCAttributes Pixel FontId] -> [GCAttributes Pixel FontId]
forall a. [a] -> [a]
reverse [GCAttributes Pixel FontId]
outattrs) FontData
fs
    gcattrsK FontData
fs (GCAttributes a a
attr : [GCAttributes a a]
attrs) [GCAttributes Pixel FontId]
outattrs [GCAttributes Pixel FontId] -> FontData -> f i o
dr =
      let cp :: GCAttributes Pixel FontId -> f i o
cp GCAttributes Pixel FontId
attr' = FontData
-> [GCAttributes a a]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> FontData -> f i o)
-> f i o
gcattrsK FontData
fs [GCAttributes a a]
attrs (GCAttributes Pixel FontId
attr' GCAttributes Pixel FontId
-> [GCAttributes Pixel FontId] -> [GCAttributes Pixel FontId]
forall a. a -> [a] -> [a]
: [GCAttributes Pixel FontId]
outattrs) [GCAttributes Pixel FontId] -> FontData -> f i o
dr
      in case GCAttributes a a
attr of
	   GCForeground a
colspec ->
	     a -> (Pixel -> f i o) -> f i o
forall a (f :: * -> * -> *) i o.
(ColorGen a, FudgetIO f, Show a) =>
a -> (Pixel -> f i o) -> f i o
convColorK a
colspec ((Pixel -> f i o) -> f i o) -> (Pixel -> f i o) -> f i o
forall a b. (a -> b) -> a -> b
$ \Pixel
fg ->
	     FontData
-> [GCAttributes a a]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> FontData -> f i o)
-> f i o
gcattrsK FontData
fs [GCAttributes a a]
attrs (Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCForeground Pixel
fg GCAttributes Pixel FontId
-> [GCAttributes Pixel FontId] -> [GCAttributes Pixel FontId]
forall a. a -> [a] -> [a]
: [GCAttributes Pixel FontId]
outattrs) [GCAttributes Pixel FontId] -> FontData -> f i o
dr
	   GCBackground a
colspec ->
	     a -> (Pixel -> f i o) -> f i o
forall a (f :: * -> * -> *) i o.
(ColorGen a, FudgetIO f, Show a) =>
a -> (Pixel -> f i o) -> f i o
convColorK a
colspec ((Pixel -> f i o) -> f i o) -> (Pixel -> f i o) -> f i o
forall a b. (a -> b) -> a -> b
$ \Pixel
fg ->
	     FontData
-> [GCAttributes a a]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> FontData -> f i o)
-> f i o
gcattrsK FontData
fs [GCAttributes a a]
attrs (Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCBackground Pixel
fg GCAttributes Pixel FontId
-> [GCAttributes Pixel FontId] -> [GCAttributes Pixel FontId]
forall a. a -> [a] -> [a]
: [GCAttributes Pixel FontId]
outattrs) [GCAttributes Pixel FontId] -> FontData -> f i o
dr
	   GCFont a
fspec ->
	     a -> (FontData -> f i o) -> f i o
forall a (f :: * -> * -> *) i o.
(FontGen a, FudgetIO f, Show a) =>
a -> (FontData -> f i o) -> f i o
convFontK a
fspec ((FontData -> f i o) -> f i o) -> (FontData -> f i o) -> f i o
forall a b. (a -> b) -> a -> b
$ \FontData
fs' ->
	     FontData
-> [GCAttributes a a]
-> [GCAttributes Pixel FontId]
-> ([GCAttributes Pixel FontId] -> FontData -> f i o)
-> f i o
gcattrsK FontData
fs' [GCAttributes a a]
attrs (FontId -> GCAttributes Pixel FontId
forall a b. b -> GCAttributes a b
GCFont (FontData -> FontId
fdFontId FontData
fs') GCAttributes Pixel FontId
-> [GCAttributes Pixel FontId] -> [GCAttributes Pixel FontId]
forall a. a -> [a] -> [a]
: [GCAttributes Pixel FontId]
outattrs) [GCAttributes Pixel FontId] -> FontData -> f i o
dr
	   GCFunction GCFunction
f -> GCAttributes Pixel FontId -> f i o
cp (GCFunction -> GCAttributes Pixel FontId
forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
f)
	   GCLineWidth Int
w -> GCAttributes Pixel FontId -> f i o
cp (Int -> GCAttributes Pixel FontId
forall a b. Int -> GCAttributes a b
GCLineWidth Int
w)
	   GCLineStyle GCLineStyle
s -> GCAttributes Pixel FontId -> f i o
cp (GCLineStyle -> GCAttributes Pixel FontId
forall a b. GCLineStyle -> GCAttributes a b
GCLineStyle GCLineStyle
s)
	   GCCapStyle GCCapStyle
s -> GCAttributes Pixel FontId -> f i o
cp (GCCapStyle -> GCAttributes Pixel FontId
forall a b. GCCapStyle -> GCAttributes a b
GCCapStyle GCCapStyle
s)
	   GCJoinStyle GCJoinStyle
s -> GCAttributes Pixel FontId -> f i o
cp (GCJoinStyle -> GCAttributes Pixel FontId
forall a b. GCJoinStyle -> GCAttributes a b
GCJoinStyle GCJoinStyle
s)
	   GCSubwindowMode GCSubwindowMode
m -> GCAttributes Pixel FontId -> f i o
cp (GCSubwindowMode -> GCAttributes Pixel FontId
forall a b. GCSubwindowMode -> GCAttributes a b
GCSubwindowMode GCSubwindowMode
m)
	   GCGraphicsExposures Bool
b -> GCAttributes Pixel FontId -> f i o
cp (Bool -> GCAttributes Pixel FontId
forall a b. Bool -> GCAttributes a b
GCGraphicsExposures Bool
b)

gcFgA,gcBgA :: c -> [GCAttributes c FontSpec]
gcBgA :: c -> [GCAttributes c FontSpec]
gcBgA c
c = [c -> GCAttributes c FontSpec
forall a b. a -> GCAttributes a b
GCBackground c
c]
gcFgA :: c -> [GCAttributes c FontSpec]
gcFgA c
c = [c -> GCAttributes c FontSpec
forall a b. a -> GCAttributes a b
GCForeground c
c]

gcFontA :: f -> [GCAttributes ColorSpec f]
gcFontA :: f -> [GCAttributes ColorSpec f]
gcFontA f
f = [f -> GCAttributes ColorSpec f
forall a b. b -> GCAttributes a b
GCFont f
f]


usefontstructs :: String
usefontstructs = String -> ShowS
argKey String
"fontstructs" String
"auto"