Initial commit

LICENSE

@@ -0,0 +1,24 @@
+Copyright (c) 2015 Gabriel Gonzalez
+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 Gabriel Gonzalez 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.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

cell.cabal

@@ -0,0 +1,30 @@
+Name: cell
+Version: 1.0.0
+Cabal-Version: >=1.8.0.2
+Build-Type: Simple
+License: BSD3
+License-File: LICENSE
+Copyright: 2015 Gabriel Gonzalez
+Author: Gabriel Gonzalez
+Maintainer: Gabriel439@gmail.com
+Bug-Reports: https://github.com/Gabriel439/Haskell-Cell-Library/issues
+Synopsis: Concurrent and combinable updates
+Description: Spreadsheet-like programming
+Category: Control, Concurrency
+Source-Repository head
+    Type: git
+    Location: https://github.com/Gabriel439/Haskell-Cell-Library
+
+Library
+    Hs-Source-Dirs: src
+    Build-Depends:
+        base      >= 4      && < 5   ,
+        async     >= 2.0    && < 2.1 ,
+        foldl     >= 1.1    && < 1.2 ,
+        gtk3      >= 0.14.0 && < 0.15,
+        managed   >= 1.0.0  && < 1.1 ,
+        microlens              < 0.4 ,
+        stm                    < 2.5 ,
+        text                   < 1.3
+    Exposed-Modules: Control.Applicative.Cell
+    GHC-Options: -O2 -Wall

src/Control/Applicative/Cell.hs

@@ -0,0 +1,135 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE RecordWildCards           #-}
+-- TODO: Remove this
+
+module Control.Applicative.Cell (
+      Cell
+    , Controls(..)
+    , spreadsheet
+    , runManaged
+    ) where
+
+import Control.Applicative (Applicative(..), Alternative(..), liftA2)
+import Control.Concurrent.STM (STM)
+import Control.Foldl (Fold(..))
+import Control.Monad.Managed (Managed, liftIO, managed, runManaged)
+import Data.Text (Text)
+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 Control.Monad.Managed    as Managed
+import qualified Data.Text                as Text
+import qualified Graphics.UI.Gtk          as Gtk
+
+data Cell a = forall e . Cell (Managed (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 Controls = Controls
+    { double :: Double -> Double -> Double -> Cell Double
+    }
+
+spreadsheet :: Managed (Controls, Cell Text -> Managed ())
+spreadsheet = managed (\k -> do
+    _ <- Gtk.initGUI
+
+    window <- Gtk.windowNew
+    Gtk.set window
+        [ Gtk.containerBorderWidth := 5
+        ]
+
+    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
+        ]
+
+    vBox <- Gtk.vBoxNew False 5
+
+    hBox <- Gtk.hBoxNew False 5
+    Gtk.boxPackStart hBox vBox           Gtk.PackNatural 0
+    Gtk.boxPackStart hBox scrolledWindow Gtk.PackGrow    0
+
+    Gtk.set window
+        [ Gtk.windowTitle         := "Haskell Spreadsheet"
+        , Gtk.containerChild      := hBox
+        , Gtk.windowDefaultWidth  := 400
+        , Gtk.windowDefaultHeight := 400
+        ]
+
+    let _double :: Double -> Double -> Double -> Cell Double
+        _double minX maxX stepX = Cell (liftIO (do
+            tmvar      <- STM.newEmptyTMVarIO
+            spinButton <- Gtk.spinButtonNewWithRange minX maxX stepX
+            _          <- Gtk.onValueSpinned spinButton (do
+                n <- Gtk.get spinButton Gtk.spinButtonValue
+                STM.atomically (STM.putTMVar tmvar n) )
+            Gtk.boxPackStart vBox spinButton Gtk.PackNatural 0
+            Gtk.widgetShowAll vBox
+            return (STM.takeTMVar tmvar, Fold.lastDef 0) ))
+
+    let controls = Controls
+            { double = _double
+            }
+
+    doneTMVar <- STM.newEmptyTMVarIO
+
+    let run :: Cell Text -> Managed ()
+        run (Cell m) = do
+            (stm, Fold step begin done) <- m
+            Managed.liftIO (do
+                let loop x = do
+                        let txt = done x
+                        Gtk.postGUISync
+                            (Gtk.set textBuffer [ Gtk.textBufferText := txt ])
+                        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 ))
+    Async.withAsync (k (controls, run)) (\a -> do
+        Gtk.widgetShowAll window
+        Gtk.mainGUI
+        Async.wait a ) )
+
+-- TODO: Remove this
+main = runManaged (do
+    (Controls{..}, run) <- spreadsheet
+
+    let f x y = Text.pack (show (x ** y))
+
+    let result = f <$> double 0 100 1
+                   <*> double 0 100 1
+    run result )

stack.yaml

@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps: []
+resolver: lts-3.1