--  CharModes
--
--  Author : Hermann O. Rodrigues
--  Created: April 2001
--
--  $Id$
--
--  Copyright (c) 2000 Hermann O. Rodrigues
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published
--  by the Free Software Foundation; either version 2 of the License,
--  or (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful, but
--  WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  General Public License for more details.
-- 
--- DESCRIPTION ---------------------------------------------------------------
--
--  This module provides higher level functionalities to allow color
--  and font formating during text printing as described in the ISO
--  6429 report and in the ANSI standard. 
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  A case example to teach the using of the `CharModes' module is
--  provided:
--  To print the text "Jedi Rules!" using a yellow background and
--  using a bold blue font to "Jedi" and an italic font to " Rules!"
--  in an ANSI terminal, use the following code sequence:
--  (  putStrLn
--   . show
--   ) $ (  bgColor Yellow
--        . bold
--        . fgColor Blue
--        . cmTxt
--        ) "Jedi"
--       +++
--       (  bgColor Yellow
--        . italic
--        . cmTxt
--        ) " Rules!"
--
--  The code sequence below is preferred (and shorter): 
--  putStrLn $ (  show
--              . bgColor Yellow
--              ) $ (  bold 
--                   . fgColor Blue
--                   . cmTxt
--                   ) "Jedi"
--                  +++
--                  (  italic
--                   . cmTxt
--                   ) " Rules!"
--
module CharModes (--
		  --  The character formating mode.
		  --
		  CharMode,
		  --
		  --  The character attributes.
		  --
		  CharAttribute (..),
		  --
		  --  The character colors.
		  --
		  CharColor (..),
		  --
		  --  The (C)haracter (M)ode Text.
		  --
		  CMText, cmTxtMode, cmTxt, (+++),
		  --
		  --  Attribute and color application.
		  --
		  attrib, fgColor, bgColor,
		  --
		  --  Predefined attribute application.
		  --
		  default', bold, nonBold, italic, underline, blink,
		  rapidBlink, reverseVideo, invisible)
where


--  Jedi module imports.
--  --------------------
import           BasicCharModes (CharMode, CharAttribute (..),
				 CharAttributeGroup, attribGroup,
				 attribCxt, CharColor (..), appMode,
				 transMode)
import qualified BasicCharModes (default')


--  The (C)haracter (M)ode Text.
--  ----------------------------

--  The (C)haracter (M)ode Text datatype (EXPORTED ABSTRACTLY).
--
data CMText = --
	      --  Adjacent `CMText's.
	      --
	      CMTextConc
              CMText
              CMText
              --
              --  Application of a `CharMode' to a string.
	      --
            | CMText
              CharMode
              String


--  Constructs a `CMText' using the given `CharMode' and the given
--  string (EXPORTED).
--
cmTxtMode :: CharMode
	  -> String
	  -> CMText
cmTxtMode = CMText


--  Constructs a `CMText' using the given string (EXPORTED).
--
--  * The resulting `CMText' has no defined attribute or color.
--
cmTxt :: String
      -> CMText
cmTxt = cmTxtMode ([], Nothing, Nothing)


--  Joins the given `CMText's (EXPORTED).
--
infixr 5 +++
(+++) :: CMText
      -> CMText
      -> CMText
(+++) = CMTextConc


--  `CMText' to string translation.
--  -------------------------------

instance Show CMText where
    showsPrec _ = shows'


--  Translate the given `CMText' to the equivalent string.
--
shows' :: CMText
       -> ShowS
shows' (CMTextConc cmtxt1 cmtxt2) =
      shows cmtxt1
    . shows cmtxt2
shows' (CMText cm s) =
    (  showString
     . BasicCharModes.default'
     . appMode cm
     ) s


--  Attribute and color application.
--  --------------------------------

--  Applies the given character attribute list to the given `CMText'
--  (EXPORTED).
--
--  * This has no effect if the given `CMText' attributes belong to
--    the attribute group of the attributes in use.
--
attrib :: [CharAttribute]
       -> CMText
       -> CMText
attrib attribl cmtxt@(CMText (attribl', mcol1, mcol2) s) =
    let attribl'' = attribCxt attribl attribl'
     in if attribl'' == attribl'
        then cmtxt
        else CMText
             (attribl'', mcol1, mcol2)
             s
attrib attribl (CMTextConc cmtxt1 cmtxt2) =
    CMTextConc
    (attrib attribl cmtxt1)
    (attrib attribl cmtxt2)


--  Colours the given `CMText' using the given foreground color
--  (EXPORTED).
--
--  * This has no effect if the `CMText' foreground color is already
--    defined.
--
fgColor :: CharColor
	-> CMText
	-> CMText
fgColor col cmtxt@(CMText (attribl, mcol1, mcol2) s) =
    case mcol1 of
     Nothing -> CMText
                (attribl, Just col, mcol2)
                s
     _       -> cmtxt
fgColor col (CMTextConc cmtxt1 cmtxt2) =
    CMTextConc
    (fgColor col cmtxt1)
    (fgColor col cmtxt2)


--  Colours the given `CMText' using the given background color
--  (EXPORTED).
--
--  * This has no effect if the `CMText' background color is already
--    defined.
--
bgColor :: CharColor
	-> CMText
	-> CMText
bgColor col cmtxt@(CMText (attribl, mcol1, mcol2) s) =
    case mcol2 of
     Nothing -> CMText
                (attribl, mcol1, Just col)
                s
     _       -> cmtxt
bgColor col (CMTextConc cmtxt1 cmtxt2) =
    CMTextConc
    (bgColor col cmtxt1)
    (bgColor col cmtxt2)


--  Predefined attribute application.
--  ---------------------------------

--  Applies the given predefined attribute to the given `CMText'
--  (EXPORTED).
--
default', bold, nonBold, italic, underline, blink, rapidBlink,
       reverseVideo, invisible :: CMText
			       -> CMText
default'     = attrib [Default      ]
bold         = attrib [HighIntensity]
nonBold      = attrib [LowIntensity ]
italic       = attrib [Italic       ]
underline    = attrib [Underline    ]
blink        = attrib [Blink        ]
rapidBlink   = attrib [RapidBlink   ]
reverseVideo = attrib [ReverseVideo ]
invisible    = attrib [Invisible    ]