hasloGUI-0.1: HasloGUI.hs
---------------------------------------------------------
--
-- Module : HasloGUI
-- Copyright : Bartosz Wójcik (2012)
-- License : BSD3
--
-- Maintainer : bartek@sudety.it
-- Stability : Unstable
-- Portability : portable
--
-- | Example of usage two libraries: wtk-gtk and Haslo.
-- Simply loan calculator with Gtk GUI.
---------------------------------------------------------
module Main
where
import Haslo
import Data.Maybe (fromJust)
import Graphics.UI.Gtk
import Data.IORef
import Data.Lenses
import Data.List
import Control.Monad.Reader
import Haslo.GUI.Gtk.HasloGUIState
import Haslo.GUI.Gtk.HasloGUILogic
import Haslo.GUI.Gtk.HasloGUIGtk
import Graphics.UI.Gtk.WtkGui
import Graphics.UI.Gtk.WtkGtk
-- ============ LICENCE =====================
thisVersion = "0.1"
thisLicenceType = "Evaluation"
thisLicenceTill = "31.12.2012"
thisLicenceFor = "Public"
-- ==========================================
main :: IO ()
main = do
initGUI
vbox <- vBoxNew False 0
ntbk <- notebookNew
st <- initState ntbk -- notebook
initMyState
showTable -- input page formating and packing function
-- Here, in showTable everything is hidden
newSt -- user state update function
False -- debug off
window <- windowNew
set window [windowTitle := "Haslo GUI",
windowDefaultWidth := 350,
windowDefaultHeight := 700 ]
containerAdd window vbox
(vb,collection) <- showTable 0 st
notebookInsertPage ntbk vb "Input" 0
widgetShowAll vb
about <- actionNew "ABOUT" "About" Nothing (Just stockAbout)
onActionActivate about aboutDialog
-- param <- actionNew "PARAM" "Parameters" Nothing Nothing
-- onActionActivate param $ paramDialog st
agr <- actionGroupNew "AGR"
mapM_ (\a -> actionGroupAddActionWithAccel agr a Nothing) [about
-- ,param
]
ui <- uiManagerNew
uiManagerAddUiFromString ui uiDecl
uiManagerInsertActionGroup ui agr 0
maybeMenubar <- uiManagerGetWidget ui "/ui/menubar"
let menubar = case maybeMenubar of
(Just x) -> x
Nothing -> error "Cannot get menubar from string."
boxPackStart vbox menubar PackNatural 0
maybeToolbar <- uiManagerGetWidget ui "/ui/toolbar"
let toolbar = case maybeToolbar of
(Just x) -> x
Nothing -> error "Cannot get toolbar from string."
boxPackStart vbox toolbar PackNatural 0
boxPackStart vbox ntbk PackGrow 0
widgetShowAll window
onDestroy window mainQuit
mainGUI
uiDecl= "<ui>\
\ <menubar>\
\ <menuitem action=\"ABOUT\" />\
\ </menubar>\
\ <toolbar>\
\ </toolbar>\
\ </ui>"
olduiDecl= "<ui>\
\ <menubar>\
\ <menu action=\"CONTRACT\">\
\ <menuitem action=\"RELOAD\" />\
\ <menuitem action=\"FIND\" />\
\ <menuitem action=\"SAVE\" />\
\ </menu>\
\ <menuitem action=\"ABOUT\" />\
\ <menuitem action=\"PARAM\" />\
\ </menubar>\
\ <toolbar>\
\ <toolitem action=\"RELOAD\" />\
\ <toolitem action=\"FIND\" />\
\ <toolitem action=\"SAVE\" />\
\ </toolbar>\
\ </ui>"
aboutDialog = do
dia <- aboutDialogNew
-- Displayed version is a combination of ElcaGUI and elca engine versions.
aboutDialogSetVersion dia $ thisVersion ++ "\non engine " ++ getVersionHaslo
aboutDialogSetCopyright dia "(c) Bartosz Wojcik 2012"
aboutDialogSetComments dia thisLicenceFor
aboutDialogSetLicense dia (Just thisLicenceType)
aboutDialogSetAuthors dia ["Bartosz Wojcik"]
answer <- dialogRun dia
widgetDestroy dia
-- | User defined layout of the input. Each inputable widget has to have its own
-- entry in the state, as 'InputField'.
--
-- Following order of packing:
-- window, notebook, notebook's page, vbox, scrolledWindow, table
-- What is important: this function has to return vbox, so it's not necessarily
-- scrolledWindow and table to be packed in.
showTable :: Int -- ^ id of widget with focus
-> IORef (State MyState) -- ^ state living in IO
-> IO (VBox, [WidgetsCollection]) -- ^ vbox containing table of the content, list of widgets needed for grabing focus
showTable nr state = do
vb <- vBoxNew False 0
scrwin <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy scrwin PolicyNever PolicyAutomatic
boxPackStart vb scrwin PackGrow 0
-- H-box put into scrolled window
vbFramesA <- hBoxNew False 0
scrolledWindowAddWithViewport scrwin vbFramesA
st <- readIORef state
-- V-box on the left hand side of vbFramesA
vbFrames <- vBoxNew False 0
boxPackStart vbFramesA vbFrames PackGrow 0
-- V-box on the right hand side of vbFramesA
vbFramesR <- vBoxNew False 0
boxPackStart vbFramesA vbFramesR PackGrow 0
-- showDBDetails vbFrames $ usrSt st
table <- myNewTable "Loan" vbFrames 29 4
-- Loan frame and its content
textToTableCellL "Type of loan" 1 0 table
cb0 <- showSelection (loanAPI $ usrSt st) 2 0 nr table state >>= \x -> return $ CSL (0,x)
errMsgToTable (loanAPI $ usrSt st) 2 1 table
hlineToTable 1 3 table
textToTableCellL "Principal" 1 2 table
en1 <- showEntry (principalAPI $ usrSt st) 2 2 nr table state >>= \x -> return $ CEn (1,x)
textToTableCellL "<small>(accepting arithmetic\n statement) </small>" 3 2 table
errMsgToTable (principalAPI $ usrSt st) 2 3 table
en7 <- case (balloonAPI $ usrSt st) `fetch` att_visible of
True -> do let label = case fromJust $ loanS $ usrSt st of
ClReversBalloon -> "Instalment amount"
ClUnfoldedBalloon -> "Residual balloon"
ClUnfoldedBalloonPlus -> "Residual balloon"
_ -> "Balloon"
textToTableCellL label 1 4 table
en <- showEntry (balloonAPI $ usrSt st) 2 4 nr table state
errMsgToTable (balloonAPI $ usrSt st) 2 5 table
return $ CEn (7,en)
False -> return Dummy
textToTableCellL "Number of instalments" 1 6 table
en2 <- showEntry (durationAPI $ usrSt st) 2 6 nr table state >>= \x -> return $ CEn (2,x)
errMsgToTable (durationAPI $ usrSt st) 2 7 table
let label3 = "Effecitve interest rate"
textToTableCellL label3 1 8 table
en3 <- showEntry (rateAPI $ usrSt st) 2 8 nr table state >>= \x -> return $ CEn (3,x)
textToTableCellL "%" 3 8 table
errMsgToTable (rateAPI $ usrSt st) 2 9 table
en5 <- case (eXtDurAPI $ usrSt st) `fetch` att_visible of
True -> do let label = "Max. extended duration"
textToTableCellL label 1 10 table
en <- showEntry (eXtDurAPI $ usrSt st) 2 10 nr table state
errMsgToTable (eXtDurAPI $ usrSt st) 2 11 table
return $ CEn (eXtDurId,en)
False -> return Dummy
textToTableCellL "1st instalment deferment" 1 12 table
en4 <- showEntry (delayAPI $ usrSt st) 2 12 nr table state >>= \x -> return $ CEn (4,x)
errMsgToTable (delayAPI $ usrSt st) 2 13 table
hlineToTable 16 3 table
bt1 <- buttonNewWithLabel "Amotization Schedule" >>= \bt ->
showButton (action100API $ usrSt st) 2 25 nr table state bt openNewPageAbs >>
return (CBu (8,bt))
let returnList = cb0 : en1 : en2 : en3 : en5 : en4 : bt1 : en7 : []
return (vb,returnList)