Ticket #1222: Main.hs

-----------------------------------------------------------------------------
--
-- Module      :  Main
-- Copyright   :  Marc  Mertens
-- License     :  AllRightsReserved
--
-- Maintainer  :  Marc Mertens
-- Stability   :  Alpha
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module Main (main
) where
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo
       (relMoveTo, moveTo, showText, Render, liftIO)
import Graphics.UI.Gtk.Gdk.GC



drawSingleCairo :: Int -> Int -> Int -> Render ()
drawSingleCairo n minY maxY = do
  if (n*30 < minY)
    then drawSingleCairo (n+1) minY maxY
    else if (maxY < (n-1)*30)
            then return ()
            else do
                pc<-liftIO $ cairoCreateContext Nothing
                moveTo 0 $ fromIntegral(n-1)*30
                lay <- liftIO $ layoutText pc ("T'was brillig and the slithy toves (Jabberwocky) " ++ (show n))
                -- liftIO $ layoutSetAttributes lay [AttrForeground 0 (-1) (Color 255 0 0)] -- Will be neglected
                liftIO $ layoutSetAttributes lay [AttrBackground 0 (-1) (Color 255 0 0)]
                showLayout lay
                drawSingleCairo (n+1) minY maxY

drawWindow :: DrawingArea -> Int -> IO ()
drawWindow canvas n = do
   area <- widgetGetDrawWindow canvas
   region <- drawableGetVisibleRegion area
   Rectangle x y w h <- regionGetClipbox region
   renderWithDrawable area $ drawSingleCairo 0 y (y+h)
   return ()

drawWindowCairo :: IO ()
drawWindowCairo = do
  return ()
main = do
    let n = 10000000
    initGUI
    window <- windowNew
    set window [windowTitle := "Color Test",
                windowDefaultWidth := 800,
                windowDefaultHeight := 800,
                containerBorderWidth :=5]
    frame <- frameNew
    containerAdd window frame
    scrolledWindow <- scrolledWindowNew Nothing Nothing
    containerAdd frame scrolledWindow
    canvas <- drawingAreaNew
    scrolledWindowAddWithViewport scrolledWindow canvas

    widgetSetSizeRequest canvas 800 (60 * n)

    on canvas exposeEvent $ do
        liftIO $ drawWindow canvas n
        return True
    widgetShowAll window
    onDestroy window mainQuit
    mainGUI