browser.hs

{-
This is a test of how the browser draws lines.
This is a second line.
This is a third.

That was a blank line above this.

@r@_Right justify
@c@_Center justify
@_Left justify

@bBold text
@iItalic text
@b@iBold Italic
@fFixed width
@f@bBold Fixed
@f@iItalic Fixed
@f@i@bBold Italic Fixed
@lLarge
@l@bLarge bold
@sSmall
@s@bSmall bold
@s@iSmall italic
@s@i@bSmall italic bold
@uunderscore
@C1RED
@C2Green
@C4Blue

	You should try different browser types:
	Fl_Browser
	Fl_Select_Browser
	Fl_Hold_Browser
	Fl_Multi_Browser
-}

module Main where
import qualified Graphics.UI.FLTK.LowLevel.FL as FL
import Graphics.UI.FLTK.LowLevel.FLTKHS
import Control.Monad
import System.Environment

data CallbackType = Top | Middle | Bottom | Visible | Browser
bCb :: Ref SelectBrowser -> IO ()
bCb browser' = FL.eventClicks >>= setValue browser'

showCb :: CallbackType -> Ref IntInput -> Ref SelectBrowser -> IO ()
showCb buttontype' field' browser' = do
  line' <- getValue field'
  if (null line')
    then print "Please enter a number in the text field before clicking on the buttons."
    else do
    let lineNumber' = read line'
    case buttontype' of
     Top -> setTopline browser' lineNumber'
     Bottom -> setBottomline browser' lineNumber'
     Middle -> setMiddleline browser' lineNumber'
     _ -> makeVisible browser' lineNumber'

swapCb :: Ref SelectBrowser -> Ref Button -> IO ()
swapCb browser' _ =
  do
    browserSize' <- getSize browser'
    linesSelected' <- filterM (selected browser') [0..(browserSize' - 1)]
    case linesSelected' of
     (l1:l2:_) -> swap browser' l1 l2
     (l1:[]) -> swap browser' l1 (-1)
     _ -> swap browser' (-1) (-1)

sortCb :: Ref SelectBrowser -> Ref Button -> IO ()
sortCb browser' _ = sortWithSortType browser' SortAscending

btypeCb :: Ref SelectBrowser -> Ref Choice -> IO ()
btypeCb browser' btype' = do
  numLines' <- getSize browser'
  forM_ [1..(numLines' - 1)] (\l -> select browser' l False)
  _ <- select browser' 1 False -- leave focus box on first line
  choice' <- getText btype'
  case choice' of
   "Normal" -> setType browser' NormalBrowserType
   "Select" -> setType browser' SelectBrowserType
   "Hold" -> setType browser' HoldBrowserType
   "Multi" -> setType browser' MultiBrowserType
   _ -> return ()
  redraw browser'

main :: IO ()
main = do
  args <- getArgs
  if (null args) then print "Enter the path to a text file as an argument. As an example use this file (./src/Examples/browser.hs) to see what Fl_Browser can do."
    else do
     let fname = head args
     window <- doubleWindowNew (Size (Width 560) (Height 400)) Nothing (Just fname)
     browser' <- selectBrowserNew (Rectangle (Position (X 0) (Y 0)) (Size (Width 560) (Height 350))) Nothing
     setType browser' MultiBrowserType
     setCallback browser' bCb
     loadStatus' <- load browser' fname
     if (loadStatus' == 0)
       then print ("Can't load " ++ fname)
       else do
       setPosition browser' 0
       field <- intInputNew (toRectangle (55,350,505,25)) (Just "Line #:")
       setCallback field (\_ -> showCb Browser field browser')
       top' <- buttonNew (toRectangle (0,375,80,25)) (Just "Top")
       setCallback top' (\_ -> showCb Top field browser')
       bottom' <- buttonNew (toRectangle (80,375,80,25)) (Just "Bottom")
       setCallback bottom' (\_ -> showCb Bottom field browser')
       middle' <- buttonNew (toRectangle (160,375,80,25)) (Just "Middle")
       setCallback middle' (\_ -> showCb Middle field browser')
       visible' <- buttonNew (toRectangle (240,375,80,25)) (Just "Make Vis.")
       setCallback visible' (\_ -> showCb Visible field browser')
       swap' <- buttonNew (toRectangle (320,375,80,25)) (Just "Swap")
       setCallback swap' $ swapCb browser'
       setTooltip swap' "Swaps two selected lines\n(Use CTRL-click to select two lines)"
       sort' <- buttonNew (toRectangle (400,375,80,25)) (Just "Sort")
       setCallback sort' (sortCb browser')
       btype <- choiceNew (toRectangle (480,375,80,25)) Nothing
       addName btype "Normal"
       addName btype "Select"
       addName btype "Hold"
       addName btype "Multi"
       setCallback btype $ btypeCb browser'
       _ <- setValue btype (MenuItemByIndex (MenuItemIndex 3))
       setResizable window (Just browser')
       showWidget window
       _ <- FL.run
       return ()