module Main where
import Tcl

import Char

import qualified BasicList
import qualified BasicMenu
import qualified Bounce
import qualified Buttons
import qualified CheckBut
import qualified Citems
import qualified Entries
import qualified GraphEdit
import qualified Hello
import qualified Image
import qualified Koch
import qualified Labels
import qualified Logo
import qualified Menus
import qualified RadioBut
import qualified Ted
import qualified VertScale
import qualified Dialog
import qualified EWidgetDemo

type Text = String
type Prog = String
type Comment = Text

data Line = Heading Text
          | Body Text
          | Link Text Prog Comment
	  | Dsc Text

main = start $
     do dot <- rootWin 
	title dot "Widget Demonstration"
	dotm <- menu dot [tearoff False]
	cset dot [use_menu dotm]

	m <- menu dot [tearoff False]
	cascade dotm m [wgt_label "File",underline 0]
 	mbutton m [wgt_label "About...   <F1>", underline 0, command info]
        separator m
 	mbutton m [wgt_label "Quit      Alt-Q", underline 0, 
                                  command (quit)]
	bind dot "<Alt-q>" quit
	bind dot "<F1>" info

        tf <- frame dot []  
        t  <- edit dot [wrap WordWrap, width 80, height 35,
                                     setgrid True, highlightthickness 0,
                                     padx 4, pady 2, takefocus False]
	ts <- vscroll t [highlightthickness 0, takefocus True]

	packAdd t [inFrame tf,packH,fillXY,packPadX 1,expand True]
	packAdd ts [packH,fillY,inFrame tf]
	packAdd tf [expand True,fillXY,packV]

 	sf <- frame dot []
        sl <- label dot [text "   ", relief Sunken,
       			 borderwidth 1, anchor W]
        
	packAdd sl [inFrame sf,packH,packPadX 2,expand True,fillXY]
	packAdd sf [packV,fillX,packPadY 2]

	tag' t "title" [] [font "Helvetica 14 bold"]
        tag' t "font1"  [] [font "Helvetica 12"]
	tag' t "font2"  [] [font "Helvetica 12"]
        demo_text <- proc read_lines
	mapM_ (display sl t) demo_text
        cset t [active_state Disabled]
 	return ()
     where 
	info = do tcl_ ["destroy .info"]
		  top <- window' ".info" []
 		  title top "About.."
		  msg <- message top [aspect 5000,justify CenterJ,text msg]
		 
		  f <- frame top [borderwidth 2, relief Ridge]
		  b <- button top [text " Ok ", 
			           command (destroy top)]
		  packAdd b [inFrame f]
		  packAdd msg [packV]
		  packAdd f [packV]
		  focus b
	          return () 		
		where
		  msg = unlines ["",
				 "",
				 "TclHaskell Demo Widget\n",
                                 "orginally by\n",
				 "David Copithorne",
				 "",
				 "updated by Meurig Sage",
				 "",
				 "based on the Tk `Widget Tour'",
				 "",
				 ""]

display :: Label -> Edit -> Line -> GUI ()
display sbar t line =
     do case line of
          Heading txt -> 
             do insertEditTagged t TIndexEnd txt ["title"]
		insertEdit t TIndexEnd "\n"
                return()
          Body txt ->
             do insertEditTagged t TIndexEnd (txt++"\n") ["font1"]
                return()
	  Dsc txt ->
	     do insertEditTagged t TIndexEnd (txt++"\n") ["font2"]
          Link txt prg cmt -> 
             do act_prg <- tag t [] [foreground "red", underline 1]
		tg <- tag t [] [foreground "blue", underline 1]
		insertEdit t TIndexEnd "     "
		insertEditTagged t TIndexEnd txt 
                         ["font1",tagId act_prg, tagId tg]
		insertEdit t TIndexEnd "\n"
		bind tg "<Enter>"           (enterTag tg cmt (tagId act_prg))
                bind tg "<ButtonRelease-1>" (invokeDemo tg prg)
		bind tg "<ButtonRelease-3>" (showCode tg prg)
                bind tg "<Leave>"           (leaveTag tg cmt (tagId act_prg))
                return()
	     where
                enterTag tg cmt act_prg = 
				  do raiseTag tg (Just act_prg) 
                                     cset t ["cursor" %% "hand2"]
				     cset sbar [text cmt]
                                     return ()

		leaveTag tg cmt act_prg = 
				  do lowerTag tg (Just act_prg)
				     cset t ["cursor" %% "xterm"]
				     cset sbar [text ""]
                                     return ()


invokeDemo :: Tag -> Prog -> GUI ()        
invokeDemo tg prg  = do cset tg [foreground "purple"]
			sequence_ [g | (p,g) <- demos, p == prg]
			return ()
		     where
			wn = "." ++ prg
		     			


demos :: [(Prog, GUI ())]
demos = [("basicList", BasicList.basicList)
	,("basicMenu", BasicMenu.basicMenu)
	,("bounce", Bounce.bounce)
	,("buttons", Buttons.buttons)
	,("checkBut", CheckBut.checkBut)
	,("citems", Citems.citems)
	,("entries", Entries.entries)
	,("graphEdit", GraphEdit.graphEdit)
	,("hello", Hello.hello)
	,("image", Image.images)
        ,("koch", Koch.koch)
	,("labels", Labels.labels)
	,("logo", Logo.logo)
	,("menus", Menus.menus)
	,("radioBut", RadioBut.radioBut)
	,("ewidgets",EWidgetDemo.ewidgets)
	,("ted", Ted.ted)
	,("vertScale", VertScale.vertScale)
        ,("dialog",Dialog.dialog)
	]

demos_tidy :: [(Prog, GUI ())]
demos_tidy = [("bounce", Bounce.bounce_tidy)]

showCode :: Tag -> Prog -> GUI ()
showCode tg prg@(p:ps) =
     do	cset tg [foreground "purple"]
 	tcl_ ["destroy .code"]
  	top <- window' ".code" []
        title top ("Demo code: " ++ fp)

        f  <- frame top []
        t  <- edit top [wrap WordWrap, height 40, width 80,
                                     font code_face, setgrid True, 
                                     highlightthickness 0,
                                     padx 4, pady 2, takefocus False]
	ts <- vscroll t [highlightthickness 0, takefocus True]
                         
	loadEditContents t
        cset t [active_state Disabled]

	packAdd t [inFrame f,packH,expand True,fillXY,packPadX 1]
	packAdd ts [packH,inFrame f,fillY]
	packAdd f [packV,expand True,fillXY]

	b <- frame top []
        b1 <- button top [text "Dismiss",command (destroy top)]
        b2 <- button top [text "Run Demo",command (invokeDemo tg prg)]

	mapM_ (\w -> packAdd w [inFrame b,packH,expand True,packPadY 2])
              [b1,b2]
	packAdd b [packV,fillX]
        return ()
     where
        fp = (toUpper p) : (ps  ++ ".hs")
        
        loadEditContents t = 
             do r <- tryGUI(loadEdit t fp)
		case r of
		  Right _  -> return ()
		  Left err -> resetEdit t (fp ++ ": File not found"); 	



read_lines :: IO [Line]
read_lines =
     do txt <- readFile "demo.txt"
        return (map parse (lines txt))

parse :: String -> Line
parse ('*':ln) = Heading ln
parse ('%':ln) = Dsc ln
parse ('>':ln) = Link txt prog cmt
      where
        cmt        = tail' ln1
        (prog,ln0) = break (=='>') ln
        (txt, ln1) = break (=='>') (tail' ln0)

        tail' []    = []
        tail' (_:t) = t
parse ln       = Body ln

code_face :: String
code_face = "*-courier-medium-r-normal--*-120-*-*-*-*-*-*"

