Menu
▾
▴
[htoolkit-cvs] port/src/Port Canvas.hs,1.16,1.17 Colors.hs,1.3,1.4 Font.hs,1.6,1.7 Types.hs,1.31,1.32 Window.hs,1.14,1.15
|
From: <kr_...@us...> - 2003-08-24 19:02:47
|
Update of /cvsroot/htoolkit/port/src/Port
In directory sc8-pr-cvs1:/tmp/cvs-serv18393/port/src/Port
Modified Files:
Canvas.hs Colors.hs Font.hs Types.hs Window.hs
Log Message:
The new defaultFontDef function now returns the default font which is specified
in Windows. The defaultPen function is renamed to windowPen and now the window
and dialog pens have colors whichs are given from Windows settings.
Index: Canvas.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Canvas.hs,v
retrieving revision 1.16
retrieving revision 1.17
diff -C2 -d -r1.16 -r1.17
*** Canvas.hs 17 Jul 2003 19:30:03 -0000 1.16
--- Canvas.hs 24 Aug 2003 19:02:45 -0000 1.17
***************
*** 42,46 ****
-- * Pen
! , Pen(..), defaultPen, dialogPen
-- ** Font
--- 42,46 ----
-- * Pen
! , Pen(..), windowPen, dialogPen
-- ** Font
***************
*** 81,97 ****
deriving Eq
! -- | Create a pen with default drawing values. That is:
--
! -- @'Pen'@ 1 @'DrawCopy'@ @'black'@ @'white'@ @'False'@ @'defaultFont'@ @'JoinMiter'@ @'CapFlat'@ @'LineSolid'@ @'HatchSolid'@
! defaultPen :: Pen
! defaultPen
! = Pen 1 DrawCopy black white False defaultFont JoinMiter CapFlat LineSolid HatchSolid
-- | Create a pen with default drawing values for dialogs. That is:
--
! -- @'Pen'@ 1 @'DrawCopy'@ @'black'@ @'dialoggrey'@ @'False'@ @'dialogFont'@ @'JoinMiter'@ @'CapFlat'@ @'LineSolid'@ @'HatchSolid'@
dialogPen :: Pen
dialogPen
! = Pen 1 DrawCopy black dialoggray False dialogFont JoinMiter CapFlat LineSolid HatchSolid
--- 81,97 ----
deriving Eq
! -- | Create a pen with default drawing values for windows. That is:
--
! -- @'Pen'@ 1 @'DrawCopy'@ @'textColor'@ @'windowColor'@ @'False'@ @'windowColor'@ @'JoinMiter'@ @'CapFlat'@ @'LineSolid'@ @'HatchSolid'@
! windowPen :: Pen
! windowPen
! = Pen 1 DrawCopy textColor windowColor False defaultFont JoinMiter CapFlat LineSolid HatchSolid
-- | Create a pen with default drawing values for dialogs. That is:
--
! -- @'Pen'@ 1 @'DrawCopy'@ @'textColor'@ @'dialogColor'@ @'False'@ @'dialogFont'@ @'JoinMiter'@ @'CapFlat'@ @'LineSolid'@ @'HatchSolid'@
dialogPen :: Pen
dialogPen
! = Pen 1 DrawCopy textColor dialogColor False defaultFont JoinMiter CapFlat LineSolid HatchSolid
Index: Colors.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Colors.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** Colors.hs 1 Jun 2003 13:00:09 -0000 1.3
--- Colors.hs 24 Aug 2003 19:02:45 -0000 1.4
***************
*** 1,3 ****
! {-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------------------
{-| Module : Colors
--- 1,3 ----
! {-# OPTIONS -fglasgow-exts -#include Canvas.h #-}
-----------------------------------------------------------------------------------------
{-| Module : Colors
***************
*** 49,53 ****
, snow, springgreen, steelblue, teal, thistle, tomato
, turquoise, violet, wheat, white, whitesmoke, yellow
! , yellowgreen, dialoggray
-- * Marshalling
, CColor, fromCColor, toCColor
--- 49,55 ----
, snow, springgreen, steelblue, teal, thistle, tomato
, turquoise, violet, wheat, white, whitesmoke, yellow
! , yellowgreen
! -- * GUI specific colors
! , dialogColor, windowColor, textColor
-- * Marshalling
, CColor, fromCColor, toCColor
***************
*** 60,63 ****
--- 62,66 ----
import Text.Read
import Text.ParserCombinators.ReadPrec
+ import System.IO.Unsafe(unsafePerformIO)
newtype Color = Color Word deriving Eq
***************
*** 204,208 ****
| c == yellow = showString "yellow"
| c == yellowgreen = showString "yellowgreen"
- | c == dialoggray = showString "dialoggray"
| otherwise = showParen (d > 0)
(showString "rgbColor " . shows (colorRed c) .
--- 207,210 ----
***************
*** 351,355 ****
do { Ident "yellow" <- lexP; return yellow } +++
do { Ident "yellowgreen" <- lexP; return yellowgreen } +++
- do { Ident "dialoggray" <- lexP; return dialoggray } +++
parens
( prec 10
--- 353,356 ----
***************
*** 434,438 ****
snow, springgreen, steelblue, teal, thistle, tomato,
turquoise, violet, wheat, white, whitesmoke, yellow,
! yellowgreen, dialoggray :: Color
aliceblue = Color 0xFFF8F0
--- 435,439 ----
snow, springgreen, steelblue, teal, thistle, tomato,
turquoise, violet, wheat, white, whitesmoke, yellow,
! yellowgreen :: Color
aliceblue = Color 0xFFF8F0
***************
*** 575,580 ****
yellow = Color 0x00FFFF
yellowgreen = Color 0x32CD9A
- dialoggray = Color 0xC8D0D4
-- marshalling
--- 576,598 ----
yellow = Color 0x00FFFF
yellowgreen = Color 0x32CD9A
+ {-# NOINLINE dialogColor #-}
+ -- | the default color for dialogs
+ dialogColor :: Color
+ dialogColor = fromCColor (unsafePerformIO osGetDialogColor)
+ foreign import ccall osGetDialogColor :: IO CColor
+
+ {-# NOINLINE windowColor #-}
+ -- | the default color for dialogs
+ windowColor :: Color
+ windowColor = fromCColor (unsafePerformIO osGetWindowColor)
+ foreign import ccall osGetWindowColor :: IO CColor
+
+ {-# NOINLINE textColor #-}
+ -- | the default text color
+ textColor :: Color
+ textColor = fromCColor (unsafePerformIO osGetTextColor)
+ foreign import ccall osGetTextColor :: IO CColor
+
-- marshalling
Index: Font.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Font.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** Font.hs 17 Jul 2003 19:30:03 -0000 1.6
--- Font.hs 24 Aug 2003 19:02:45 -0000 1.7
***************
*** 17,21 ****
createFont
, defaultFont
- , dialogFont
-- * Metrics (on a certain canvas).
--- 17,20 ----
***************
*** 29,33 ****
-- * Standard font definitions.
, defaultFontDef
- , dialogFontDef
, serifFontDef
, sansSerifFontDef
--- 28,31 ----
***************
*** 59,67 ****
createFont :: FontDef -> IO Font
createFont fontDef
! = withCFontDef fontDef $ \cname csize cweight cstyle cunderline cstrikeout ->
! do handle <- osCreateFont cname csize cweight cstyle cunderline cstrikeout
when (nullPtr == handle) (ioError (mkIOError doesNotExistErrorType "createFont" Nothing (Just (show fontDef))))
fromCFont fontDef handle
! foreign import ccall osCreateFont :: CString -> CInt -> CInt -> CInt -> CBool -> CBool -> IO FontHandle
--- 57,65 ----
createFont :: FontDef -> IO Font
createFont fontDef
! = withCFontDef fontDef $ \cname csize cweight cstyle ->
! do handle <- osCreateFont cname csize cweight cstyle
when (nullPtr == handle) (ioError (mkIOError doesNotExistErrorType "createFont" Nothing (Just (show fontDef))))
fromCFont fontDef handle
! foreign import ccall osCreateFont :: CString -> CInt -> CInt -> CInt -> IO FontHandle
***************
*** 103,106 ****
--- 101,106 ----
allFontSizes = [low'..high']
+ fst3 (x,y,z) = x
+
decodeVariants :: Ptr CInt -> IO (FiniteMap (FontWeight, FontStyle) [FontSize])
decodeVariants pints
***************
*** 115,119 ****
variants <- decodeVariants (pints `plusPtr` (sizeOf cweight * 3))
let sizes = if csize == 0 then allFontSizes else [fromCInt csize]
! return (addToFM_C (foldr insertUniq) variants (fromCWeight cweight,fromCStyle cstyle) sizes)
foreign import ccall osGetAvailableFontVariants :: CString -> CInt -> CInt -> IO (Ptr CInt);
--- 115,119 ----
variants <- decodeVariants (pints `plusPtr` (sizeOf cweight * 3))
let sizes = if csize == 0 then allFontSizes else [fromCInt csize]
! return (addToFM_C (foldr insertUniq) variants (fromCWeight cweight,fst3 (fromCStyle cstyle)) sizes)
foreign import ccall osGetAvailableFontVariants :: CString -> CInt -> CInt -> IO (Ptr CInt);
***************
*** 157,167 ****
createFont defaultFontDef
- {-# NOINLINE dialogFont #-}
- -- | The default dialog font.
- dialogFont :: Font
- dialogFont
- = unsafePerformIO $
- createFont dialogFontDef
-
{-# NOINLINE defaultFontDef #-}
defaultFontDef :: FontDef
--- 157,160 ----
***************
*** 171,182 ****
osDefaultFontDef pname psize pweight pstyle
foreign import ccall osDefaultFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()
-
- {-# NOINLINE dialogFontDef #-}
- dialogFontDef :: FontDef
- dialogFontDef
- = unsafePerformIO $
- withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout ->
- osDialogFontDef pname psize pweight pstyle
- foreign import ccall osDialogFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()
{-# NOINLINE serifFontDef #-}
--- 164,167 ----
Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Types.hs,v
retrieving revision 1.31
retrieving revision 1.32
diff -C2 -d -r1.31 -r1.32
*** Types.hs 23 Aug 2003 18:03:57 -0000 1.31
--- Types.hs 24 Aug 2003 19:02:45 -0000 1.32
***************
*** 939,955 ****
foreign import ccall "&osDeleteFont" osDeleteFont :: FinalizerPtr FH
! toCStyle :: FontStyle -> CInt
! toCStyle style
! = case style of
! Oblique -> toCInt 2
! Italic -> toCInt 1
! other -> toCInt 0
! fromCStyle :: CInt -> FontStyle
fromCStyle ci
! = case ci of
! 2 -> Oblique
! 1 -> Italic
! _ -> Roman
toCWeight :: Int -> CInt
--- 939,960 ----
foreign import ccall "&osDeleteFont" osDeleteFont :: FinalizerPtr FH
! toCStyle :: FontStyle -> Bool -> Bool -> CInt
! toCStyle style underline strikeout
! = (case style of
! Oblique -> toCInt 2
! Italic -> toCInt 1
! other -> toCInt 0)
! .|. (if underline then 4 else 0)
! .|. (if strikeout then 8 else 0)
! fromCStyle :: CInt -> (FontStyle,Bool,Bool)
fromCStyle ci
! = (case ci of
! 2 -> Oblique
! 1 -> Italic
! _ -> Roman
! , ci .&. 4 /= 0
! , ci .&. 8 /= 0
! )
toCWeight :: Int -> CInt
***************
*** 961,972 ****
= min fontMaxWeight (max fontMinWeight (fromCInt w))
! withCFontDef :: FontDef -> (CString -> CInt -> CInt -> CInt -> CBool -> CBool -> IO a) -> IO a
withCFontDef (FontDef name size weight style underline strikeout) f
= withCString name $ \cname ->
f cname (toCInt size)
(toCInt (min fontMaxWeight (max fontMinWeight weight)))
! (toCStyle style)
! (toCBool underline)
! (toCBool strikeout)
withCFontDefResult :: (Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CBool -> Ptr CBool -> IO ()) -> IO FontDef
--- 966,975 ----
= min fontMaxWeight (max fontMinWeight (fromCInt w))
! withCFontDef :: FontDef -> (CString -> CInt -> CInt -> CInt -> IO a) -> IO a
withCFontDef (FontDef name size weight style underline strikeout) f
= withCString name $ \cname ->
f cname (toCInt size)
(toCInt (min fontMaxWeight (max fontMinWeight weight)))
! (toCStyle style underline strikeout)
withCFontDefResult :: (Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CBool -> Ptr CBool -> IO ()) -> IO FontDef
***************
*** 992,997 ****
fromCFontDef cname csize cweight cstyle cunderline cstrikeout
= do name <- peekCString cname
! return (FontDef name (fromCInt csize) (fromCWeight cweight) (fromCStyle cstyle)
! (fromCBool cunderline) (fromCBool cstrikeout))
withCFontMetricsResult :: (Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()) -> IO FontMetrics
--- 995,1000 ----
fromCFontDef cname csize cweight cstyle cunderline cstrikeout
= do name <- peekCString cname
! let (style,underlined,striked) = fromCStyle cstyle
! return (FontDef name (fromCInt csize) (fromCWeight cweight) style underlined striked)
withCFontMetricsResult :: (Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()) -> IO FontMetrics
Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Window.hs,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** Window.hs 23 Aug 2003 20:05:00 -0000 1.14
--- Window.hs 24 Aug 2003 19:02:45 -0000 1.15
***************
*** 46,50 ****
import Graphics.UI.Port.PtrMap
import Graphics.UI.Port.Types
! import Graphics.UI.Port.Canvas(withCanvas, defaultPen, dialogPen)
import Graphics.UI.Port.Handlers( getAllWindowHandles, registerWindow, setWindowDismissHandler, setWindowPaintHandler )
--- 46,50 ----
import Graphics.UI.Port.PtrMap
import Graphics.UI.Port.Types
! import Graphics.UI.Port.Canvas(withCanvas, windowPen, dialogPen)
import Graphics.UI.Port.Handlers( getAllWindowHandles, registerWindow, setWindowDismissHandler, setWindowPaintHandler )
***************
*** 87,91 ****
return hwnd
where
! onpaint canvas rect = withCanvas defaultPen UnBuffered canvas (return ())
foreign import ccall osCreateWindow :: IO WindowHandle
--- 87,91 ----
return hwnd
where
! onpaint canvas rect = withCanvas windowPen UnBuffered canvas (return ())
foreign import ccall osCreateWindow :: IO WindowHandle
|
