{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
-- | The following program:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > import Control.Applicative
-- > import Typed.Spreadsheet
-- >
-- > main :: IO ()
-- > main = textUI "Example program" logic
-- > where
-- > logic = combine <$> checkBox "a"
-- > <*> spinButton "b" 1
-- > <*> spinButton "c" 0.1
-- > <*> entry "d"
-- >
-- > combine a b c d = display (a, b + c, d)
--
-- ... creates a user interface that looks like this:
--
-- <<http://i.imgur.com/xPifEtA.png User interface on startup>>
--
-- Every time you update a control on the left panel, the right panel updates
-- in response:
--
-- <<http://i.imgur.com/TTxgSwN.png User interface after user input>>
--
-- Once @ghc-8.0@ is out then you can simplify the above program even further
-- using the `ApplicativeDo` extension:
--
-- > {-# 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)) )
--
-- This library also supports graphical output, like in the following program:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > import Diagrams.Backend.Cairo (Cairo)
-- > 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" logic
-- > where
-- > logic = combine <$> radioButton "Color" Red [Orange .. Purple]
-- > <*> spinButtonAt 100 "Radius" 1
-- > <*> spinButton "X Coordinate" 1
-- > <*> spinButton "Y Coordinate" 1
-- >
-- > combine :: AColor -> Double -> Double -> Double -> Diagram Cairo
-- > combine color r x y =
-- > 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:
--
-- <<http://i.imgur.com/ddYoG46.png 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
-- * You transform or combine `Updatable` values using `Functor` and
-- `Applicative` operations. 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 https://github.com/Gabriel439/Haskell-Typed-Spreadsheet-Library.git
-- > $ stack build --install-ghc # Builds the executable
-- > $ stack exec typed-spreadsheet-example # Runs the executable
--
-- That project includes the code for the above example in @exec/Main.hs@. 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
, graphicalUI
-- * Controls
, checkBox
, spinButton
, entry
, radioButton
-- * Controls with Defaults
, checkBoxAt
, spinButtonAt
, entryAt
-- * Utilities
, display
-- * Examples
-- $examples
) where
import Control.Applicative
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (STM)
import Control.Foldl (Fold(..))
import Control.Monad.IO.Class (liftIO)
import Data.Monoid
import Data.String (IsString(..))
import Data.Text (Text)
import Diagrams.Backend.Cairo (Cairo)
import Diagrams.Backend.Gtk (renderToGtk)
import Diagrams.Prelude (Diagram, r2, translate, (#))
import Lens.Micro (_Left, _Right)
import Graphics.UI.Gtk (AttrOp((:=)))
import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.Async as Async
import qualified Control.Foldl as Fold
import qualified Data.Text as Text
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 = Fold.handles _Left foldF <*> Fold.handles _Right foldX
-- | 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)
instance Monoid a => Monoid (Updatable a) where
mempty = pure mempty
mappend = liftA2 mappend
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
, _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.boxPackStart hBox scrolledWindow Gtk.PackGrow 0
return textBuffer
processTextEvent :: Gtk.TextBuffer -> Text -> IO ()
processTextEvent textBuffer txt =
Gtk.set textBuffer [ Gtk.textBufferText := txt ]
-- | 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
renderToGtk drawWindow (diagram # translate (r2 (w', h')))
-- | Shared logic for `textUI` and `graphicalUI`
ui :: (Gtk.HBox -> IO a)
-> (a -> b -> IO ())
-> Text
-> Updatable b
-> 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, Fold.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, Fold.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, Fold.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 a = do
button <- f (show a)
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 a)
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, Fold.lastDef x) )
let control = Control
{ _checkBoxAt = __checkBoxAt
, _spinButtonAt = __spinButtonAt
, _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
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
Async.withAsync (run (k control)) (\a -> do
Gtk.mainGUI
Async.wait a )
-- | 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 `Text` entry
entry
:: Text
-- ^ Label
-> Updatable Text
entry = entryAt 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 `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 = Text.pack . show
-- $examples
--
-- Mortgage calculator:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > import Control.Applicative
-- > import Data.Monoid
-- > import Data.Text (Text)
-- > import Typed.Spreadsheet
-- >
-- > payment :: Double -> Double -> Double -> Text
-- > payment mortgageAmount numberOfYears yearlyInterestRate
-- > = "Monthly payment: $"
-- > <> display (mortgageAmount * (i * (1 + i) ^ n) / ((1 + i) ^ n - 1))
-- > where
-- > n = truncate (numberOfYears * 12)
-- > i = yearlyInterestRate / 12 / 100
-- >
-- > logic :: Updatable Text
-- > logic = payment <$> spinButton "Mortgage Amount" 1000
-- > <*> spinButton "Number of years" 1
-- > <*> spinButton "Yearly interest rate (%)" 0.01
-- >
-- > main :: IO ()
-- > main = textUI "Mortgage payment" logic
--
-- Example input and output:
--
-- <<http://i.imgur.com/nvRZ9HC.png Mortgage calculator program>>
--
-- Mad libs:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > import Data.Monoid
-- > 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:
--
-- <<http://i.imgur.com/k22An4Y.png Mad libs program>>
--
-- Sinusoid plot:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > import Diagrams.Backend.Cairo (Cairo)
-- > import Diagrams.Prelude
-- > import Typed.Spreadsheet
-- >
-- > main :: IO ()
-- > main = graphicalUI "Example program" logic
-- > where
-- > logic = combine <$> spinButtonAt 50 "Amplitude (Pixels)" 0.1
-- > <*> spinButtonAt 0.1 "Frequency (Pixels⁻¹)" 0.001
-- > <*> spinButtonAt 90 "Phase (Degrees)" 1
-- >
-- > combine :: Double -> Double -> Double -> Diagram Cairo
-- > combine amplitude frequency phase = strokeP (fromVertices points) <> axes
-- > where
-- > axes = arrowBetween (p2 (0, 0)) (p2 ( 100, 0))
-- > <> arrowBetween (p2 (0, 0)) (p2 (-100, 0))
-- > <> arrowBetween (p2 (0, 0)) (p2 ( 0, 100))
-- > <> arrowBetween (p2 (0, 0)) (p2 ( 0, -100))
-- >
-- > f x = - amplitude * cos (frequency * x + phase * pi / 180)
-- >
-- > points = map (\x -> p2 (x, f x)) [-100, -99 .. 100]
--
-- Example input and output:
--
-- <<http://i.imgur.com/ueF0w7U.png Sinusoid plot>>
--
-- Factor diagram:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > import Diagrams.Backend.Cairo (Cairo)
-- > import Diagrams.Prelude
-- > import Diagrams.TwoD.Factorization (factorDiagram')
-- > import Typed.Spreadsheet
-- >
-- > main :: IO ()
-- > main = graphicalUI "Factor diagram" logic
-- > where
-- > logic = combine <$> spinButtonAt 3 "Factor #1" 1
-- > <*> spinButtonAt 3 "Factor #2" 1
-- > <*> spinButtonAt 3 "Factor #3" 1
-- >
-- > combine :: Double -> Double -> Double -> Diagram Cairo
-- > combine x y z =
-- > factorDiagram' [truncate x, truncate y, truncate z] # scale 10
--
-- Example input and output:
--
-- <<http://i.imgur.com/eMvMtKk.png Factor diagram>>