module Typed.Spreadsheet (
Updatable
, textUI
, graphicalUI
, checkBox
, spinButton
, entry
, radioButton
, checkBoxAt
, spinButtonAt
, entryAt
, display
) 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, reflectY, 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
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
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
}
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.boxPackStart hBox scrolledWindow Gtk.PackGrow 0
return textBuffer
processTextEvent :: Gtk.TextBuffer -> Text -> IO ()
processTextEvent textBuffer txt =
Gtk.set textBuffer [ Gtk.textBufferText := txt ]
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
renderToGtk drawWindow (diagram # reflectY # translate (r2 (w', h')))
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
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 )
checkBox
:: Text
-> Updatable Bool
checkBox = checkBoxAt False
spinButton
:: Text
-> Double
-> Updatable Double
spinButton = spinButtonAt 0
entry
:: Text
-> Updatable Text
entry = entryAt Text.empty
radioButton
:: Show a
=> Text
-> a
-> [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)
spinButtonAt
:: Double
-> Text
-> Double
-> Updatable Double
spinButtonAt s0 label x =
Updatable (\control -> _spinButtonAt control s0 label x)
entryAt
:: Text
-> Text
-> Updatable Text
entryAt s0 label = Updatable (\control -> _entryAt control s0 label)
display :: Show a => a -> Text
display = Text.pack . show