-- -----------------------------------------------------------------------
--
-- $Source: /repository/uni/htk/kernel/Configuration.hs,v $
--
-- HTk - a GUI toolkit for Haskell  -  (c) Universitaet Bremen
--
-- $Revision: 1.7 $ from $Date: 2002/01/07 21:14:16 $
-- Last modification by $Author: ludi $
--
-- -----------------------------------------------------------------------

---
-- Basic types and classes concerning widget configuration.
module Configuration (

  HasColour(..),

  background,
  getBackground,

  foreground,
  getForeground,

  activeBackground,
  getActiveBackground,

  activeForeground,
  getActiveForeground,

  disabledForeground,
  getDisabledForeground,

  fg,
  bg,

  hasBackGroundColour,
  hasForeGroundColour,

  HasSize(..),
  HasPosition(..),
  HasGeometry(..),
  HasCanvAnchor(..),
  HasBorder(..),
  HasValue(..),
  HasText(..),
  HasFont(..),
  HasUnderline(..),
  HasJustify(..),
  HasGrid(..),
  HasOrientation(..),
  HasFile(..),
  HasAlign(..),
  HasIncrement(..),
  HasEnable(..),
  HasAnchor(..),
  HasBBox(..)

) where

import GUIObject
import Computation
import Geometry
import GUIValue
import Colour
import Font
import Resources


-- -----------------------------------------------------------------------
-- BBox
-- -----------------------------------------------------------------------

---
-- Objects or sets of objects with a bounding box (e.g. canvas tags)
-- instantiate the <code>class HasBBox</code>.
class GUIObject w => HasBBox w i where
---
-- Returns the bounding box of the given object.
  bbox :: w -> i -> IO (Maybe (Distance,Distance,Distance,Distance))


-- -----------------------------------------------------------------------
-- has anchor
-- -----------------------------------------------------------------------

---
-- Objects that have an anchor position instantiate the
-- <code>class HasAnchor</code>.
class GUIObject w => HasAnchor w where
---
-- Sets the anchor position.
  anchor :: Anchor -> Config w
---
-- Gets the anchor position.
  getAnchor :: w -> IO Anchor
  anchor a w = cset w "anchor" a
  getAnchor w = cget w "anchor"


-- -----------------------------------------------------------------------
-- coloured
-- -----------------------------------------------------------------------

---
-- Coloured objects instantiate the <code>class HasColour</code>.
class GUIObject w => HasColour w where
---
-- Internal.
  legalColourID :: w -> ConfigID -> Bool
---
-- Internal.
  setColour :: w -> ConfigID -> Colour -> IO w
---
-- Internal.
  getColour :: w -> ConfigID -> IO Colour
  legalColourID _ "background" = True
  legalColourID _ _ = False
  setColour w cid col =
    if legalColourID w cid then cset w cid col else return w
  getColour w cid =
    if legalColourID w cid then cget w cid else return cdefault

---
-- Sets the background colour.
background :: (ColourDesignator c, HasColour w) => c -> Config w
background c w = setColour w "background" (toColour c)

---
-- Gets the background colour.
getBackground :: HasColour w => w -> IO Colour
getBackground w = getColour w "background" 

---
-- Sets the foreground colour.
foreground :: (ColourDesignator c, HasColour w) => c -> Config w
foreground c w = setColour w "foreground" (toColour c)

---
-- Gets the foreground colour.
getForeground :: HasColour w => w -> IO Colour
getForeground w = getColour w "foreground"

---
-- Sets the active background colour.
activeBackground :: (ColourDesignator c, HasColour w) => c -> Config w
activeBackground c w = setColour w "activebackground" (toColour c)

---
-- Gets the active background colour.
getActiveBackground :: HasColour w => w -> IO Colour    
getActiveBackground w = getColour w "activebackground"  
 
---
-- Sets the active foreground colour.
activeForeground :: (ColourDesignator c, HasColour w) => c -> Config w
activeForeground c w = setColour w "activeforeground" (toColour c)

---
-- Gets the active foreground colour.
getActiveForeground :: HasColour w => w -> IO Colour    
getActiveForeground w = getColour w "activeforeground"    

---
-- Sets the disabled foreground colour.
disabledForeground :: (ColourDesignator c, HasColour w) => c -> Config w
disabledForeground c w = setColour w "disabledforeground" (toColour c)

---
-- Gets the disabled foreground colour.
getDisabledForeground :: HasColour w => w -> IO Colour
getDisabledForeground w = getColour w "disabledforeground"

---
-- Sets the foreground colour.
fg :: (ColourDesignator c, HasColour w) => c -> Config w
fg = foreground

---
-- Sets the background colour.
bg :: (ColourDesignator c, HasColour w) => c -> Config w
bg = background

---
-- Internal.
hasBackGroundColour :: HasColour w => w -> ConfigID -> Bool
hasBackGroundColour w "background" = True
hasBackGroundColour w _ = False

---
-- Internal.
hasForeGroundColour :: HasColour w => w -> ConfigID -> Bool
hasForeGroundColour w "background" = True
hasForeGroundColour w "foreground" = True
hasForeGroundColour w _ = False


-- -----------------------------------------------------------------------
-- geometry
-- -----------------------------------------------------------------------

---
-- Objects with a configureable size instantiate the
-- <code>class HasSize</code>.
class GUIObject w => HasSize w where
---
-- Sets the object's width.
  width       :: Distance -> Config w
---
-- Gets the object's width.
  getWidth    :: w -> IO Distance
---
-- Sets the object's height.
  height      :: Distance -> Config w
---
-- Gets the object's height.
  getHeight   :: w -> IO Distance
---
-- Sets the object's width and height.
  size        :: Size -> Config w
---
-- Gets the object's width and height.
  getSize     :: w -> IO Size
  width s w    = cset w "width" s
  getWidth w   = cget w "width"
  height s w   = cset w "height" s
  getHeight w  = cget w "height"
  size (x,y) w = width x w >> height y w
  getSize w    =
    getWidth w >>= \ x -> getHeight w >>= \ y -> return (x,y)

---
-- Objects with a configureable positon (e.g. canvas items) instantiate
-- the <code>class HasPosition</code>.
class GUIObject w => HasPosition w where
---
-- Gets the object's position.
  position    :: Position -> Config w
---
-- Sets the object's position.
  getPosition :: w -> IO Position

---
-- Objects with a configureable size and position instantiate the
-- <code>class HasGeometry</code>.
class (HasSize w, HasPosition w) => HasGeometry w where
---
-- Sets the object's geometry.
  geometry    :: Geometry -> Config w
---
-- Gets the object's geometry.
  getGeometry :: w -> IO Geometry

---
-- Canvasitems with an anchor position on the canvas instantiate the
-- <code>class HasCanvAnchor</code>.
class GUIObject w => HasCanvAnchor w where
---
-- Sets the anchor position on the canvas.
  canvAnchor	:: Anchor -> Config w
---
-- Gets the anchor position on the canvas.
  getCanvAnchor   :: w -> IO Anchor


-- -----------------------------------------------------------------------
-- has border
-- -----------------------------------------------------------------------

---
-- Objects with a configureable border instantiate the
-- <code>class HasBorder</code>.
class GUIObject w => HasBorder w where
---
-- Sets the width of the object's border.
  borderwidth     :: Distance -> Config w
---
-- Gets the width of the object's border.
  getBorderwidth  :: w -> IO Distance
---
-- Sets the object's relief.
  relief          :: Relief -> Config w
---
-- Gets the object's relief.
  getRelief       :: w -> IO Relief
  borderwidth s w  = cset w "borderwidth" s
  getBorderwidth w = cget w "borderwidth"
  relief r w       = cset w "relief" r
  getRelief w      = cget w "relief"


-- -----------------------------------------------------------------------
-- objects associated with a value
-- -----------------------------------------------------------------------

---
-- Objects that have a value instantiate the
-- <code>class HasValue</code>.
class (GUIObject w, GUIValue v) => HasValue w v where
---
-- Sets the object's value.
  value      :: v -> Config w
---
-- Gets the object's value.
  getValue   :: w -> IO v
  value v w = cset w "value" v >> return w
  getValue w = cget w "value"


-- -----------------------------------------------------------------------
-- text labelled widgets
-- -----------------------------------------------------------------------

---
-- Objects containing text instantiate the class
-- <code>HasText</code>.
class (GUIObject w, GUIValue v) => HasText w v where
---
-- Sets the object's text.
  text      :: v -> Config w
---
-- Gets the object's text.
  getText   :: w -> IO v
  text t w  = cset w "text" t
  getText w = cget w "text"

---
-- Objects with a configureable font instantiate the
-- <code>class HasFont</code>.
class GUIObject w => HasFont w where
---
-- Sets the object's font.
  font     :: FontDesignator f => f -> Config w
---
-- Gets the object's font.
  getFont  :: w -> IO Font
  font f w  = cset w "font" (toFont f)
  getFont w = cget w "font"

---
-- Objects that have a text underline configure option instantiate th
-- <code>class HasUnderline</code>.
class GUIObject w => HasUnderline w where
---
-- Sets the index position of the text character to underline.
  underline      :: Int -> Config w
---
-- Gets the index position of the text character to underline.
  getUnderline   :: w -> IO Int
---
-- Sets the maximum line length for text in screen units.
  wraplength     :: Int -> Config w
---
-- Gets the maximum line length for text in screen units.
  getWraplength  :: w -> IO Int
  underline i w   = cset w "underline" i
  getUnderline w  = cget w "underline"
  wraplength l w  = cset w "wraplength" l
  getWraplength w = cget w "wraplength" 

---
-- Objects that have a configureable text justification instantiate the
-- <code>class HasJustify</code>.
class GUIObject w => HasJustify w where
---
-- Sets the text justification.
  justify     :: Justify -> Config w
---
-- Gets the set text justification.
  getJustify  :: w -> IO Justify
  justify js w = cset w "justify" js
  getJustify w = cget w "justify"


-- -----------------------------------------------------------------------
-- grid
-- -----------------------------------------------------------------------

---
-- Objects that support geometry gridding instantiate the
-- <code>class HasGrid</code>.
class GUIObject w => HasGrid w where
---
-- Enables geometry gridding.
  setgrid    :: Toggle -> Config w
---
-- Gets the current setting.
  getGrid    :: w -> IO Toggle
  setgrid b w = cset w "setgrid" b
  getGrid w   = cget w "setgrid"


-- -----------------------------------------------------------------------
-- orientation
-- -----------------------------------------------------------------------

---
-- Oriented objects instantiate the <code>class HasOrientation</code>.
class GUIObject w => HasOrientation w where
---
-- Sets the object's orientation.
  orient      :: Orientation -> Config w
---
-- Gets the object's orientation.
  getOrient   :: w -> IO Orientation
  orient o w   = cset w "orient" o
  getOrient w  = cget w "orient"


-- -----------------------------------------------------------------------
-- file
-- -----------------------------------------------------------------------

---
-- Objects associated with a file instantiate the
-- <code>class HasFile</code>.
class GUIObject w => HasFile w where
---
-- Sets the name of the associated file.
  filename :: String -> Config w
---
-- Gets the name of the associated file.
  getFileName :: w -> IO String
        

-- -----------------------------------------------------------------------
-- align
-- -----------------------------------------------------------------------

---
-- Objects with a configureable alignment instantiate the
-- <code>class HasAlign</code>.        
class GUIObject w => HasAlign w where
  align     :: Alignment -> Config w
  getAlign  :: w -> IO Alignment
  align a w  = cset w "align" a
  getAlign w = cget w "align"


-- -----------------------------------------------------------------------
-- increment (canvas region, scales)
-- -----------------------------------------------------------------------

---
-- Incrementable objects (e.g. scale wigdgets) instantiate the
-- <code>class HasIncrement</code>.
class HasIncrement w a where
---
-- Increments the object.
  increment       :: a -> Config w
---
-- Gets object's incrementation.
  getIncrement    :: w -> IO a


-- -----------------------------------------------------------------------
--  enabling and disabling of widgets
-- -----------------------------------------------------------------------

---
-- Stateful objects that can be enabled or disabled instantiate the
-- <code>class HasEnable</code>.
class GUIObject w => HasEnable w where
---
-- Sets the objects state.
  state      :: State -> Config w
---
-- Gets the objects state.
  getState   :: w -> IO State
---
-- Disables the object.
  disable    :: Config w
---
-- Enables the object.
  enable     :: Config w
---
-- <code>True</code> if the object is enabled.
  isEnabled  :: w -> IO Bool
  state s w   = cset w "state" s
  getState w  = cget w "state"
  disable     = state Disabled
  enable      = state Normal
  isEnabled w = do {st <- getState w; return (st /= Disabled)}