module HTk.Devices.Screen (
Screen(..),
getScreenHeight,
getScreenWidth,
getScreenManager,
VisualClass(..),
getScreenVisual
) where
import HTk.Kernel.Core
import HTk.Kernel.Geometry(Distance)
import Data.Char(isSpace)
import HTk.Containers.Window
newtype Screen w = Screen w
getScreenHeight :: Window a => Screen a
-> IO Distance
getScreenHeight scr@(Screen win) =
evalMethod win (\nm -> ["winfo screenheight " ++ show nm])
getScreenWidth :: Window a => Screen a
-> IO Distance
getScreenWidth scr@(Screen win)=
evalMethod win (\nm -> ["winfo screenwidth " ++ show nm])
getScreenVisual :: Window a => Screen a
-> IO VisualClass
getScreenVisual scr@(Screen win) =
evalMethod win (\nm -> ["winfo screenvisual " ++ show nm])
getScreenManager :: Window a => Screen a
-> IO String
getScreenManager (Screen win) =
evalMethod win (\nm -> ["winfo manager " ++ show nm])
data VisualClass =
DirectColour
| GrayScale
| PseudoColour
| StaticColour
| StaticGray
| TrueColour
deriving (Eq,Ord,Enum)
instance GUIValue VisualClass where
cdefault = DirectColour
instance Read VisualClass where
readsPrec p b =
case dropWhile (isSpace) b of
'd':'i':'r':'e':'c':'t':'c':'o':'l':'o':'r':xs -> [(DirectColour,xs)]
'g':'r':'a':'y':'s':'c':'a':'l':'e':xs -> [(GrayScale,xs)]
'p':'s':'e':'u':'d':'o':'c':'o':'l':'o':'r':xs -> [(PseudoColour,xs)]
's':'t':'a':'t':'i':'c':'c':'o':'l':'o':'r':xs -> [(StaticColour,xs)]
's':'t':'a':'t':'i':'c':'g':'r':'a':'y':xs -> [(StaticGray,xs)]
't':'r':'u':'e':'c':'o':'l':'o':'r':xs -> [(TrueColour,xs)]
_ -> []
instance Show VisualClass where
showsPrec d p r =
(case p of
DirectColour -> "directcolor"
GrayScale -> "grayscale"
PseudoColour -> "pseudocolor"
StaticColour -> "staticcolor"
StaticGray -> "staticgray"
TrueColour -> "truecolor"
) ++ r