# LANGUAGE ExistentialQuantification   #
{-# LANGUAGE RankNTypes                 #-}
# LANGUAGE ApplicativeDo               #
# LANGUAGE CPP               #

-- | The following program:
--
-- > {-# LANGUAGE ApplicativeDo     #-}
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Typed.Spreadsheet
-- > 
-- > main :: IO ()
-- > main = textUI "Example program" $ do
-- >     a <- checkBox   "a"
  >      b < - spinButton " b " 1
  >      c < - spinButton " c " 0.1
-- >     d <- entry      "d"
-- >     return (display (a, b + c, d))
--
-- ... creates a user interface that looks like this:
--
-- << User interface on startup>>
--
-- Every time you update a control on the left panel, the right panel updates
-- in response:
--
-- << User interface after user input>>
--
-- This library also supports graphical output, like in the following program:
--
-- > {-# LANGUAGE ApplicativeDo     #-}
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Diagrams.Prelude
-- > import Typed.Spreadsheet
-- > 
  > data AColor = Red | Orange | Yellow | Green | Blue | Purple
  >      deriving ( Enum , Bounded , Show )
-- > 
-- > toColor :: AColor -> Colour Double
-- > toColor Red    = red
-- > toColor Orange = orange
-- > toColor Yellow = yellow
-- > toColor Green  = green
-- > toColor Blue   = blue
-- > toColor Purple = purple
-- > 
-- > main :: IO ()
-- > main = graphicalUI "Example program" $ do
  >      color < - radioButton       " Color "         Red [ Orange .. Purple ]
  >      r      < - spinButtonAt 100 " Radius "        1
  >      x                " X Coordinate " 1
  >      y                " Y Coordinate " 1
-- >     return (circle r # fc (toColor color) # translate (r2 (x, y)))
--
-- This produces a canvas that colors, resizes, and moves a circle in response
-- to user input:
--
-- << Graphical user interface>>
--
-- The general workflow for this library is:
--
  * You build primitive ` Updatable ` values using ` checkBox ` , ` spinButton ` ,
--   `entry`, or `radioButton`, each of which corresponds to a control on the
--   left panel of the user interface
  * Combine ` Updatable ` values using @ApplicativeDo@ notation .   Composite values
    update whenever one of their substituent values update
-- * You consume an @(`Updatable` `Text`)@ value using `textUI`, which displays
--   the continuously updating value in the right panel of the user interface
--
-- You can get started quickly by cloning and building this project:
--
  > $ git clone -Typed-Spreadsheet-Library.git
-- > $ stack build --install-ghc             # Builds the executable
-- > $ stack exec typed-spreadsheet-example  # Runs the executable
--
-- ... or if you are using OS X, then build the project using:
--
  > $ stack --stack - yaml = osx.yaml build --install - ghc
--
  That project includes the code for the above examples in the @exec/@
-- subdirectory.  Just modify that file and rebuild to play with the example.
--
-- NOTE: You must compile your program with the @-threaded@ flag.  The example
-- project takes care of this.
--
-- See the \"Examples\" section at the bottom of this module for more examples.

module Typed.Spreadsheet (
    -- * Types
      Updatable
    , textUI
    , cellUI
    , graphicalUI
    , ui

    -- * Controls
    , checkBox
    , spinButton
    , entry
    , radioButton

    -- * Controls with Defaults
    , checkBoxAt
    , spinButtonAt
    , hscale
    , hscaleAt
    , hscaleWithRange
    , vscale
    , vscaleAt
    , vscaleWithRange
    , entryAt

    -- * Utilities
    , display

    -- * Examples
    -- $examples
    ) where

import Control.Applicative
import Control.Concurrent.STM (STM)
import Control.Foldl (Fold(..))
import Control.Monad.IO.Class (liftIO)
import Data.String (IsString(..))
import Data.Text (Text)
import Diagrams.Backend.Cairo (Cairo)
import Diagrams.Prelude (Diagram, r2, reflectY, translate, (#))
import Lens.Micro (_Left, _Right)
import Graphics.UI.Gtk (AttrOp((:=)))

import qualified Control.Concurrent
import qualified Control.Concurrent.STM   as STM
import qualified Control.Concurrent.Async
import qualified Control.Foldl
import qualified Data.Text
import qualified Diagrams.Backend.Gtk
import qualified Graphics.UI.Gtk          as Gtk

data Cell a = forall e . Cell (IO (STM e, Fold e a))

instance Functor Cell where
    fmap f (Cell m) = Cell (fmap (fmap (fmap f)) m)

instance Applicative Cell where
    pure a = Cell (pure (empty, pure a))

    Cell mF <*> Cell mX = Cell (liftA2 helper mF mX)
      where
        helper (inputF, foldF) (inputX, foldX) = (input, fold )
          where
            input = fmap Left inputF <|> fmap Right inputX

            fold  = do
                f <- Control.Foldl.handles _Left foldF
                x <- Control.Foldl.handles _Right foldX
                return (f x)

-- | An updatable input value
data Updatable a = Updatable (Control -> Cell a)

instance Functor Updatable where
    fmap f (Updatable m) = Updatable (fmap (fmap f) m)

instance Applicative Updatable where
    pure a = Updatable (pure (pure a))

    Updatable mf <*> Updatable mx = Updatable (liftA2 (<*>) mf mx)

#if MIN_VERSION_base(4,11,0)
instance Semigroup a => Semigroup (Updatable a) where
    (<>) = liftA2 (<>)

instance Monoid a => Monoid (Updatable a) where
    mempty = pure mempty

#else
instance Monoid a => Monoid (Updatable a) where
    mempty = pure mempty

    mappend = liftA2 mappend
#endif


instance IsString a => IsString (Updatable a) where
    fromString str = pure (fromString str)

instance Num a => Num (Updatable a) where
    fromInteger = pure . fromInteger

    negate = fmap negate
    abs    = fmap abs
    signum = fmap signum

    (+) = liftA2 (+)
    (*) = liftA2 (*)
    (-) = liftA2 (-)

instance Fractional a => Fractional (Updatable a) where
    fromRational = pure . fromRational

    recip = fmap recip

    (/) = liftA2 (/)

instance Floating a => Floating (Updatable a) where
    pi = pure pi

    exp   = fmap exp
    sqrt  = fmap sqrt
    log   = fmap log
    sin   = fmap sin
    tan   = fmap tan
    cos   = fmap cos
    asin  = fmap sin
    atan  = fmap atan
    acos  = fmap acos
    sinh  = fmap sinh
    tanh  = fmap tanh
    cosh  = fmap cosh
    asinh = fmap asinh
    atanh = fmap atanh
    acosh = fmap acosh

    (**)    = liftA2 (**)
    logBase = liftA2 logBase

-- | Use a `Control` to obtain updatable input `Updatable`s
data Control = Control
    { _checkBoxAt      :: Bool -> Text -> Cell Bool
    , _spinButtonAt    :: Double -> Text -> Double -> Cell Double
    , _hscaleWithRange :: Double -> Double -> Double -> Text -> Double -> Cell Double
    , _vscaleWithRange :: Double -> Double -> Double -> Text -> Double -> Cell Double
    , _entryAt         :: Text -> Text -> Cell Text
    , _radioButton     :: forall a . Show a => Text -> a -> [a] -> Cell a
    }

-- | Build a `Text`-based user interface
textUI
    :: Text
    -- ^ Window title
    -> Updatable Text
    -- ^ Program logic
    -> IO ()
textUI = ui textSetup processTextEvent
  where
    textSetup :: Gtk.HBox -> IO Gtk.TextBuffer
    textSetup hBox = do
        textView   <- Gtk.textViewNew
        textBuffer <- Gtk.get textView Gtk.textViewBuffer
        Gtk.set textView
            [ Gtk.textViewEditable      := False
            , Gtk.textViewCursorVisible := False
            ]

        hAdjust <- Gtk.textViewGetHadjustment textView
        vAdjust <- Gtk.textViewGetVadjustment textView
        scrolledWindow <- Gtk.scrolledWindowNew (Just hAdjust) (Just vAdjust)
        Gtk.set scrolledWindow
            [ Gtk.containerChild                 := textView
            , Gtk.scrolledWindowShadowType       := Gtk.ShadowIn
            , Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyAutomatic
            , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic
            ]
        Gtk.boxPackStart hBox scrolledWindow Gtk.PackGrow 0
        return textBuffer

    processTextEvent :: Gtk.TextBuffer -> Text -> IO ()
    processTextEvent textBuffer txt =
        Gtk.set textBuffer [ Gtk.textBufferText := txt ]

-- | Build a cell-based user interface
cellUI
    :: Text
    -- ^ Window title
    -> Updatable [(Text, Text)]
    -- ^ Program logic
    -> IO ()
cellUI = ui cellSetup processCellEvent
  where
    cellSetup :: Gtk.HBox -> IO Gtk.VBox
    cellSetup hBox = do
        vbox <- Gtk.vBoxNew False 5
        Gtk.boxPackStart hBox vbox Gtk.PackGrow 0
        return vbox

    processCellEvent :: Gtk.VBox -> [(Text, Text)] -> IO ()
    processCellEvent vbox keyVals = do
        cells <- Gtk.containerGetChildren vbox
        mapM_ (Gtk.containerRemove vbox) cells

        let createCell (key, val) = do
                textView   <- Gtk.textViewNew
                textBuffer <- Gtk.get textView Gtk.textViewBuffer
                Gtk.set textView
                    [ Gtk.textViewEditable      := False
                    , Gtk.textViewCursorVisible := False
                    ]
                Gtk.set textBuffer [ Gtk.textBufferText := val ]
                hAdjust <- Gtk.textViewGetHadjustment textView
                vAdjust <- Gtk.textViewGetVadjustment textView
                scrolledWindow <- do
                    Gtk.scrolledWindowNew (Just hAdjust) (Just vAdjust)
                Gtk.set scrolledWindow
                    [ Gtk.containerChild :=
                        textView
                    , Gtk.scrolledWindowShadowType :=
                        Gtk.ShadowIn
                    , Gtk.scrolledWindowHscrollbarPolicy :=
                        Gtk.PolicyAutomatic
                    , Gtk.scrolledWindowVscrollbarPolicy :=
                        Gtk.PolicyAutomatic
                    ]
                frame <- Gtk.frameNew
                Gtk.set frame
                    [ Gtk.containerChild := scrolledWindow
                    , Gtk.frameLabel     := key
                    ]
                Gtk.boxPackStart vbox frame Gtk.PackNatural 0
        mapM_ createCell keyVals
        Gtk.widgetShowAll vbox

-- | Build a `Diagram`-based user interface
graphicalUI
    :: Text
    -- ^ Window title
    -> Updatable (Diagram Cairo)
    -- ^ Program logic
    -> IO ()
graphicalUI = ui setupGraphical processGraphicalEvent
  where
    setupGraphical :: Gtk.HBox -> IO Gtk.DrawingArea
    setupGraphical hBox = do
        drawingArea <- Gtk.drawingAreaNew
        Gtk.boxPackStart hBox drawingArea Gtk.PackGrow 0
        return drawingArea

    processGraphicalEvent :: Gtk.DrawingArea -> Diagram Cairo -> IO ()
    processGraphicalEvent drawingArea diagram = do
        drawWindow <- Gtk.widgetGetDrawWindow drawingArea
        (w, h) <- Gtk.widgetGetSize drawingArea
        let w' = fromIntegral w / 2
        let h' = fromIntegral h / 2
        let diagram' = diagram # reflectY # translate (r2 (w', h'))
        Diagrams.Backend.Gtk.renderToGtk drawWindow diagram'

-- | Underlying function for building custom user interfaces
ui  :: (Gtk.HBox -> IO resource)
    -- ^ Acquire initial resource
    -> (resource -> event -> IO ())
    -- ^ Callback function to process each event
    -> Text
    -- ^ Window title
    -> Updatable event
    -- ^ Event stream
    -> IO ()
ui setup process title (Updatable k) = do
    _ <- Gtk.initGUI

    window <- Gtk.windowNew
    Gtk.set window
        [ Gtk.containerBorderWidth := 5
        ]

    vBox <- Gtk.vBoxNew False 5

    hBox <- Gtk.hBoxNew False 5
    Gtk.boxPackStart hBox vBox Gtk.PackNatural 0
    a    <- setup hBox

    Gtk.set window
        [ Gtk.windowTitle         := title
        , Gtk.containerChild      := hBox
        , Gtk.windowDefaultWidth  := 600
        , Gtk.windowDefaultHeight := 400
        ]

    let __spinButtonAt :: Double -> Text -> Double -> Cell Double
        __spinButtonAt s0 label stepX = Cell (do
            tmvar      <- STM.newEmptyTMVarIO
            let minX = fromIntegral (minBound :: Int)
            let maxX = fromIntegral (maxBound :: Int)
            spinButton_ <- Gtk.spinButtonNewWithRange minX maxX stepX
            Gtk.set spinButton_
                [ Gtk.spinButtonValue    := s0
                ]
            _  <- Gtk.onValueSpinned spinButton_ (do
                n <- Gtk.get spinButton_ Gtk.spinButtonValue
                STM.atomically (STM.putTMVar tmvar n) )

            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := spinButton_
                , Gtk.frameLabel     := label
                ]

            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll vBox
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __hscaleWithRange :: Double -> Double -> Double -> Text -> Double -> Cell Double
        __hscaleWithRange minY maxY s0 label stepY = Cell (do
            tmvar      <- STM.newEmptyTMVarIO
            slider <- Gtk.hScaleNewWithRange minY maxY stepY
            Gtk.set slider
                [ Gtk.rangeValue    := s0
                ]
            _  <- Gtk.onRangeValueChanged slider (do
                n <- Gtk.get slider Gtk.rangeValue
                STM.atomically (STM.putTMVar tmvar n) )
            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := slider
                , Gtk.frameLabel     := label
                ]
            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll vBox
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __vscaleWithRange :: Double -> Double -> Double -> Text -> Double -> Cell Double
        __vscaleWithRange minY maxY s0 label stepY = Cell (do
            tmvar      <- STM.newEmptyTMVarIO
            slider <- Gtk.vScaleNewWithRange minY maxY stepY
            Gtk.set slider
                [ Gtk.rangeValue    := (-s0)
                ]
            _  <- Gtk.onRangeValueChanged slider (do
                n <- Gtk.get slider Gtk.rangeValue
                STM.atomically (STM.putTMVar tmvar (-n)) )
            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := slider
                , Gtk.frameLabel     := label
                ]
            Gtk.boxPackStart hBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll hBox
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __checkBoxAt :: Bool -> Text -> Cell Bool
        __checkBoxAt s0 label = Cell (do
            checkButton <- Gtk.checkButtonNewWithLabel label

            Gtk.set checkButton [ Gtk.toggleButtonActive := s0 ]
            tmvar <- STM.newEmptyTMVarIO
            _     <- Gtk.on checkButton Gtk.toggled (do
                pressed <- Gtk.get checkButton Gtk.toggleButtonActive
                STM.atomically (STM.putTMVar tmvar pressed) )

            Gtk.boxPackStart vBox checkButton Gtk.PackNatural 0
            Gtk.widgetShowAll vBox
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __entryAt :: Text -> Text -> Cell Text
        __entryAt s0 label = Cell (do
            entry_ <- Gtk.entryNew

            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := entry_
                , Gtk.frameLabel     := label
                ]
            Gtk.set entry_ [ Gtk.entryText := s0 ]

            tmvar <- STM.newEmptyTMVarIO
            _     <- Gtk.on entry_ Gtk.editableChanged (do
                txt <- Gtk.get entry_ Gtk.entryText
                STM.atomically (STM.putTMVar tmvar txt) )

            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll frame
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __radioButton :: Show a => Text -> a -> [a] -> Cell a
        __radioButton label x xs = Cell (do
            tmvar <- STM.newEmptyTMVarIO

            vBoxRadio <- Gtk.vBoxNew False 5

            let makeButton f y = do
                    button <- f (show y)
                    Gtk.boxPackStart vBoxRadio button Gtk.PackNatural 0
                    _ <- Gtk.on button Gtk.toggled (do
                        active <- Gtk.get button Gtk.toggleButtonActive
                        if active
                            then STM.atomically (STM.putTMVar tmvar y)
                            else return () )
                    return button

            button <- makeButton Gtk.radioButtonNewWithLabel x
            mapM_ (makeButton (Gtk.radioButtonNewWithLabelFromWidget button)) xs

            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := vBoxRadio
                , Gtk.frameLabel     := label
                ]
            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll frame
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef x) )

    let control = Control
            { _checkBoxAt      = __checkBoxAt
            , _spinButtonAt    = __spinButtonAt
            , _hscaleWithRange = __hscaleWithRange
            , _vscaleWithRange = __vscaleWithRange
            , _entryAt         = __entryAt
            , _radioButton     = __radioButton
            }

    doneTMVar <- STM.newEmptyTMVarIO

    let run (Cell m) = do
            (stm, Fold step begin done) <- Gtk.postGUISync m
            -- I don't know why this delay is necessary for diagrams output
            Control.Concurrent.threadDelay 200000
            let loop x = do
                    let b = done x
                    Gtk.postGUISync (process a b)
                    let doneTransaction = do
                            STM.takeTMVar doneTMVar
                            return Nothing
                    me <- STM.atomically (doneTransaction <|> fmap pure stm)
                    case me of
                        Nothing -> return ()
                        Just e  -> loop (step x e)
            loop begin

    _ <- Gtk.on window Gtk.deleteEvent (liftIO (do
        STM.atomically (STM.putTMVar doneTMVar ())
        Gtk.mainQuit
        return False ))
    Gtk.widgetShowAll window
    Control.Concurrent.Async.withAsync (run (k control)) (\s -> do
        Gtk.mainGUI
        Control.Concurrent.Async.wait s )

-- | A check box that returns `True` if selected and `False` if unselected
checkBox
    :: Text
    -- ^ Label
    -> Updatable Bool
checkBox = checkBoxAt False

-- | A `Double` spin button
spinButton
    :: Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
spinButton = spinButtonAt 0

-- | A `Double` horizontal slider
hscale
    :: Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
hscale = hscaleAt 0

-- | A `Double` vertical slider
vscale
    :: Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
vscale = vscaleAt 0

-- | A `Text` entry
entry
    :: Text
    -- ^ Label
    -> Updatable Text
entry = entryAt Data.Text.empty

  | A control that selects from one or more mutually exclusive choices
radioButton
    :: Show a
    => Text
    -- ^ Label
    -> a
  ^ 1st choice ( Default selection )
    -> [a]
    -- ^ Remaining choices
    -> Updatable a
radioButton label a0 as =
    Updatable (\control -> _radioButton control label a0 as)

-- | Same as `checkBox` except that you can specify the initial state
checkBoxAt
    :: Bool
    -- ^ Initial state 
    -> Text
    -- ^ Label
    -> Updatable Bool
checkBoxAt s0 label =
    Updatable (\control -> _checkBoxAt control s0 label)

  | Same as ` spinButton ` except that you can specify the initial state
spinButtonAt
    :: Double
    -- ^ Initial state
    -> Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
spinButtonAt s0 label x =
    Updatable (\control -> _spinButtonAt control s0 label x)

-- | Same as `hscaleButton` except that you can specify the initial state
hscaleAt
    :: Double
    -- ^ Initial state
    -> Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
hscaleAt = hscaleWithRange (fromIntegral (minBound :: Int)) (fromIntegral (maxBound :: Int))

-- | Same as `hscaleButton` except that you can specify the range and initial state
hscaleWithRange
    :: Double
    -- ^ Minimum value
    -> Double
    -- ^ Maximum value
    -> Double
    -- ^ Initial state
    -> Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
hscaleWithRange b0 b1 s0 label x =
    Updatable (\control -> _hscaleWithRange control b0 b1 s0 label x)

-- | Same as `vscaleButton` except that you can specify the initial state
vscaleAt
    :: Double
    -- ^ Initial state
    -> Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
vscaleAt = vscaleWithRange (fromIntegral (minBound :: Int)) (fromIntegral (maxBound :: Int))

-- | Same as `vscaleButton` except that you can specify the range and initial state
vscaleWithRange
    :: Double
    -- ^ Minimum value
    -> Double
    -- ^ Maximum value
    -> Double
    -- ^ Initial state
    -> Text
    -- ^ Label
    -> Double
    -- ^ Step size
    -> Updatable Double
vscaleWithRange b0 b1 s0 label x =
    Updatable (\control -> _vscaleWithRange control b0 b1 s0 label x)

-- | Same as `entry` except that you can specify the initial state
entryAt
    :: Text
    -- ^ Initial state
    -> Text
    -- ^ Label
    -> Updatable Text
entryAt s0 label = Updatable (\control -> _entryAt control s0 label)

-- | Convert a `Show`able value to `Text`
display :: Show a => a -> Text
display = Data.Text.pack . show

-- $examples
--
-- Mortgage calculator:
--
-- > {-# LANGUAGE ApplicativeDo     #-}
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Typed.Spreadsheet
-- > 
-- > main :: IO ()
-- > main = textUI "Mortgage payment" $ do
  >    mortgageAmount      < - spinButton " Mortgage Amount "           1000
  >    numberOfYears       < - spinButton " Number of years "              1
  >    yearlyInterestRate < - spinButton " Yearly interest rate ( % ) "     0.01
  >    let n = truncate ( numberOfYears * 12 )
-- >   let i = yearlyInterestRate / 12 / 100
  >    return ( " Monthly payment : $ " < > display ( mortgageAmount * ( i * ( 1 + i ) ^ n ) / ( ( 1 + i ) ^ n - 1 ) ) )
--
-- Example input and output:
--
  < <  Mortgage calculator program > >
--
  Mad libs :
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Typed.Spreadsheet
-- > 
  > noun = entry " Noun "
-- > 
-- > verb = entry "Verb"
-- > 
-- > adjective = entry "Adjective"
-- > 
-- > example =
-- >     "I want to " <> verb <> " every " <> noun <> " because they are so " <> adjective
-- > 
-- > main :: IO ()
-- > main = textUI "Mad libs" example
--
  The above program works because the ` Updatable ` type implements ` IsString `
-- and `Monoid`, so no `Applicative` operations are necessary
--
-- Example input and output:
--
  < <  Mad libs program > >
--
  Sinusoid plot :
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Diagrams.Prelude
-- > import Typed.Spreadsheet
-- > 
-- > main :: IO ()
-- > main = graphicalUI "Example program" $ do
  >      amplitude < - spinButtonAt 50   " Amplitude ( Pixels ) "    0.1
  >      frequency < - spinButtonAt 0.1 " Frequency ( Pixels⁻¹ ) " 0.001
  >      phase      < - spinButtonAt 90   " Phase ( Degrees ) "       1
-- > 
  >      let axes = arrowBetween ( p2 ( 0 , 0 ) ) ( p2 ( 100 ,     0 ) )
  >              < >  ( p2 ( 0 , 0 ) ) ( p2 ( -100 ,     0 ) )
  >              < >  ( p2 ( 0 , 0 ) ) ( p2 (    0 ,   100 ) )
  >              < >  ( p2 ( 0 , 0 ) ) ( p2 (    0 , -100 ) )
-- > 
-- >     let f x = amplitude * cos (frequency * x + phase * pi / 180)
-- > 
  >      let points = map ( \x - > p2 ( x , f x ) ) [ -100 , -99 .. 100 ]
-- > 
-- >     return (strokeP (fromVertices points) <> axes)
--
-- Example input and output:
--
  < <   plot > >
--
-- Factor diagram:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Diagrams.Prelude
-- > import Diagrams.TwoD.Factorization (factorDiagram')
-- > import Typed.Spreadsheet
-- > 
-- > main :: IO ()
-- > main = graphicalUI "Factor diagram" $ do
  >      x < - spinButtonAt 3 " Factor # 1 " 1
  >      y < - spinButtonAt 3 " Factor # 2 " 1
  >      z < - spinButtonAt 3 " Factor # 3 " 1
  >      return ( factorDiagram ' [ truncate x , truncate y , truncate z ] # scale 10 )
--
-- Example input and output:
--
-- << Factor diagram>>

# LANGUAGE RankNTypes                 #
 | The following program:

 > {-# LANGUAGE ApplicativeDo     #-}
 > {-# LANGUAGE OverloadedStrings #-}
 > 
 > import Typed.Spreadsheet
 > 
 > main :: IO ()
 > main = textUI "Example program" $ do
 >     a <- checkBox   "a"
 >     d <- entry      "d"
 >     return (display (a, b + c, d))

 ... creates a user interface that looks like this:

 << User interface on startup>>

 Every time you update a control on the left panel, the right panel updates
 in response:

 << User interface after user input>>

 This library also supports graphical output, like in the following program:

 > {-# LANGUAGE ApplicativeDo     #-}
 > {-# LANGUAGE OverloadedStrings #-}
 > 
 > import Diagrams.Prelude
 > import Typed.Spreadsheet
 > 
 > 
 > toColor :: AColor -> Colour Double
 > toColor Red    = red
 > toColor Orange = orange
 > toColor Yellow = yellow
 > toColor Green  = green
 > toColor Blue   = blue
 > toColor Purple = purple
 > 
 > main :: IO ()
 > main = graphicalUI "Example program" $ do
 >     return (circle r # fc (toColor color) # translate (r2 (x, y)))

 This produces a canvas that colors, resizes, and moves a circle in response
 to user input:

 << Graphical user interface>>

 The general workflow for this library is:

   `entry`, or `radioButton`, each of which corresponds to a control on the
   left panel of the user interface
 * You consume an @(`Updatable` `Text`)@ value using `textUI`, which displays
   the continuously updating value in the right panel of the user interface

 You can get started quickly by cloning and building this project:

 > $ stack build --install-ghc             # Builds the executable
 > $ stack exec typed-spreadsheet-example  # Runs the executable

 ... or if you are using OS X, then build the project using:

stack - yaml = osx.yaml build --install - ghc

 subdirectory.  Just modify that file and rebuild to play with the example.

 NOTE: You must compile your program with the @-threaded@ flag.  The example
 project takes care of this.

 See the \"Examples\" section at the bottom of this module for more examples.
 * Types
 * Controls
 * Controls with Defaults
 * Utilities
 * Examples
 $examples
 | An updatable input value
 | Use a `Control` to obtain updatable input `Updatable`s
 | Build a `Text`-based user interface
 ^ Window title
 ^ Program logic
 | Build a cell-based user interface
 ^ Window title
 ^ Program logic
 | Build a `Diagram`-based user interface
 ^ Window title
 ^ Program logic
 | Underlying function for building custom user interfaces
 ^ Acquire initial resource
 ^ Callback function to process each event
 ^ Window title
 ^ Event stream
 I don't know why this delay is necessary for diagrams output
 | A check box that returns `True` if selected and `False` if unselected
 ^ Label
 | A `Double` spin button
 ^ Label
 ^ Step size
 | A `Double` horizontal slider
 ^ Label
 ^ Step size
 | A `Double` vertical slider
 ^ Label
 ^ Step size
 | A `Text` entry
 ^ Label
 ^ Label
 ^ Remaining choices
 | Same as `checkBox` except that you can specify the initial state
 ^ Initial state 
 ^ Label
 ^ Initial state
 ^ Label
 ^ Step size
 | Same as `hscaleButton` except that you can specify the initial state
 ^ Initial state
 ^ Label
 ^ Step size
 | Same as `hscaleButton` except that you can specify the range and initial state
 ^ Minimum value
 ^ Maximum value
 ^ Initial state
 ^ Label
 ^ Step size
 | Same as `vscaleButton` except that you can specify the initial state
 ^ Initial state
 ^ Label
 ^ Step size
 | Same as `vscaleButton` except that you can specify the range and initial state
 ^ Minimum value
 ^ Maximum value
 ^ Initial state
 ^ Label
 ^ Step size
 | Same as `entry` except that you can specify the initial state
 ^ Initial state
 ^ Label
 | Convert a `Show`able value to `Text`
 $examples

 Mortgage calculator:

 > {-# LANGUAGE ApplicativeDo     #-}
 > {-# LANGUAGE OverloadedStrings #-}
 > 
 > import Typed.Spreadsheet
 > 
 > main :: IO ()
 > main = textUI "Mortgage payment" $ do
 >   let i = yearlyInterestRate / 12 / 100

 Example input and output:



 > {-# LANGUAGE OverloadedStrings #-}
 > 
 > import Typed.Spreadsheet
 > 
 > 
 > verb = entry "Verb"
 > 
 > adjective = entry "Adjective"
 > 
 > example =
 >     "I want to " <> verb <> " every " <> noun <> " because they are so " <> adjective
 > 
 > main :: IO ()
 > main = textUI "Mad libs" example

 and `Monoid`, so no `Applicative` operations are necessary

 Example input and output:



 > {-# LANGUAGE OverloadedStrings #-}
 > 
 > import Diagrams.Prelude
 > import Typed.Spreadsheet
 > 
 > main :: IO ()
 > main = graphicalUI "Example program" $ do
 > 
 > 
 >     let f x = amplitude * cos (frequency * x + phase * pi / 180)
 > 
 > 
 >     return (strokeP (fromVertices points) <> axes)

 Example input and output:


 Factor diagram:

 > {-# LANGUAGE OverloadedStrings #-}
 > 
 > import Diagrams.Prelude
 > import Diagrams.TwoD.Factorization (factorDiagram')
 > import Typed.Spreadsheet
 > 
 > main :: IO ()
 > main = graphicalUI "Factor diagram" $ do

 Example input and output:

 << Factor diagram>>
# LANGUAGE ExistentialQuantification   #
# LANGUAGE ApplicativeDo               #
# LANGUAGE CPP               #

  >      b < - spinButton " b " 1
  >      c < - spinButton " c " 0.1
  > data AColor = Red | Orange | Yellow | Green | Blue | Purple
  >      deriving ( Enum , Bounded , Show )
  >      color < - radioButton       " Color "         Red [ Orange .. Purple ]
  >      r      < - spinButtonAt 100 " Radius "        1
  >      x                " X Coordinate " 1
  >      y                " Y Coordinate " 1
  * You build primitive ` Updatable ` values using ` checkBox ` , ` spinButton ` ,
  * Combine ` Updatable ` values using @ApplicativeDo@ notation .   Composite values
    update whenever one of their substituent values update
  > $ git clone -Typed-Spreadsheet-Library.git
  That project includes the code for the above examples in the @exec/@

module Typed.Spreadsheet (
      Updatable
    , textUI
    , cellUI
    , graphicalUI
    , ui

    , checkBox
    , spinButton
    , entry
    , radioButton

    , checkBoxAt
    , spinButtonAt
    , hscale
    , hscaleAt
    , hscaleWithRange
    , vscale
    , vscaleAt
    , vscaleWithRange
    , entryAt

    , display

    ) where

import Control.Applicative
import Control.Concurrent.STM (STM)
import Control.Foldl (Fold(..))
import Control.Monad.IO.Class (liftIO)
import Data.String (IsString(..))
import Data.Text (Text)
import Diagrams.Backend.Cairo (Cairo)
import Diagrams.Prelude (Diagram, r2, reflectY, translate, (#))
import Lens.Micro (_Left, _Right)
import Graphics.UI.Gtk (AttrOp((:=)))

import qualified Control.Concurrent
import qualified Control.Concurrent.STM   as STM
import qualified Control.Concurrent.Async
import qualified Control.Foldl
import qualified Data.Text
import qualified Diagrams.Backend.Gtk
import qualified Graphics.UI.Gtk          as Gtk

data Cell a = forall e . Cell (IO (STM e, Fold e a))

instance Functor Cell where
    fmap f (Cell m) = Cell (fmap (fmap (fmap f)) m)

instance Applicative Cell where
    pure a = Cell (pure (empty, pure a))

    Cell mF <*> Cell mX = Cell (liftA2 helper mF mX)
      where
        helper (inputF, foldF) (inputX, foldX) = (input, fold )
          where
            input = fmap Left inputF <|> fmap Right inputX

            fold  = do
                f <- Control.Foldl.handles _Left foldF
                x <- Control.Foldl.handles _Right foldX
                return (f x)

data Updatable a = Updatable (Control -> Cell a)

instance Functor Updatable where
    fmap f (Updatable m) = Updatable (fmap (fmap f) m)

instance Applicative Updatable where
    pure a = Updatable (pure (pure a))

    Updatable mf <*> Updatable mx = Updatable (liftA2 (<*>) mf mx)

#if MIN_VERSION_base(4,11,0)
instance Semigroup a => Semigroup (Updatable a) where
    (<>) = liftA2 (<>)

instance Monoid a => Monoid (Updatable a) where
    mempty = pure mempty

#else
instance Monoid a => Monoid (Updatable a) where
    mempty = pure mempty

    mappend = liftA2 mappend
#endif


instance IsString a => IsString (Updatable a) where
    fromString str = pure (fromString str)

instance Num a => Num (Updatable a) where
    fromInteger = pure . fromInteger

    negate = fmap negate
    abs    = fmap abs
    signum = fmap signum

    (+) = liftA2 (+)
    (*) = liftA2 (*)
    (-) = liftA2 (-)

instance Fractional a => Fractional (Updatable a) where
    fromRational = pure . fromRational

    recip = fmap recip

    (/) = liftA2 (/)

instance Floating a => Floating (Updatable a) where
    pi = pure pi

    exp   = fmap exp
    sqrt  = fmap sqrt
    log   = fmap log
    sin   = fmap sin
    tan   = fmap tan
    cos   = fmap cos
    asin  = fmap sin
    atan  = fmap atan
    acos  = fmap acos
    sinh  = fmap sinh
    tanh  = fmap tanh
    cosh  = fmap cosh
    asinh = fmap asinh
    atanh = fmap atanh
    acosh = fmap acosh

    (**)    = liftA2 (**)
    logBase = liftA2 logBase

data Control = Control
    { _checkBoxAt      :: Bool -> Text -> Cell Bool
    , _spinButtonAt    :: Double -> Text -> Double -> Cell Double
    , _hscaleWithRange :: Double -> Double -> Double -> Text -> Double -> Cell Double
    , _vscaleWithRange :: Double -> Double -> Double -> Text -> Double -> Cell Double
    , _entryAt         :: Text -> Text -> Cell Text
    , _radioButton     :: forall a . Show a => Text -> a -> [a] -> Cell a
    }

textUI
    :: Text
    -> Updatable Text
    -> IO ()
textUI = ui textSetup processTextEvent
  where
    textSetup :: Gtk.HBox -> IO Gtk.TextBuffer
    textSetup hBox = do
        textView   <- Gtk.textViewNew
        textBuffer <- Gtk.get textView Gtk.textViewBuffer
        Gtk.set textView
            [ Gtk.textViewEditable      := False
            , Gtk.textViewCursorVisible := False
            ]

        hAdjust <- Gtk.textViewGetHadjustment textView
        vAdjust <- Gtk.textViewGetVadjustment textView
        scrolledWindow <- Gtk.scrolledWindowNew (Just hAdjust) (Just vAdjust)
        Gtk.set scrolledWindow
            [ Gtk.containerChild                 := textView
            , Gtk.scrolledWindowShadowType       := Gtk.ShadowIn
            , Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyAutomatic
            , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic
            ]
        Gtk.boxPackStart hBox scrolledWindow Gtk.PackGrow 0
        return textBuffer

    processTextEvent :: Gtk.TextBuffer -> Text -> IO ()
    processTextEvent textBuffer txt =
        Gtk.set textBuffer [ Gtk.textBufferText := txt ]

cellUI
    :: Text
    -> Updatable [(Text, Text)]
    -> IO ()
cellUI = ui cellSetup processCellEvent
  where
    cellSetup :: Gtk.HBox -> IO Gtk.VBox
    cellSetup hBox = do
        vbox <- Gtk.vBoxNew False 5
        Gtk.boxPackStart hBox vbox Gtk.PackGrow 0
        return vbox

    processCellEvent :: Gtk.VBox -> [(Text, Text)] -> IO ()
    processCellEvent vbox keyVals = do
        cells <- Gtk.containerGetChildren vbox
        mapM_ (Gtk.containerRemove vbox) cells

        let createCell (key, val) = do
                textView   <- Gtk.textViewNew
                textBuffer <- Gtk.get textView Gtk.textViewBuffer
                Gtk.set textView
                    [ Gtk.textViewEditable      := False
                    , Gtk.textViewCursorVisible := False
                    ]
                Gtk.set textBuffer [ Gtk.textBufferText := val ]
                hAdjust <- Gtk.textViewGetHadjustment textView
                vAdjust <- Gtk.textViewGetVadjustment textView
                scrolledWindow <- do
                    Gtk.scrolledWindowNew (Just hAdjust) (Just vAdjust)
                Gtk.set scrolledWindow
                    [ Gtk.containerChild :=
                        textView
                    , Gtk.scrolledWindowShadowType :=
                        Gtk.ShadowIn
                    , Gtk.scrolledWindowHscrollbarPolicy :=
                        Gtk.PolicyAutomatic
                    , Gtk.scrolledWindowVscrollbarPolicy :=
                        Gtk.PolicyAutomatic
                    ]
                frame <- Gtk.frameNew
                Gtk.set frame
                    [ Gtk.containerChild := scrolledWindow
                    , Gtk.frameLabel     := key
                    ]
                Gtk.boxPackStart vbox frame Gtk.PackNatural 0
        mapM_ createCell keyVals
        Gtk.widgetShowAll vbox

graphicalUI
    :: Text
    -> Updatable (Diagram Cairo)
    -> IO ()
graphicalUI = ui setupGraphical processGraphicalEvent
  where
    setupGraphical :: Gtk.HBox -> IO Gtk.DrawingArea
    setupGraphical hBox = do
        drawingArea <- Gtk.drawingAreaNew
        Gtk.boxPackStart hBox drawingArea Gtk.PackGrow 0
        return drawingArea

    processGraphicalEvent :: Gtk.DrawingArea -> Diagram Cairo -> IO ()
    processGraphicalEvent drawingArea diagram = do
        drawWindow <- Gtk.widgetGetDrawWindow drawingArea
        (w, h) <- Gtk.widgetGetSize drawingArea
        let w' = fromIntegral w / 2
        let h' = fromIntegral h / 2
        let diagram' = diagram # reflectY # translate (r2 (w', h'))
        Diagrams.Backend.Gtk.renderToGtk drawWindow diagram'

ui  :: (Gtk.HBox -> IO resource)
    -> (resource -> event -> IO ())
    -> Text
    -> Updatable event
    -> IO ()
ui setup process title (Updatable k) = do
    _ <- Gtk.initGUI

    window <- Gtk.windowNew
    Gtk.set window
        [ Gtk.containerBorderWidth := 5
        ]

    vBox <- Gtk.vBoxNew False 5

    hBox <- Gtk.hBoxNew False 5
    Gtk.boxPackStart hBox vBox Gtk.PackNatural 0
    a    <- setup hBox

    Gtk.set window
        [ Gtk.windowTitle         := title
        , Gtk.containerChild      := hBox
        , Gtk.windowDefaultWidth  := 600
        , Gtk.windowDefaultHeight := 400
        ]

    let __spinButtonAt :: Double -> Text -> Double -> Cell Double
        __spinButtonAt s0 label stepX = Cell (do
            tmvar      <- STM.newEmptyTMVarIO
            let minX = fromIntegral (minBound :: Int)
            let maxX = fromIntegral (maxBound :: Int)
            spinButton_ <- Gtk.spinButtonNewWithRange minX maxX stepX
            Gtk.set spinButton_
                [ Gtk.spinButtonValue    := s0
                ]
            _  <- Gtk.onValueSpinned spinButton_ (do
                n <- Gtk.get spinButton_ Gtk.spinButtonValue
                STM.atomically (STM.putTMVar tmvar n) )

            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := spinButton_
                , Gtk.frameLabel     := label
                ]

            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll vBox
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __hscaleWithRange :: Double -> Double -> Double -> Text -> Double -> Cell Double
        __hscaleWithRange minY maxY s0 label stepY = Cell (do
            tmvar      <- STM.newEmptyTMVarIO
            slider <- Gtk.hScaleNewWithRange minY maxY stepY
            Gtk.set slider
                [ Gtk.rangeValue    := s0
                ]
            _  <- Gtk.onRangeValueChanged slider (do
                n <- Gtk.get slider Gtk.rangeValue
                STM.atomically (STM.putTMVar tmvar n) )
            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := slider
                , Gtk.frameLabel     := label
                ]
            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll vBox
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __vscaleWithRange :: Double -> Double -> Double -> Text -> Double -> Cell Double
        __vscaleWithRange minY maxY s0 label stepY = Cell (do
            tmvar      <- STM.newEmptyTMVarIO
            slider <- Gtk.vScaleNewWithRange minY maxY stepY
            Gtk.set slider
                [ Gtk.rangeValue    := (-s0)
                ]
            _  <- Gtk.onRangeValueChanged slider (do
                n <- Gtk.get slider Gtk.rangeValue
                STM.atomically (STM.putTMVar tmvar (-n)) )
            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := slider
                , Gtk.frameLabel     := label
                ]
            Gtk.boxPackStart hBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll hBox
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __checkBoxAt :: Bool -> Text -> Cell Bool
        __checkBoxAt s0 label = Cell (do
            checkButton <- Gtk.checkButtonNewWithLabel label

            Gtk.set checkButton [ Gtk.toggleButtonActive := s0 ]
            tmvar <- STM.newEmptyTMVarIO
            _     <- Gtk.on checkButton Gtk.toggled (do
                pressed <- Gtk.get checkButton Gtk.toggleButtonActive
                STM.atomically (STM.putTMVar tmvar pressed) )

            Gtk.boxPackStart vBox checkButton Gtk.PackNatural 0
            Gtk.widgetShowAll vBox
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __entryAt :: Text -> Text -> Cell Text
        __entryAt s0 label = Cell (do
            entry_ <- Gtk.entryNew

            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := entry_
                , Gtk.frameLabel     := label
                ]
            Gtk.set entry_ [ Gtk.entryText := s0 ]

            tmvar <- STM.newEmptyTMVarIO
            _     <- Gtk.on entry_ Gtk.editableChanged (do
                txt <- Gtk.get entry_ Gtk.entryText
                STM.atomically (STM.putTMVar tmvar txt) )

            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll frame
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef s0) )

    let __radioButton :: Show a => Text -> a -> [a] -> Cell a
        __radioButton label x xs = Cell (do
            tmvar <- STM.newEmptyTMVarIO

            vBoxRadio <- Gtk.vBoxNew False 5

            let makeButton f y = do
                    button <- f (show y)
                    Gtk.boxPackStart vBoxRadio button Gtk.PackNatural 0
                    _ <- Gtk.on button Gtk.toggled (do
                        active <- Gtk.get button Gtk.toggleButtonActive
                        if active
                            then STM.atomically (STM.putTMVar tmvar y)
                            else return () )
                    return button

            button <- makeButton Gtk.radioButtonNewWithLabel x
            mapM_ (makeButton (Gtk.radioButtonNewWithLabelFromWidget button)) xs

            frame <- Gtk.frameNew
            Gtk.set frame
                [ Gtk.containerChild := vBoxRadio
                , Gtk.frameLabel     := label
                ]
            Gtk.boxPackStart vBox frame Gtk.PackNatural 0
            Gtk.widgetShowAll frame
            return (STM.takeTMVar tmvar, Control.Foldl.lastDef x) )

    let control = Control
            { _checkBoxAt      = __checkBoxAt
            , _spinButtonAt    = __spinButtonAt
            , _hscaleWithRange = __hscaleWithRange
            , _vscaleWithRange = __vscaleWithRange
            , _entryAt         = __entryAt
            , _radioButton     = __radioButton
            }

    doneTMVar <- STM.newEmptyTMVarIO

    let run (Cell m) = do
            (stm, Fold step begin done) <- Gtk.postGUISync m
            Control.Concurrent.threadDelay 200000
            let loop x = do
                    let b = done x
                    Gtk.postGUISync (process a b)
                    let doneTransaction = do
                            STM.takeTMVar doneTMVar
                            return Nothing
                    me <- STM.atomically (doneTransaction <|> fmap pure stm)
                    case me of
                        Nothing -> return ()
                        Just e  -> loop (step x e)
            loop begin

    _ <- Gtk.on window Gtk.deleteEvent (liftIO (do
        STM.atomically (STM.putTMVar doneTMVar ())
        Gtk.mainQuit
        return False ))
    Gtk.widgetShowAll window
    Control.Concurrent.Async.withAsync (run (k control)) (\s -> do
        Gtk.mainGUI
        Control.Concurrent.Async.wait s )

checkBox
    :: Text
    -> Updatable Bool
checkBox = checkBoxAt False

spinButton
    :: Text
    -> Double
    -> Updatable Double
spinButton = spinButtonAt 0

hscale
    :: Text
    -> Double
    -> Updatable Double
hscale = hscaleAt 0

vscale
    :: Text
    -> Double
    -> Updatable Double
vscale = vscaleAt 0

entry
    :: Text
    -> Updatable Text
entry = entryAt Data.Text.empty

  | A control that selects from one or more mutually exclusive choices
radioButton
    :: Show a
    => Text
    -> a
  ^ 1st choice ( Default selection )
    -> [a]
    -> Updatable a
radioButton label a0 as =
    Updatable (\control -> _radioButton control label a0 as)

checkBoxAt
    :: Bool
    -> Text
    -> Updatable Bool
checkBoxAt s0 label =
    Updatable (\control -> _checkBoxAt control s0 label)

  | Same as ` spinButton ` except that you can specify the initial state
spinButtonAt
    :: Double
    -> Text
    -> Double
    -> Updatable Double
spinButtonAt s0 label x =
    Updatable (\control -> _spinButtonAt control s0 label x)

hscaleAt
    :: Double
    -> Text
    -> Double
    -> Updatable Double
hscaleAt = hscaleWithRange (fromIntegral (minBound :: Int)) (fromIntegral (maxBound :: Int))

hscaleWithRange
    :: Double
    -> Double
    -> Double
    -> Text
    -> Double
    -> Updatable Double
hscaleWithRange b0 b1 s0 label x =
    Updatable (\control -> _hscaleWithRange control b0 b1 s0 label x)

vscaleAt
    :: Double
    -> Text
    -> Double
    -> Updatable Double
vscaleAt = vscaleWithRange (fromIntegral (minBound :: Int)) (fromIntegral (maxBound :: Int))

vscaleWithRange
    :: Double
    -> Double
    -> Double
    -> Text
    -> Double
    -> Updatable Double
vscaleWithRange b0 b1 s0 label x =
    Updatable (\control -> _vscaleWithRange control b0 b1 s0 label x)

entryAt
    :: Text
    -> Text
    -> Updatable Text
entryAt s0 label = Updatable (\control -> _entryAt control s0 label)

display :: Show a => a -> Text
display = Data.Text.pack . show

  >    mortgageAmount      < - spinButton " Mortgage Amount "           1000
  >    numberOfYears       < - spinButton " Number of years "              1
  >    yearlyInterestRate < - spinButton " Yearly interest rate ( % ) "     0.01
  >    let n = truncate ( numberOfYears * 12 )
  >    return ( " Monthly payment : $ " < > display ( mortgageAmount * ( i * ( 1 + i ) ^ n ) / ( ( 1 + i ) ^ n - 1 ) ) )
  < <  Mortgage calculator program > >
  Mad libs :
  > noun = entry " Noun "
  The above program works because the ` Updatable ` type implements ` IsString `
  < <  Mad libs program > >
  Sinusoid plot :
  >      amplitude < - spinButtonAt 50   " Amplitude ( Pixels ) "    0.1
  >      frequency < - spinButtonAt 0.1 " Frequency ( Pixels⁻¹ ) " 0.001
  >      phase      < - spinButtonAt 90   " Phase ( Degrees ) "       1
  >      let axes = arrowBetween ( p2 ( 0 , 0 ) ) ( p2 ( 100 ,     0 ) )
  >              < >  ( p2 ( 0 , 0 ) ) ( p2 ( -100 ,     0 ) )
  >              < >  ( p2 ( 0 , 0 ) ) ( p2 (    0 ,   100 ) )
  >              < >  ( p2 ( 0 , 0 ) ) ( p2 (    0 , -100 ) )
  >      let points = map ( \x - > p2 ( x , f x ) ) [ -100 , -99 .. 100 ]
  < <   plot > >
  >      x < - spinButtonAt 3 " Factor # 1 " 1
  >      y < - spinButtonAt 3 " Factor # 2 " 1
  >      z < - spinButtonAt 3 " Factor # 3 " 1
  >      return ( factorDiagram ' [ truncate x , truncate y , truncate z ] # scale 10 )
