hasloGUI (empty) → 0.1
raw patch · 4 files changed
+276/−0 lines, 4 filesdep +QuickCheckdep +basedep +convertiblesetup-changed
Dependencies added: QuickCheck, base, convertible, gtk, haslo, lenses, mtl, old-time, time, wtk, wtk-gtk
Files
- HasloGUI.hs +222/−0
- Setup.hs +2/−0
- hasloGUI.cabal +21/−0
- license +31/−0
+ HasloGUI.hs view
@@ -0,0 +1,222 @@+--------------------------------------------------------- +-- +-- 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) +
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hasloGUI.cabal view
@@ -0,0 +1,21 @@+Name: hasloGUI +Version: 0.1 +License: BSD3+License-file: license +Author: Bartosz Wojcik +Maintainer: Bartosz Wojcik <bartoszmwojcik@gmail.com> +Copyright: Copyright (c) 2012, Bartosz Wojcik +Category: Financial +Synopsis: Loan calculator Gtk GUI. Based on haslo (Haskell Loan) library. +Stability: experimental +Build-type: Simple +Description: Example of usage of loan library named Haslo and of wtk-gtk wrapper over gtk. + +Cabal-Version: >=1.2.3 + +Executable HasloGUI + include-dirs: . + Build-Depends: base >= 3 && < 5, old-time, QuickCheck, mtl, time, + lenses, convertible, gtk >= 0.10.1, haslo, wtk, wtk-gtk + Main-Is: HasloGUI.hs +
+ license view
@@ -0,0 +1,31 @@+Copyright (c) 2012, Bartosz Wójcik++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.