diff --git a/haskell/gtk-gui/.gitignore b/haskell/gtk-gui/.gitignore new file mode 100644 index 0000000..c368d45 --- /dev/null +++ b/haskell/gtk-gui/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ \ No newline at end of file diff --git a/haskell/gtk-gui/README.md b/haskell/gtk-gui/README.md new file mode 100644 index 0000000..f698311 --- /dev/null +++ b/haskell/gtk-gui/README.md @@ -0,0 +1,32 @@ +# Creating a GUI application in Haskell with GTK+ + +## Description + +This project serves as a companion codebase for Stack Builder's blog post ["Creating a GUI application in Haskell."](https://www.stackbuilders.com/blog/gui-application/) + +## Installation + +For installation instructions of C libraries required by Gtk2Hs and haskell-gi, please refer to the [Gtk2Hs Github Repository](https://github.com/gtk2hs/gtk2hs?tab=readme-ov-file#installing-c-libraries). The installation process may vary depending on your operating system, so make sure to follow the instructions specific to your platform. + +**WARNING**: This setup is incompatible with ARM architectures. + +## Building and Running the Project + +1. **Clone the Repository**: Clone this repository to your local machine and navigate to the project directory. + + ```bash + git clone https://github.com/stackbuilders/blog-code.git + cd haskell/gtk-gui/ + ``` + +2. **Build the Project**: Use Stack to build the project. + + ```bash + stack build + ``` + +3. **Run the Project**: Run the project with the following command: + + ```bash + stack exec gtk-gui-exe + ``` diff --git a/haskell/gtk-gui/Setup.hs b/haskell/gtk-gui/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/haskell/gtk-gui/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell/gtk-gui/app/Main.hs b/haskell/gtk-gui/app/Main.hs new file mode 100644 index 0000000..da8b344 --- /dev/null +++ b/haskell/gtk-gui/app/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Lib + +main :: IO () +main = renderCalculator diff --git a/haskell/gtk-gui/gtk-gui.cabal b/haskell/gtk-gui/gtk-gui.cabal new file mode 100644 index 0000000..eb67ee8 --- /dev/null +++ b/haskell/gtk-gui/gtk-gui.cabal @@ -0,0 +1,61 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: gtk-gui +version: 0.1.0.0 +homepage: https://github.com/stackbuilders/blog-code#readme +bug-reports: https://github.com/stackbuilders/blog-code/issues +author: Mark Karpov +maintainer: jgalarza@stackbuilders.com +copyright: 2016 Mark Karpov +license: BSD-3-Clause +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/stackbuilders/blog-code + +library + exposed-modules: + Lib + other-modules: + Paths_gtk_gui + autogen-modules: + Paths_gtk_gui + hs-source-dirs: + src + build-tools: + alex >=3.4.0.1 && <3.4.1 + , happy >=1.20.1.1 && <1.20.2 + build-tool-depends: + gtk2hs-buildtools:gtk2hs-buildtools ==0.13.10.* + , haskell-gi:haskell-gi ==0.26.8.* + build-depends: + base >=4.7 && <5 + , gtk3 ==0.15.8.* + default-language: Haskell2010 + +executable gtk-gui-exe + main-is: Main.hs + other-modules: + Paths_gtk_gui + autogen-modules: + Paths_gtk_gui + hs-source-dirs: + app + build-tools: + alex >=3.4.0.1 && <3.4.1 + , happy >=1.20.1.1 && <1.20.2 + build-tool-depends: + gtk2hs-buildtools:gtk2hs-buildtools ==0.13.10.* + , haskell-gi:haskell-gi ==0.26.8.* + build-depends: + base >=4.7 && <5 + , gtk-gui + , gtk3 ==0.15.8.* + default-language: Haskell2010 diff --git a/haskell/gtk-gui/package.yaml b/haskell/gtk-gui/package.yaml new file mode 100644 index 0000000..ee90a8f --- /dev/null +++ b/haskell/gtk-gui/package.yaml @@ -0,0 +1,30 @@ +name: gtk-gui +version: 0.1.0.0 +github: "stackbuilders/blog-code" +license: BSD-3-Clause +author: "Mark Karpov" +maintainer: "jgalarza@stackbuilders.com" +copyright: "2016 Mark Karpov" + +extra-source-files: +- README.md + +dependencies: +- base >= 4.7 && < 5 +- gtk3 >= 0.15.8 && < 0.15.9 + +build-tools: +- alex >= 3.4.0.1 && < 3.4.1 +- happy >= 1.20.1.1 && < 1.20.2 +- haskell-gi >= 0.26.8 && < 0.26.9 +- gtk2hs-buildtools >= 0.13.10 && < 0.13.11 + +library: + source-dirs: src + +executables: + gtk-gui-exe: + main: Main.hs + source-dirs: app + dependencies: + - gtk-gui diff --git a/haskell/gtk-gui/src/Lib.hs b/haskell/gtk-gui/src/Lib.hs new file mode 100644 index 0000000..95c186b --- /dev/null +++ b/haskell/gtk-gui/src/Lib.hs @@ -0,0 +1,216 @@ +module Lib + ( renderCalculator + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.IORef +import Graphics.UI.Gtk hiding (Action, backspace) + +renderCalculator :: IO () +renderCalculator = do + st <- newIORef (Value "" Nothing) + void initGUI + window <- renderWindow + display <- renderDisplay + grid <- gridNew + gridSetRowHomogeneous grid True + let attach x y w h item = gridAttach grid item x y w h + mkBtn = mkButton st display + attach 0 0 5 1 display + mkBtn "MC" id >>= attach 0 1 1 1 + mkBtn "MR" id >>= attach 1 1 1 1 + mkBtn "MS" id >>= attach 2 1 1 1 + mkBtn "M+" id >>= attach 3 1 1 1 + mkBtn "M–" id >>= attach 4 1 1 1 + mkBtn "←" backspace >>= attach 0 2 1 1 + mkBtn "CE" clearEntry >>= attach 1 2 1 1 + mkBtn "C" clearAll >>= attach 2 2 1 1 + mkBtn "±" id >>= attach 3 2 1 1 + mkBtn "√" id >>= attach 4 2 1 1 + mkBtn "7" (enterDigit '7') >>= attach 0 3 1 1 + mkBtn "8" (enterDigit '8') >>= attach 1 3 1 1 + mkBtn "9" (enterDigit '9') >>= attach 2 3 1 1 + mkBtn "÷" (operator Division) >>= attach 3 3 1 1 + mkBtn "%" id >>= attach 4 3 1 1 + mkBtn "4" (enterDigit '4') >>= attach 0 4 1 1 + mkBtn "5" (enterDigit '5') >>= attach 1 4 1 1 + mkBtn "6" (enterDigit '6') >>= attach 2 4 1 1 + mkBtn "*" (operator Multiplication) >>= attach 3 4 1 1 + mkBtn "1/x" id >>= attach 4 4 1 1 + mkBtn "1" (enterDigit '1') >>= attach 0 5 1 1 + mkBtn "2" (enterDigit '2') >>= attach 1 5 1 1 + mkBtn "3" (enterDigit '3') >>= attach 2 5 1 1 + mkBtn "–" (operator Subtraction) >>= attach 3 5 1 1 + mkBtn "=" equals >>= attach 4 5 1 2 + mkBtn "0" (enterDigit '0') >>= attach 0 6 2 1 + mkBtn "." enterDot >>= attach 2 6 1 1 + mkBtn "+" (operator Addition) >>= attach 3 6 1 1 + containerAdd window grid + window `on` deleteEvent $ do + liftIO mainQuit + return False + widgetShowAll window + mainGUI + +---------------------------------------------------------------------------- +-- Calculator's state + +-- | 'Value' holds textual representation of first argument reversed and +-- 'Action' to apply to it, which see. +data Value = Value String (Maybe Action) + +-- | Action to apply to first argument and textual representation of second +-- argument reversed (if relevant). +data Action + = Addition String + | Subtraction String + | Multiplication String + | Division String + +-- | Change second argument inside of 'Action'. +mapAction :: (String -> String) -> Action -> Action +mapAction f (Addition x) = Addition (f x) +mapAction f (Subtraction x) = Subtraction (f x) +mapAction f (Multiplication x) = Multiplication (f x) +mapAction f (Division x) = Division (f x) + +-- | Get second argument from 'Action'. +getSndArg :: Action -> String +getSndArg (Addition x) = x +getSndArg (Subtraction x) = x +getSndArg (Multiplication x) = x +getSndArg (Division x) = x + +-- | Render given 'Value'. +renderValue :: Value -> String +renderValue (Value x action) = + g x ++ f a ++ (if null y then "" else g y) + where + (a, y) = + case action of + Nothing -> ("", "") + Just (Addition arg) -> ("+", arg) + Just (Subtraction arg) -> ("–", arg) + Just (Multiplication arg) -> ("*", arg) + Just (Division arg) -> ("÷", arg) + f "" = "" + f l = " " ++ l ++ " " + g "" = "0" + g xs = reverse xs + +---------------------------------------------------------------------------- +-- Calculator's operations + +-- | Change state as if a dot is entered. +enterDot :: Value -> Value +enterDot (Value x action) = + let f xs = if '.' `elem` xs then xs else '.' : xs + in case action of + Nothing -> Value (f x) Nothing + Just a -> Value x (Just $ mapAction f a) + +-- | Change state as if specific char (digit) is entered. +enterDigit :: Char -> Value -> Value +enterDigit ch (Value x action) = + case action of + Nothing -> Value (ch:x) Nothing + Just a -> Value x (Just $ mapAction (ch:) a) + +-- | Change state as if last character of current argument is removed. +backspace :: Value -> Value +backspace (Value x action) = + case action of + Nothing -> Value (drop 1 x) Nothing + Just a -> Value x (Just $ mapAction (drop 1) a) + +-- | Apply given operator to current state. If some action is already fully +-- constructed, evaluate it first. +operator :: (String -> Action) -> Value -> Value +operator op value = + let (Value x action) = equals value + in Value x $ Just $ + case action of + Nothing -> op "" + Just a -> op (getSndArg a) + +-- | Change state as if current argument is removed. +clearEntry :: Value -> Value +clearEntry (Value x action) = + case action of + Nothing -> Value "" Nothing + Just a -> + if null (getSndArg a) + then Value "" Nothing + else Value x (Just $ mapAction (const "") a) + +-- | Change state returning it to the default value. +clearAll :: Value -> Value +clearAll = const (Value "" Nothing) + +-- | Evaluate current calculator's state putting result in place of first +-- argument. +equals :: Value -> Value +equals (Value x action) = + case action of + Nothing -> Value x Nothing + Just a -> + if null (getSndArg a) + then Value x action + else Value result Nothing + where + g :: String -> Double + g "" = 0 + g ('.':xs) = g ('0':'.':xs) + g xs = read (reverse xs) + x' = g x + y' = g (getSndArg a) + result = reverse . show $ + case a of + Addition _ -> x' + y' + Subtraction _ -> x' - y' + Multiplication _ -> x' * y' + Division _ -> x' / y' + +---------------------------------------------------------------------------- +-- Helpers + +-- | Create a button and attach handler to it that mutates calculator's +-- state with given function. +mkButton + :: IORef Value -- ^ 'IORef' to calculator state + -> Entry -- ^ Our display to update + -> String -- ^ Button label + -> (Value -> Value) -- ^ How this button affects calculator state + -> IO Button -- ^ Resulting button object +mkButton st display label mutateState = do + btn <- buttonNew + set btn [ buttonLabel := label ] + btn `on` buttonActivated $ do + value <- atomicModifyIORef st $ \x -> let r = mutateState x in (r, r) + updateDisplay display value + return btn + +-- | Make calculator's display show given 'Value'. +updateDisplay :: Entry -> Value -> IO () +updateDisplay display value = + set display [ entryText := renderValue value ] + +-- | Create a new window with default settings. +renderWindow :: IO Window +renderWindow = do + window <- windowNew + set window [ windowTitle := "Calculator" + , windowResizable := False + , windowDefaultWidth := 230 + , windowDefaultHeight := 250 ] + pure window + +-- | Create a new display with default settings. +renderDisplay :: IO Entry +renderDisplay = do + display <- entryNew + set display [ entryEditable := False + , entryXalign := 1 -- makes contents right-aligned + , entryText := "0" ] + pure display diff --git a/haskell/gtk-gui/stack.yaml b/haskell/gtk-gui/stack.yaml new file mode 100644 index 0000000..61f87be --- /dev/null +++ b/haskell/gtk-gui/stack.yaml @@ -0,0 +1,4 @@ +resolver: lts-22.13 + +packages: +- . diff --git a/haskell/gtk-gui/stack.yaml.lock b/haskell/gtk-gui/stack.yaml.lock new file mode 100644 index 0000000..fcf6d2a --- /dev/null +++ b/haskell/gtk-gui/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: 6f0bea3ba5b07360f25bc886e8cff8d847767557a492a6f7f6dcb06e3cc79ee9 + size: 712905 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/13.yaml + original: lts-22.13