├── .gitignore ├── FPSheet.cabal ├── LICENSE ├── README.md ├── Setup.hs ├── examples ├── Covid.hs ├── Plot.hs └── PlotBackend.hs ├── exe ├── Main.hs └── Sheet │ └── Frontend │ ├── CmdParser.hs │ ├── TUI.hs │ └── Types.hs ├── imgs └── example.png ├── lib └── Sheet │ └── Backend │ ├── SheetAbstr.hs │ ├── Standard.hs │ └── Standard │ ├── Deps.hs │ ├── Impl.hs │ ├── Parsers.hs │ ├── Saves.hs │ └── Types.hs ├── stack.yaml ├── test ├── Main.hs ├── PropertyTests.hs └── UnitTests.hs ├── watchAppLog.sh └── watchGhciLog.sh /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .stack-work/ 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.tix 8 | .virtualenv 9 | .hsenv 10 | .cabal-sandbox/ 11 | cabal.sandbox.config 12 | cabal.config 13 | *.swp 14 | .web-log 15 | .sheet 16 | .ghciLog 17 | *.fps 18 | -------------------------------------------------------------------------------- /FPSheet.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.28.2. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: dd08242f80190563f0e480bc2b44c102f40d55803268fc42c4f09b9b4cc2c60d 6 | 7 | name: FPSheet 8 | version: 0.1.0.0 9 | description: Please see the README on GitHub at 10 | homepage: https://github.com/githubuser/FPSheet#readme 11 | bug-reports: https://github.com/githubuser/FPSheet/issues 12 | author: Author name here 13 | maintainer: example@example.com 14 | copyright: 2018 Author name here 15 | license: BSD3 16 | license-file: LICENSE 17 | build-type: Simple 18 | cabal-version: >= 1.10 19 | extra-source-files: 20 | README.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/RKlompUU/FPSheet 25 | 26 | library 27 | default-language: Haskell2010 28 | hs-source-dirs: lib 29 | exposed-modules: 30 | Sheet.Backend.Standard 31 | Sheet.Backend.Standard.Deps 32 | Sheet.Backend.Standard.Parsers 33 | Sheet.Backend.Standard.Types 34 | other-modules: 35 | Paths_FPSheet 36 | Sheet.Backend.SheetAbstr 37 | Sheet.Backend.Standard.Saves 38 | Sheet.Backend.Standard.Impl 39 | build-depends: 40 | base >=4.7 && <5, 41 | aeson, 42 | mtl, 43 | lens, 44 | text, 45 | bytestring, 46 | xlsx, 47 | containers, 48 | hint >= 0.9.0, 49 | uu-tc, 50 | haskell-src-exts >= 1.20.3, 51 | haskell-src-exts-util, 52 | exceptions 53 | 54 | test-suite FPSheet-test 55 | default-language: Haskell2010 56 | hs-source-dirs: test 57 | type: exitcode-stdio-1.0 58 | main-is: Main.hs 59 | other-modules: 60 | Paths_FPSheet 61 | PropertyTests 62 | UnitTests 63 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 64 | build-depends: 65 | FPSheet, 66 | base >=4.7 && <5, 67 | QuickCheck, 68 | hspec 69 | 70 | executable FPSheet-exe 71 | default-language: Haskell2010 72 | hs-source-dirs: exe 73 | main-is: Main.hs 74 | other-modules: 75 | Paths_FPSheet 76 | Sheet.Frontend.Types 77 | Sheet.Frontend.TUI 78 | Sheet.Frontend.CmdParser 79 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 80 | build-depends: 81 | FPSheet, 82 | hint >= 0.9.0, 83 | base >=4.7 && <5, 84 | containers, 85 | brick, 86 | aeson, 87 | vty, 88 | terminal-size, 89 | text, 90 | uu-tc, 91 | json 92 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Rick Klomp (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # FPSheet 2 | ## A Spreadsheet program with Haskell as the scripting language 3 | 4 | The prototype was written in C, it can be tried out in the c-prototype branch. 5 | I am currently rewriting the tool in Haskell, which I am doing in this master branch. 6 | 7 | ![Alt text](imgs/example.png?raw=true "Example") 8 | 9 | FPSheet is a spreadsheet program, where the scripting language for computing cell's values from formulas runs Haskell internally. 10 | This arguably provides a more uniform experience than what is provided by the scripting languages of standard spreadsheet programs. Note: this README currently assumes some familiarity from the reader with ghc's ghci tool. 11 | 12 | The tool maintains a Haskell Interpreter session in the background. When a cell is defined or edited, a unique variable is defined or redefined inside this session. For example, if cell abd124 is edited to: "45", FPSheet sends the following to the interpreter session: "let abd124 = 45". Similarly, if cell a4 is edited to: "a5 * 10", FPSheet sends the following to the ghci session: "let a4 = a5 * 10". 13 | 14 | Interestingly, since Haskell is lazily evaluated, and since Haskell regards function values as first class citizens, functions can be defined by cells. Any other cell can then apply these functions simply by referring to cells. 15 | 16 | ### Installation 17 | 18 | Run: `stack install` 19 | 20 | ### Usage 21 | 22 | Run: `stack exec FPSheet-exe` 23 | 24 | The program has vim-like modes: 25 | - normal mode for moving around 26 | - edit mode for editing the definition of a cell 27 | 28 | While in normal mode, press: 29 | - `:q` to exit. 30 | - `:w ` to write the sheet to disk 31 | - `:r ` to read a sheet from disk 32 | - `:i ` to import an .xlsx file (imports from cell values) 33 | - `:I ` to import an .xlsx file (imports from cell formulas if set, falls back to cell values for cells that do not have a formula definition set) 34 | - `:` to jump to `column,row` (e.g. `a10`, `azzz4050`, etc.) 35 | - `` to interrupt the ghci backend (useful for when you accidentally defined a cell that cannot finish evaluation) 36 | 37 | ### TODOs 38 | 39 | - Fix known issue: the haskell interpreter that is currently used does not appear to support polymorphic definitions. 40 | - We now have [a1..a10], [a1..e1], [a1..e10], [a1..], similar ranges not yet supported are: 41 | - [a1,b1..] 42 | - [a1,a4..] 43 | - [a1,a4..a10] 44 | - Copy pasting cells (properly handling loose and stuck cell references) 45 | - Exporting to excell savefiles 46 | - Undo & redo 47 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/Covid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Covid where 3 | 4 | import Text.JSON.Generic 5 | 6 | data Datapoint = Datapoint { 7 | country :: String, 8 | active :: Double, 9 | city :: String, 10 | citycode :: String, 11 | confirmed :: Double, 12 | date :: String, 13 | deaths :: Double, 14 | lat :: String, 15 | lon :: String, 16 | province :: String, 17 | recovered :: Double 18 | } deriving (Typeable, Data, Show, Eq) 19 | 20 | decode :: String -> [Datapoint] 21 | decode = decodeJSON 22 | -------------------------------------------------------------------------------- /examples/Plot.hs: -------------------------------------------------------------------------------- 1 | {- | A first example of drawing diagrams from within GTK. This 2 | program draws a Koch snowflake with the depth controllable 3 | via a GTK widget. 4 | 5 | Install dependencies: 6 | - stack install gi-gtk plots diagrams-cairo 7 | -} 8 | {-# LANGUAGE OverloadedLabels, OverloadedStrings, TypeFamilies, FlexibleContexts, NoMonomorphismRestriction #-} 9 | module Plot where 10 | 11 | import PlotBackend 12 | 13 | import Plots 14 | 15 | import Control.Monad 16 | import Control.DeepSeq 17 | 18 | import qualified GI.Gdk as Gdk 19 | import qualified GI.Gtk as Gtk 20 | import Data.GI.Base 21 | import Diagrams.Prelude hiding (set) 22 | import Diagrams.Size (requiredScaling) 23 | import Diagrams.Backend.Cairo (Cairo) 24 | import qualified Data.Colour as C 25 | 26 | -- A function to set up the main window and signal handlers 27 | createMainWindow :: [(String, [Double])] -> IO Gtk.Window 28 | createMainWindow yss = do 29 | win <- new Gtk.Window [] 30 | 31 | on win #keyPressEvent $ \event -> do 32 | name <- event `get` #keyval >>= Gdk.keyvalName 33 | when (name == Just "Escape") Gtk.mainQuit 34 | return False 35 | 36 | drawArea <- new Gtk.DrawingArea [#widthRequest := 1000, #heightRequest := 1000] 37 | 38 | -- add the depthWidget control and drawArea to the main window 39 | hbox <- Gtk.boxNew Gtk.OrientationVertical 0 40 | Gtk.boxPackStart hbox drawArea True True 0 41 | #add win hbox 42 | 43 | -- handle the drawArea's @onExpose@ signal. We provide a function 44 | -- that takes an area marked as dirty and redraws it. 45 | -- This program simply redraws the entire drawArea. 46 | -- 47 | -- Many gtk signal handlers return True if the signal was handled, and False 48 | -- otherwise (in which case the signal will be propagated to the parent). 49 | on drawArea #draw $ \context -> do 50 | rect <- Gtk.widgetGetAllocation drawArea -- size in pixels (Int) 51 | canvasX <- get rect #width 52 | canvasY <- get rect #height 53 | let dia = renderAxis $ linesPlot yss 54 | w = width dia 55 | h = height dia 56 | spec = mkSizeSpec2D (Just $ fromIntegral canvasX) (Just $ fromIntegral canvasY) 57 | scaledDia_ = toGtkCoords $ transform (requiredScaling spec (V2 w h)) dia 58 | renderToGtk context True scaledDia_ -- (renderAxis myaxis) -- scaledDia 59 | return True 60 | 61 | return win 62 | 63 | -- Gtk application 64 | -- 65 | -- Initialize the library, create and show the main window, 66 | -- finally enter the main loop 67 | doLinesPlot :: [(String, [Double])] -> IO () 68 | doLinesPlot yss = do 69 | deepseq yss $ return () 70 | Gtk.init Nothing 71 | win <- createMainWindow yss 72 | on win #destroy Gtk.mainQuit 73 | Gtk.widgetShowAll win 74 | Gtk.main 75 | 76 | test :: IO () 77 | test = do 78 | Gtk.init Nothing 79 | win <- createMainWindow undefined 80 | Gtk.widgetShowAll win 81 | Gtk.main 82 | 83 | linesPlot yss = 84 | let datapoints = map (\(lbl, ys) -> (lbl, zip [1..] ys)) yss 85 | in r2Axis &~ do 86 | mapM (\(lbl, points) -> linePlot points (key lbl)) datapoints 87 | -- smoothLinePlot 88 | -------------------------------------------------------------------------------- /examples/PlotBackend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Diagrams.Backend.Gtk 5 | -- Copyright : (c) 2019 Torsten Kemps-Benedix 6 | -- License : MIT-style (see LICENSE) 7 | -- Maintainer : tkx68@icloud.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Convenient interface to rendering diagrams directly 12 | -- on Gtk DrawingArea widgets using the Cairo backend. This package uses Cairo 13 | -- double buffering (see ). 14 | -- 15 | -- See the following example for a practical use case. Have a close look at the 16 | -- use of 'renderToGtk' in the `on drawArea #draw` code block. See 17 | -- 18 | -- for details on the draw signal or 19 | -- 20 | -- for the original GTK3 documentation. 21 | -- 22 | -- @ 23 | -- {-# LANGUAGE OverloadedLabels, OverloadedStrings, TypeFamilies, FlexibleContexts, NoMonomorphismRestriction #-} 24 | -- module Main where 25 | -- 26 | -- import Control.Monad 27 | -- import qualified GI.Gdk as Gdk 28 | -- import qualified GI.Gtk as Gtk 29 | -- import Data.GI.Base 30 | -- import Diagrams.Prelude hiding (set) 31 | -- import Diagrams.Size (requiredScaling) 32 | -- import Diagrams.Backend.GIGtk 33 | -- import Diagrams.Backend.Cairo (Cairo) 34 | -- import qualified Data.Colour as C 35 | -- import Data.Text (Text) 36 | -- import qualified Data.Text as T 37 | -- 38 | -- hilbert :: Int -> Diagram Cairo 39 | -- hilbert = frame 1 . lw medium . lc (colors!!1) . strokeT . hilbert' 40 | -- where 41 | -- hilbert' :: Int -> Trail V2 Double 42 | -- hilbert' 0 = mempty 43 | -- hilbert' n = 44 | -- hilbert'' (n-1) # reflectY <> vrule 1 45 | -- <> hilbert' (n-1) <> hrule 1 46 | -- <> hilbert' (n-1) <> vrule (-1) 47 | -- <> hilbert'' (n-1) # reflectX 48 | -- where 49 | -- hilbert'' :: Int -> Trail V2 Double 50 | -- hilbert'' m = hilbert' m # rotateBy (1/4) 51 | -- 52 | -- -- Our drawing code, copied from 53 | -- -- projects.haskell.org/diagrams/gallery/Pentaflake.html 54 | -- colors ::[Colour Double] 55 | -- colors = iterate (C.blend 0.1 white) red 56 | -- 57 | -- p ::Diagram Cairo 58 | -- p = regPoly 5 1 # lwO 0 59 | -- 60 | -- -- | create a snowflake diagram of depth @n@ 61 | -- -- 62 | -- -- specifying a type here because the monoidal query type needs to be specified 63 | -- -- for @drawToGtk@, otherwise get a "No instance for (PathLike ..." error. 64 | -- pentaflake :: Int -> Diagram Cairo 65 | -- pentaflake 0 = p 66 | -- pentaflake n = appends (p' # fc (colors !! (n-1))) 67 | -- (zip vs (repeat (rotateBy (1/2) p'))) 68 | -- where vs = take 5 . iterate (rotateBy (1/5)) 69 | -- . (if odd n then negated else id) $ unitY 70 | -- p' = pentaflake (n-1) 71 | -- 72 | -- pentaflake' ::Int -> Diagram Cairo 73 | -- pentaflake' n = pentaflake n # fc (colors !! n) 74 | -- 75 | -- -- end of diagrams code 76 | -- 77 | -- -- A function to set up the main window and signal handlers 78 | -- createMainWindow :: IO Gtk.Window 79 | -- createMainWindow = do 80 | -- win <- new Gtk.Window [] 81 | -- 82 | -- on win #keyPressEvent $ \event -> do 83 | -- name <- event `get` #keyval >>= Gdk.keyvalName 84 | -- when (name == Just "Escape") Gtk.mainQuit 85 | -- return False 86 | -- 87 | -- depthWidget <- Gtk.spinButtonNewWithRange 1 10 1 88 | -- -- when the spinButton changes, redraw the window 89 | -- on depthWidget #valueChanged $ do 90 | -- Gtk.widgetQueueDraw win --drawArea 91 | -- return () 92 | -- 93 | -- rbHilbert <- Gtk.radioButtonNewWithLabelFromWidget Gtk.noRadioButton "Hilbert" 94 | -- set rbHilbert [#active := True] 95 | -- rbPentaFlake <- Gtk.radioButtonNewWithLabelFromWidget (Just rbHilbert) "Penta Flake" 96 | -- set rbPentaFlake [#active := False] 97 | -- boxRB <- Gtk.boxNew Gtk.OrientationVertical 0 98 | -- Gtk.boxPackStart boxRB rbHilbert False False 0 99 | -- Gtk.boxPackStart boxRB rbPentaFlake False False 0 100 | -- 101 | -- drawArea <- new Gtk.DrawingArea [#widthRequest := 512, #heightRequest := 512] 102 | -- 103 | -- -- add the depthWidget control and drawArea to the main window 104 | -- hbox <- Gtk.boxNew Gtk.OrientationVertical 0 105 | -- Gtk.boxPackStart hbox boxRB False False 0 -- box child expand fill extraPadding 106 | -- Gtk.boxPackStart hbox depthWidget False False 0 -- box child expand fill extraPadding 107 | -- Gtk.boxPackStart hbox drawArea True True 0 108 | -- #add win hbox 109 | -- 110 | -- on rbHilbert #toggled $ do 111 | -- Gtk.widgetQueueDraw drawArea 112 | -- return () 113 | -- 114 | -- -- handle the drawArea's @onExpose@ signal. We provide a function 115 | -- -- that takes an area marked as dirty and redraws it. 116 | -- -- This program simply redraws the entire drawArea. 117 | -- -- 118 | -- -- Many gtk signal handlers return True if the signal was handled, and False 119 | -- -- otherwise (in which case the signal will be propagated to the parent). 120 | -- on drawArea #draw $ \context -> do 121 | -- rect <- Gtk.widgetGetAllocation drawArea -- size in pixels (Int) 122 | -- canvasX <- get rect #width 123 | -- canvasY <- get rect #height 124 | -- curDepth <- fromIntegral <$> Gtk.spinButtonGetValueAsInt depthWidget 125 | -- hilbertActive <- get rbHilbert #active 126 | -- let dia = if hilbertActive then hilbert curDepth else pentaflake curDepth 127 | -- w = width dia 128 | -- h = height dia 129 | -- spec = mkSizeSpec2D (Just $ fromIntegral canvasX) (Just $ fromIntegral canvasY) 130 | -- scaledDia = toGtkCoords $ transform (requiredScaling spec (V2 w h)) dia 131 | -- renderToGtk context True scaledDia 132 | -- return True 133 | -- 134 | -- return win 135 | -- 136 | -- -- Gtk application 137 | -- -- 138 | -- -- Initialize the library, create and show the main window, 139 | -- -- finally enter the main loop 140 | -- main :: IO () 141 | -- main = do 142 | -- Gtk.init Nothing 143 | -- win <- createMainWindow 144 | -- on win #destroy Gtk.mainQuit 145 | -- Gtk.widgetShowAll win 146 | -- Gtk.main 147 | -- @ 148 | ----------------------------------------------------------------------------- 149 | module PlotBackend 150 | ( defaultRender 151 | , toGtkCoords 152 | , renderToGtk 153 | ) where 154 | 155 | import Control.Monad.Trans.Reader (runReaderT) 156 | import Diagrams.Prelude hiding (render, height, width) 157 | import Diagrams.Backend.Cairo.Internal 158 | import Foreign.Ptr (castPtr) 159 | import GHC.Int 160 | import qualified GI.Cairo (Context(..)) 161 | import GI.Gtk 162 | import qualified Graphics.Rendering.Cairo as Cairo 163 | import qualified Graphics.Rendering.Cairo.Internal as Cairo (Render(runRender)) 164 | import qualified Graphics.Rendering.Cairo.Types as Cairo (Cairo(Cairo)) 165 | 166 | -- | This function bridges gi-cairo with the hand-written cairo 167 | -- package. It takes a `GI.Cairo.Context` (as it appears in gi-cairo), 168 | -- and a `Render` action (as in the cairo lib), and renders the 169 | -- `Render` action into the given context. 170 | renderWithContext :: GI.Cairo.Context -> Cairo.Render () -> IO () 171 | renderWithContext ct r = withManagedPtr ct $ \p -> 172 | runReaderT (Cairo.runRender r) (Cairo.Cairo (castPtr p)) 173 | 174 | -- | Convert a Diagram to the backend coordinates. 175 | -- 176 | -- Provided to Query the diagram with coordinates from a mouse click 177 | -- event. 178 | -- 179 | -- > widget `on` buttonPressEvent $ tryEvent $ do 180 | -- > click <- eventClick 181 | -- > (x,y) <- eventCoordinates 182 | -- > let result = runQuery (query $ toGtkCoords myDiagram) (x ^& y) 183 | -- > do_something_with result 184 | -- 185 | -- `toGtkCoords` does no rescaling of the diagram, however it is centered in 186 | -- the window. 187 | toGtkCoords :: Monoid' m => QDiagram Cairo V2 Double m -> QDiagram Cairo V2 Double m 188 | toGtkCoords d = (\(_,_,d') -> d') $ 189 | adjustDia Cairo 190 | (CairoOptions "" absolute RenderOnly False) 191 | d 192 | 193 | -- | Render a diagram to a 'DrawingArea''s context with double buffering if needed, 194 | -- rescaling to fit the full area. 195 | defaultRender :: 196 | Monoid' m => 197 | GI.Cairo.Context -- ^ DrawingArea's context to render onto -- provided by the draw event 198 | -> Bool -- ^render double buffered? 199 | -> QDiagram Cairo V2 Double m -- ^ Diagram 200 | -> IO () 201 | defaultRender ctx diagram = do 202 | render ctx opts diagram 203 | where opts w h = (CairoOptions 204 | { _cairoFileName = "" 205 | , _cairoSizeSpec = dims (V2 (fromIntegral w) (fromIntegral h)) 206 | , _cairoOutputType = RenderOnly 207 | , _cairoBypassAdjust = False 208 | } 209 | ) 210 | 211 | -- | Render a diagram to a 'DrawArea''s context with double buffering. No 212 | -- rescaling or transformations will be performed. 213 | -- 214 | -- Typically the diagram will already have been transformed by 215 | -- 'toGtkCoords'. 216 | renderToGtk :: 217 | (Monoid' m) 218 | => GI.Cairo.Context -- ^ DrawingArea's context to render onto -- provided by the draw event 219 | -> Bool -- ^render double buffered? 220 | -> QDiagram Cairo V2 Double m -- ^ Diagram 221 | -> IO () 222 | renderToGtk ctx db = render ctx opts db 223 | where opts _ _ = (CairoOptions 224 | { _cairoFileName = "" 225 | , _cairoSizeSpec = absolute 226 | , _cairoOutputType = RenderOnly 227 | , _cairoBypassAdjust = True 228 | } 229 | ) 230 | 231 | -- | Render a diagram onto a 'GI.Cairo.Context' using the given CairoOptions. Place this within a 'draw' event callback which provides the DrawArea's context. 232 | -- 233 | -- This uses cairo double-buffering if the thirs parameter is set to True.. 234 | render :: 235 | (Monoid' m) => 236 | GI.Cairo.Context -- ^ DrawingArea's 'GI.Cairo.Context' to render the digram onto 237 | -> (Int32 -> Int32 -> Options Cairo V2 Double) -- ^ options, depending on drawable width and height 238 | -> Bool -- ^render double buffered? 239 | -> QDiagram Cairo V2 Double m -- ^ Diagram 240 | -> IO () 241 | render ctx renderOpts db diagram = 242 | renderWithContext ctx (do 243 | (x1, x2, y1, y2) <- Cairo.clipExtents 244 | let w = round $ x2 - x1 245 | h = round $ y2 - y1 246 | opts = renderOpts w h 247 | if db 248 | then doubleBuffer $ do 249 | delete w h 250 | snd (renderDia Cairo opts diagram) 251 | else 252 | snd (renderDia Cairo opts diagram) 253 | ) 254 | 255 | -- 256 | -- Used to clear canvas when using double buffering. 257 | delete :: Int32 -> Int32 -> Cairo.Render () 258 | delete w h = do 259 | Cairo.setSourceRGB 1 1 1 260 | Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h) 261 | Cairo.fill 262 | 263 | 264 | -- | Wrap the given render action in double buffering. 265 | doubleBuffer :: Cairo.Render () -> Cairo.Render () 266 | doubleBuffer renderAction = do 267 | Cairo.pushGroup 268 | renderAction 269 | Cairo.popGroupToSource 270 | Cairo.paint 271 | -------------------------------------------------------------------------------- /exe/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Sheet.Backend.Standard 4 | import Sheet.Frontend.Types 5 | import Sheet.Frontend.TUI 6 | 7 | import qualified Language.Haskell.Interpreter as I 8 | import qualified Data.Map as M 9 | 10 | main :: IO () 11 | main = do 12 | runTUI 13 | 14 | test :: StateTy C 15 | test = do 16 | let p0 = (3,4) 17 | 18 | let p = (1,4) 19 | getCell p >>= setText "(\\x -> x + c4) $ 5 * 104" >>= evalCell 20 | 21 | getCell (1,5) >>= setText "\"pretty long string here\"" >>= evalCell 22 | getCell (3,5) >>= setText "\"also pretty long\"" >>= evalCell 23 | 24 | --getCell p0 >>= setText "5 * 3" >>= evalCell 25 | 26 | getCell p 27 | -------------------------------------------------------------------------------- /exe/Sheet/Frontend/CmdParser.hs: -------------------------------------------------------------------------------- 1 | module Sheet.Frontend.CmdParser where 2 | 3 | import Prelude hiding ((<*>), (<|>), (<$>), (<*), (*>), (<$), ($>)) 4 | import ParseLib 5 | 6 | import Sheet.Backend.Standard 7 | 8 | data Command = 9 | CmdInvalid | 10 | CmdMoveCursor Int Int | 11 | CmdImport Bool String | 12 | CmdSaveActiveFile | 13 | CmdSave String | 14 | CmdLoad String | 15 | CmdQuit Bool 16 | 17 | type CmdParser a = Parser Char a 18 | 19 | parseCmd :: String -> Command 20 | parseCmd cmd = 21 | case filter (null . snd) (parse cmdParser cmd) of 22 | [] -> CmdInvalid 23 | ((x,_):_) -> x 24 | 25 | cmdParser :: CmdParser Command 26 | cmdParser = 27 | CmdMoveCursor <$> pCol <*> pRow <|> 28 | CmdImport <$> ((=='i') <$> (symbol 'i' <|> symbol 'I')) <*> (pWhitespace *> pFilename) <|> 29 | CmdSaveActiveFile <$ symbol 'w' <|> 30 | CmdSave <$> (symbol 'w' *> pWhitespace *> pFilename) <|> 31 | CmdLoad <$> (symbol 'r' *> pWhitespace *> pFilename) <|> 32 | CmdQuit True <$ token "wq" <|> 33 | CmdQuit False <$ symbol 'q' 34 | 35 | pFilename :: CmdParser String 36 | pFilename = 37 | let fchars = ['a'..'z'] ++ ['A'..'Z'] ++ ['.', '/'] 38 | in greedy1 (satisfy (flip elem fchars)) 39 | 40 | -------------------------------------------------------------------------------- /exe/Sheet/Frontend/TUI.hs: -------------------------------------------------------------------------------- 1 | module Sheet.Frontend.TUI where 2 | 3 | import Sheet.Backend.Standard 4 | import Sheet.Frontend.Types 5 | 6 | import Control.Concurrent.Chan 7 | 8 | import Brick.Widgets.Core 9 | import Graphics.Vty 10 | import Graphics.Vty.Attributes 11 | import Brick.Util 12 | import Brick.Widgets.Border 13 | import Brick.Widgets.Center 14 | import Brick 15 | import Brick.Widgets.Edit 16 | import Brick.Types 17 | import Brick.BChan 18 | 19 | import Data.List 20 | import Control.Concurrent 21 | 22 | import System.Environment 23 | import System.Console.Terminal.Size 24 | 25 | import qualified Data.Text as T 26 | 27 | import System.Exit 28 | import Control.Monad.IO.Class 29 | 30 | import Sheet.Frontend.CmdParser 31 | 32 | import qualified Data.Map as M 33 | 34 | type BrickS = UISheet 35 | type BrickE = CustomEvent -- Custom event type 36 | type BrickN = String -- Custom resource type 37 | 38 | runTUI :: IO () 39 | runTUI = do 40 | args <- getArgs 41 | let f = safeGet args 0 42 | asyncResChan <- Brick.BChan.newBChan 10000 43 | initialState <- initUISheet asyncResChan 44 | let app = App { appDraw = drawImpl, 45 | appChooseCursor = chooseCursorImpl, 46 | appHandleEvent = handleEventImpl, 47 | appStartEvent = startEventImpl f, 48 | appAttrMap = attrMapImpl } 49 | finalState <- customMain (Graphics.Vty.mkVty Graphics.Vty.defaultConfig) 50 | (Just asyncResChan) 51 | app 52 | initialState 53 | return () 54 | 55 | drawImpl :: BrickS -> [Widget BrickN] 56 | drawImpl s = 57 | let (colOffset, rowOffset) = sheetOffset s 58 | colsNum = uiCols s 59 | rowsNum = uiRows s 60 | 61 | cols = [colOffset..colOffset + colsNum] 62 | rows = [rowOffset..rowOffset + rowsNum] 63 | 64 | colsHeader = hBox 65 | $ insertColSeps 66 | $ map (renderColTag s (sheetCursor s)) cols 67 | rowsHeader = vBox $ map (renderRowTag (sheetCursor s)) rows 68 | 69 | cells = s_cells $ sheetCells s 70 | cellRows = [[(c,r) | c <- cols] | r <- rows] 71 | in renderSelectedCell s : 72 | [(str " " <=> 73 | fixedWidthRightStr (headerWidth s) "," <=> 74 | (rowsHeader <+> vBorder)) <+> 75 | (colsHeader <=> 76 | hBorder <=> 77 | vBox (map (hBox . insertColSeps . map (renderCell s)) cellRows)) 78 | <=> 79 | renderFooter s] 80 | 81 | insertColSeps :: [Widget BrickN] -> [Widget BrickN] 82 | insertColSeps = intercalate [str $ take colSep $ repeat ' '] . map (: []) 83 | 84 | renderSelectedCell :: BrickS -> Widget BrickN 85 | renderSelectedCell s = 86 | let p@(cCursor, rCursor) = sheetCursor s 87 | cell = M.lookup p (s_cells $ sheetCells s) 88 | cellRendering = case uiMode s of 89 | ModeEdit{cellEditor = editField, cellEditorWidth = editWidth} -> 90 | hLimit (editWidth) $ renderEditor (str . flip (++) "." . intercalate "\n") True editField 91 | _ -> case cell of 92 | Nothing -> fixedWidthLeftStr (cWidth s) "" 93 | Just c -> case maybe (getText c) id $ getEval c of 94 | "" -> fixedWidthLeftStr (cWidth s) "" 95 | text -> str (take (screenWidth s) text) 96 | in cellBgAttr s p applyStandout $ translateBy (Location $ sheetCursorPos s) cellRendering 97 | 98 | renderFooter :: BrickS -> Widget BrickN 99 | renderFooter s = 100 | case uiMode s of 101 | ModeCommand{cmdEditor = editField, cmdEditorWidth = editWidth} -> 102 | str ":" <+> hLimit (editWidth) (renderEditor (str . flip (++) "." . intercalate "\n") True editField) 103 | _ -> emptyWidget 104 | 105 | editorTextRenderer :: [String] -> Widget BrickN 106 | editorTextRenderer lns = 107 | let line = intercalate "\n" lns 108 | in hLimit (length line) $ str line 109 | 110 | renderCell :: BrickS -> Pos -> Widget BrickN 111 | renderCell s (col,row) = 112 | let (cCursor, rCursor) = sheetCursor s 113 | cell = M.lookup (col,row) (s_cells $ sheetCells s) 114 | in cellBgAttr s (col,row) id $ case cell of 115 | Nothing -> fixedWidthLeftStr (cWidth s) "" 116 | Just c -> case getEval c of 117 | Just res -> fixedWidthLeftStr (cWidth s) res 118 | Nothing -> fixedWidthLeftStr (cWidth s) (getText c) 119 | 120 | cellBgAttr s (col,row) dflt = 121 | case M.lookup (col,row) (cellStatus s) of 122 | Just CellSuccess -> withAttr greenBg 123 | Just CellDefined -> withAttr brightYellowBg 124 | Just CellUpdating -> withAttr yellowBg 125 | Just CellFailure -> withAttr redBg 126 | Nothing -> dflt 127 | 128 | fixedWidthLeftStr :: Int -> String -> Widget BrickN 129 | fixedWidthLeftStr width str = 130 | txt $ T.justifyLeft width ' ' $ T.pack $ take width str 131 | 132 | fixedWidthCenterStr :: Int -> String -> Widget BrickN 133 | fixedWidthCenterStr width str = 134 | txt $ T.center width ' ' $ T.pack $ take width str 135 | 136 | fixedWidthRightStr :: Int -> String -> Widget BrickN 137 | fixedWidthRightStr width str = 138 | txt $ T.justifyRight width ' ' $ T.pack $ take width str 139 | 140 | renderColTag :: BrickS -> Pos -> Int -> Widget BrickN 141 | renderColTag s (cCursor,_) col 142 | | col == cCursor = applyStandout $ fixedWidthCenterStr (cWidth s) $ toCol col 143 | | otherwise = fixedWidthCenterStr (cWidth s) $ toCol col 144 | 145 | renderRowTag :: Pos -> Int -> Widget BrickN 146 | renderRowTag (_,rCursor) row 147 | | row == rCursor = applyStandout $ str $ show row 148 | | otherwise = str $ show row 149 | 150 | chooseCursorImpl :: BrickS -> [CursorLocation BrickN] -> Maybe (CursorLocation BrickN) 151 | chooseCursorImpl _ [] = Nothing 152 | chooseCursorImpl _ cs = Just $ head cs 153 | 154 | sheetCursorPos :: UISheet -> Pos 155 | sheetCursorPos s = 156 | let (cCursor, rCursor) = sheetCursor s 157 | (cOffset, rOffset) = sheetOffset s 158 | x = (cCursor - cOffset) * (cWidth s + colSep) + headerWidth s 159 | y = (rCursor - rOffset) + headerHeight s 160 | in (x,y) 161 | 162 | uiSetActiveFile :: Maybe String -> UISheet -> UISheet 163 | uiSetActiveFile f s = 164 | s { 165 | activeFile = f 166 | } 167 | 168 | uiResize :: Int -> Int -> UISheet -> UISheet 169 | uiResize width height s = 170 | let rows = height - headerHeight s - 2 171 | cols = ((width - (headerWidth (s {uiRows = rows})) - 1) `div` (cWidth s + colSep)) - 1 172 | in s { 173 | uiCols = cols, 174 | uiRows = rows, 175 | 176 | screenWidth = width, 177 | screenHeight = height 178 | } 179 | 180 | headerWidth :: UISheet -> Int 181 | headerWidth s = 182 | let (_,rOffset) = sheetOffset s 183 | in (length $ show (rOffset + uiRows s)) + 1 184 | 185 | headerHeight :: UISheet -> Int 186 | headerHeight _ = 2 187 | 188 | colSep :: Int 189 | colSep = 1 190 | 191 | moveCursor :: Int -> Int -> BrickS -> BrickS 192 | moveCursor toCol toRow s = 193 | let toCol' = max 1 toCol 194 | toRow' = max 1 toRow 195 | (offsetCol, offsetRow) = sheetOffset s 196 | offsetCol' = if toCol' < offsetCol 197 | then toCol' 198 | else if toCol' > offsetCol + uiCols s 199 | then toCol' - uiCols s 200 | else offsetCol 201 | offsetRow' = if toRow' < offsetRow 202 | then toRow' 203 | else if toRow' > offsetRow + uiRows s 204 | then toRow' - uiRows s 205 | else offsetRow 206 | in s { sheetCursor = (toCol', toRow'), sheetOffset = (offsetCol', offsetRow') } 207 | 208 | delayedCustomEvent :: BChan CustomEvent -> Int -> CustomEvent -> IO () 209 | delayedCustomEvent chan delayMs custEv = do 210 | forkIO $ do 211 | threadDelay (delayMs * 1000) 212 | writeBChan chan custEv 213 | return () 214 | 215 | -- |- 216 | handleEventImpl :: BrickS -> BrickEvent BrickN BrickE -> EventM BrickN (Next BrickS) 217 | handleEventImpl s (AppEvent (EvNewDefinition (BackendJobResponse applyRes))) = do 218 | cells' <- liftIO $ execStateT applyRes (sheetCells s) 219 | continue $ s { sheetCells = cells', uiMode = ModeNormal } 220 | handleEventImpl s (AppEvent (EvVisualFeedback c stat)) = do 221 | case stat of 222 | CellSuccess -> liftIO $ delayedCustomEvent (custEvChan s) (showCellFeedbackTimeout s) (EvVisualFeedback c CellNoStatus) 223 | CellDefined -> liftIO $ delayedCustomEvent (custEvChan s) (showCellFeedbackTimeout s) (EvVisualFeedback c CellNoStatus) 224 | CellFailure -> liftIO $ delayedCustomEvent (custEvChan s) (showCellFeedbackTimeout s) (EvVisualFeedback c CellNoStatus) 225 | _ -> return () 226 | let cellStatus' = case stat of 227 | CellNoStatus -> M.delete (getCellPos c) (cellStatus s) 228 | _ -> M.insert (getCellPos c) stat (cellStatus s) 229 | continue $ s { cellStatus = cellStatus' } 230 | ------ 231 | handleEventImpl s (VtyEvent (EvResize width height)) = do 232 | continue $ uiResize width height s 233 | ------ 234 | handleEventImpl s@(UISheet { uiMode = ModeNormal }) ev = do 235 | let enterCmdEditor = continue $ s { 236 | uiMode = ModeCommand {cmdEditor = editor "Cell editor" (Just 1) "", 237 | cmdEditorWidth = 2} 238 | } 239 | case ev of 240 | VtyEvent (EvKey KEsc []) -> do 241 | liftIO $ do 242 | flip execStateT (sheetCells s) $ do 243 | interrupt 244 | continue $ s 245 | VtyEvent (EvKey KEnter []) -> do 246 | let (col,row) = sheetCursor s 247 | str = maybe "" getText $ M.lookup (col,row) (s_cells $ sheetCells s) 248 | editField = editor "Cell editor" (Just 1) str 249 | e' <- handleEditorEvent (EvKey (KChar 'e') [MCtrl]) editField 250 | continue $ s { 251 | uiMode = ModeEdit { 252 | cellEditor = e', 253 | cellEditorWidth = max (cWidth s) (length str + 2) 254 | } 255 | } 256 | VtyEvent (EvKey (KChar ';') []) -> enterCmdEditor 257 | VtyEvent (EvKey (KChar ':') []) -> enterCmdEditor 258 | VtyEvent (EvKey KRight []) -> do 259 | let (cCursor, rCursor) = sheetCursor s 260 | continue $ moveCursor (cCursor + 1) rCursor s 261 | VtyEvent (EvKey KLeft []) -> do 262 | let (cCursor, rCursor) = sheetCursor s 263 | continue $ moveCursor (cCursor-1) rCursor s 264 | VtyEvent (EvKey KUp []) -> do 265 | let (cCursor, rCursor) = sheetCursor s 266 | continue $ moveCursor cCursor (rCursor-1) s 267 | VtyEvent (EvKey KDown []) -> do 268 | let (cCursor, rCursor) = sheetCursor s 269 | continue $ moveCursor cCursor (rCursor + 1) s 270 | VtyEvent vtEv -> do 271 | let (col,row) = sheetCursor s 272 | editField = editor "Cell editor" (Just 1) "" 273 | e' <- handleEditorEvent vtEv editField 274 | continue $ s { 275 | uiMode = ModeEdit { 276 | cellEditor = e', 277 | cellEditorWidth = max (cWidth s) (2 + (length $ intercalate "\n" $ getEditContents e')) 278 | } 279 | } 280 | _ -> continue s 281 | ------ 282 | handleEventImpl s@(UISheet { uiMode = m@(ModeEdit{cellEditor = editField}) }) ev = do 283 | let apply = do let str = intercalate "" $ getEditContents editField 284 | cells' <- liftIO $ flip execStateT (sheetCells s) $ getCell (sheetCursor s) >>= setText str >>= evalCells . flip (:) [] 285 | return $ s { sheetCells = cells', uiMode = ModeNormal } 286 | case ev of 287 | VtyEvent (EvKey KEsc []) -> continue $ s { uiMode = ModeNormal } 288 | VtyEvent (EvKey KEnter []) -> apply >>= continue 289 | VtyEvent (EvKey KUp []) -> do 290 | s' <- apply 291 | let (cCursor, rCursor) = sheetCursor s 292 | continue $ moveCursor cCursor (rCursor-1) s' 293 | VtyEvent (EvKey KDown []) -> do 294 | s' <- apply 295 | let (cCursor, rCursor) = sheetCursor s 296 | continue $ moveCursor cCursor (rCursor + 1) s' 297 | VtyEvent vtEv -> do 298 | e' <- handleEditorEvent vtEv editField 299 | continue $ s { uiMode = m {cellEditor = e', cellEditorWidth = max (cWidth s) (2 + (length $ intercalate "\n" $ getEditContents e'))} } 300 | _ -> continue s 301 | ------ 302 | handleEventImpl s@(UISheet { uiMode = m@(ModeCommand{cmdEditor = editField}) }) ev = do 303 | case ev of 304 | VtyEvent (EvKey KEsc []) -> continue $ s { uiMode = ModeNormal } 305 | VtyEvent (EvKey KEnter []) -> do 306 | let str = intercalate "\n" $ getEditContents editField 307 | setSheetModeNormal s = s {uiMode = ModeNormal} 308 | saveFile f = liftIO $ do 309 | flip execStateT (sheetCells s) $ do 310 | save f 311 | saveActiveFile = case activeFile s of 312 | Just f -> saveFile f >> return () 313 | Nothing -> return () 314 | case parseCmd str of 315 | CmdMoveCursor col row -> continue 316 | $ setSheetModeNormal 317 | $ moveCursor col row s 318 | CmdImport simpleImport f -> do 319 | cells' <- liftIO $ do 320 | flip execStateT (sheetCells s) $ do 321 | importFile f simpleImport 322 | continue $ s { sheetCells = cells', uiMode = ModeNormal } 323 | CmdSave f -> do 324 | saveFile f 325 | continue $ s { uiMode = ModeNormal } 326 | CmdLoad f -> do 327 | cells' <- liftIO $ do 328 | flip execStateT (sheetCells s) $ do 329 | load f 330 | continue $ s { sheetCells = cells', uiMode = ModeNormal } 331 | CmdSaveActiveFile -> saveActiveFile >> continue (s { uiMode = ModeNormal }) 332 | CmdQuit save -> if save 333 | then saveActiveFile >> halt s 334 | else halt s 335 | CmdInvalid -> continue 336 | $ setSheetModeNormal s 337 | VtyEvent vtEv -> do 338 | e' <- handleEditorEvent vtEv editField 339 | continue $ s { uiMode = m {cmdEditor = e', cmdEditorWidth = max (cWidth s) (2 + (length $ intercalate "\n" $ getEditContents e'))} } 340 | _ -> continue s 341 | 342 | startEventImpl :: Maybe String -> BrickS -> EventM BrickN BrickS 343 | startEventImpl f s = do 344 | (cols, rows) <- liftIO $ maybe (80,24) (\w -> (width w, height w)) 345 | <$> size 346 | cells' <- case f of 347 | Just file -> do 348 | cells' <- liftIO $ do 349 | flip execStateT (sheetCells s) $ do 350 | load file 351 | return cells' 352 | Nothing -> return $ sheetCells s 353 | return $ (uiSetActiveFile f . uiResize cols rows) (s { sheetCells = cells' }) 354 | 355 | attrMapImpl :: BrickS -> AttrMap 356 | attrMapImpl _ = attrMap defAttr [ (blueBg, bg blue), 357 | (redBg, bg red), 358 | (greenBg, bg green), 359 | (yellowBg, bg yellow), 360 | (brightYellowBg, bg brightYellow) ] 361 | 362 | withAttrs :: [AttrName] -> Widget BrickN -> Widget BrickN 363 | withAttrs attrs w = foldr withAttr w attrs 364 | 365 | blueBg = attrName "blueBg" 366 | redBg = attrName "redBg" 367 | greenBg = attrName "greenBg" 368 | brightYellowBg = attrName "brightYellowBg" 369 | yellowBg = attrName "yellowBg" 370 | 371 | applyStandout :: Widget BrickN -> Widget BrickN 372 | applyStandout w = 373 | withAttr blueBg $ modifyDefAttr (flip withStyle standout) w 374 | 375 | safeGet :: [a] -> Int -> Maybe a 376 | safeGet xs i 377 | | length xs > i = Just $ xs !! i 378 | | otherwise = Nothing 379 | -------------------------------------------------------------------------------- /exe/Sheet/Frontend/Types.hs: -------------------------------------------------------------------------------- 1 | module Sheet.Frontend.Types where 2 | 3 | import Sheet.Backend.Standard 4 | 5 | import Brick.BChan 6 | import Brick.Widgets.Edit 7 | 8 | import qualified Data.Map as M 9 | 10 | -- | 'UISheet' defines the spreadsheet type. The functions in this UI 11 | -- submodule pass a value of this datatype along in a statewise matter. 12 | data UISheet = 13 | UISheet { 14 | activeFile :: Maybe String, 15 | 16 | sheetCells :: S, 17 | sheetCursor :: Pos, 18 | sheetOffset :: Pos, 19 | 20 | uiCols :: Int, 21 | uiRows :: Int, 22 | cWidth :: Int, 23 | 24 | screenWidth :: Int, 25 | screenHeight :: Int, 26 | 27 | uiMode :: UIMode, 28 | 29 | cellStatus :: M.Map Pos CellStatus, 30 | 31 | custEvChan :: BChan CustomEvent, 32 | showCellFeedbackTimeout :: Int -- in milliseconds 33 | } 34 | 35 | data UIMode = 36 | ModeNormal 37 | | ModeEdit { 38 | cellEditor :: Editor String String, 39 | cellEditorWidth :: Int 40 | } 41 | | ModeCommand { 42 | cmdEditor :: Editor String String, 43 | cmdEditorWidth :: Int 44 | } 45 | 46 | data CustomEvent = 47 | EvNewDefinition BackendJobResponse | 48 | EvVisualFeedback C CellStatus 49 | 50 | initUISheet :: BChan CustomEvent -> IO UISheet 51 | initUISheet customEvChan = do 52 | sheet <- initSheet (\j -> writeBChan customEvChan $ EvNewDefinition j) 53 | (\cell stat -> writeBChan customEvChan $ EvVisualFeedback cell stat) 54 | return $ UISheet { 55 | activeFile = Nothing, 56 | sheetCells = sheet, 57 | sheetCursor = (1,1), 58 | sheetOffset = (1,1), 59 | uiCols = 10, 60 | uiRows = 10, 61 | cWidth = 15, 62 | screenWidth = 80, 63 | screenHeight = 24, 64 | uiMode = ModeNormal, 65 | cellStatus = M.empty, 66 | custEvChan = customEvChan, 67 | showCellFeedbackTimeout = 500 68 | } 69 | -------------------------------------------------------------------------------- /imgs/example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RKlompUU/FPSheet/fb382ea209e81a49e4c2079f8a17a2dbcaba35a7/imgs/example.png -------------------------------------------------------------------------------- /lib/Sheet/Backend/SheetAbstr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, RankNTypes, 2 | ConstraintKinds, FlexibleContexts #-} 3 | module Sheet.Backend.SheetAbstr 4 | ( module Sheet.Backend.SheetAbstr 5 | , module Control.Monad 6 | , module Control.Monad.State 7 | , module Data.Functor.Identity 8 | ) where 9 | 10 | import Control.Monad 11 | import Control.Monad.State 12 | import Control.Monad.Reader 13 | 14 | import Data.Functor.Identity 15 | 16 | import Data.Map.Lazy 17 | 18 | import qualified Data.Set as S 19 | 20 | 21 | -- Annotated text (with for example explicit information about cells that are referred to) 22 | --class AnnText t where 23 | 24 | -- | The Spreadsheet API interface supplies toplevel functions. 25 | class (MonadState s m, Var var pos, Expr s m e var val pos, Cell s m c e var val dep pos) => Spreadsheet s m c e var val dep pos | s -> c, s -> var, s -> e, s -> m where 26 | -- | 'getSetCells' returns the list of thus far set cells 27 | getSetCells :: m [c] 28 | -- | 'getCell' retrieves a cell from the spreadsheet. 29 | getDepGraph :: [c] -> m [(pos,[pos])] 30 | getCell :: pos -> m c 31 | -- | 'setCell' sets a 'Cell' c in the spreadsheet at the 'Pos' that must be retrievable from within c. 32 | -- If a 'Cell' at the given 'Pos' was already present, it is overwritten. 33 | setCell :: c -> m c 34 | evalCells :: [c] -> m () 35 | -- | 'reval' reevalutes all Cells 36 | reval :: m () 37 | -- | 'importFile' loads an external format from disk (currently only supports .xlsx) 38 | importFile :: String -> Bool -> m () 39 | -- | 'save' saves the sheet state to disk (in FPSheet's own format) 40 | save :: String -> m () 41 | -- | 'load' loads the sheet state from disk (in FPSheet's own format) 42 | load :: String -> m () 43 | interrupt :: m () 44 | 45 | -- | The 'Cell' API interface supplies cell manipulation functions. 46 | class (MonadState s m, Var var pos, Expr s m e var val pos) => Cell s m c e var val dep pos | c -> e, c -> dep, c -> var, var -> m, e -> m where 47 | -- | 'evalCell' tries to evaluate the cell's content, in the context of the current spreadsheet's state. 48 | -- This is run in the state monad. 'evalCell' must change the evaluated cell in the spreadsheet state. Possibly, 49 | -- depending on the implementation choices made, it additionally re-evaluates those cells that are depending on a 50 | -- currently evaluated cell. 51 | -- | 'getEval' returns the evaluation that has been determined during 52 | evalCell :: c -> m () 53 | -- a prior call to 'evalCell' if it resulted in an evaluation. Otherwise 54 | -- 'getEval' returns 'Nothing'. 55 | getEval :: c -> Maybe String 56 | -- | 'getText' returns the text contents of a 'Cell'. 57 | getText :: c -> String 58 | -- | 'setText' sets textual definition of the cell (note: this does not trigger evaluation) 59 | setText :: String -> c -> m c 60 | -- | 'getCellPos' returns the position on the sheet of the cell 61 | getCellPos :: c -> pos 62 | -- | 'newCell' returns a new cell (probably an empty cell, but this is a choice left for the implementation). 63 | newCell :: pos -> c 64 | -- dependencies 65 | addCellDep :: c -> dep -> m () 66 | delCellDep :: c -> dep -> m () 67 | getCellDeps :: c -> m [c] 68 | 69 | -- | The 'Expr' API interface supplies expression manipulation functions. 70 | class (MonadState s m, Var var pos) => Expr s m e var val pos | e -> val, e -> pos, e -> var, var -> m, e -> m where 71 | refsInExpr :: e -> S.Set pos 72 | 73 | -- | The 'Var' API interface is currently purely used to allow for different 74 | -- kind of variable encodings within languages. Perhaps this part of the 75 | -- API should be extended with functions once some kind of annotated text 76 | -- mechanism has been added. 77 | class Var var pos where 78 | posToRef :: pos -> var 79 | -------------------------------------------------------------------------------- /lib/Sheet/Backend/Standard.hs: -------------------------------------------------------------------------------- 1 | module Sheet.Backend.Standard ( 2 | module Sheet.Backend.Standard.Impl, 3 | module Sheet.Backend.Standard.Types, 4 | module Sheet.Backend.Standard.Parsers, 5 | module Sheet.Backend.SheetAbstr 6 | ) where 7 | 8 | import Sheet.Backend.SheetAbstr 9 | import Sheet.Backend.Standard.Impl 10 | import Sheet.Backend.Standard.Types 11 | import Sheet.Backend.Standard.Parsers 12 | -------------------------------------------------------------------------------- /lib/Sheet/Backend/Standard/Deps.hs: -------------------------------------------------------------------------------- 1 | module Sheet.Backend.Standard.Deps where 2 | 3 | import Sheet.Backend.Standard.Types 4 | 5 | resolveDeps :: [(Pos,[Pos])] -> [Pos] 6 | resolveDeps cdeps = 7 | let res = map fst 8 | $ filter (\c -> not $ any (== fst c) 9 | $ (concatMap snd cdeps)) 10 | $ cdeps 11 | in if null res 12 | then [] 13 | else res ++ resolveDeps (filter (\c -> not $ any (== fst c) res) cdeps) 14 | -------------------------------------------------------------------------------- /lib/Sheet/Backend/Standard/Impl.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : SpreedSheet.Sheet 3 | Description : An experimental application of the spreadsheet API 4 | Stability : experimental 5 | -} 6 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, 7 | ScopedTypeVariables #-} 8 | module Sheet.Backend.Standard.Impl ( 9 | module Sheet.Backend.Standard.Impl, 10 | module Sheet.Backend.Standard.Types, 11 | ) where 12 | 13 | import Sheet.Backend.Standard.Saves 14 | import Sheet.Backend.Standard.Parsers 15 | 16 | import Data.Maybe 17 | import Data.Char 18 | import Data.List 19 | 20 | import Control.Monad 21 | import Control.Monad.Reader 22 | 23 | import qualified Data.Map as M 24 | import qualified Data.Set as S 25 | 26 | import Sheet.Backend.SheetAbstr 27 | import Sheet.Backend.Standard.Types 28 | import Sheet.Backend.Standard.Deps 29 | 30 | import Control.Concurrent.Chan 31 | import Control.Concurrent 32 | 33 | import qualified Language.Haskell.Interpreter as I 34 | 35 | import qualified Language.Haskell.Exts.Parser as P 36 | import qualified Language.Haskell.Exts.Syntax as P 37 | import qualified Language.Haskell.Exts.ExactPrint as P 38 | import qualified Language.Haskell.Exts.SrcLoc as P 39 | import qualified Language.Haskell.Exts.Pretty as P 40 | 41 | import Language.Haskell.Exts.Util 42 | 43 | import Control.Monad.Catch as MC 44 | 45 | 46 | instance Spreadsheet S StateTy C E VAR VAL (Dep Pos) Pos where 47 | getCell p = do 48 | cells <- s_cells <$> get 49 | return (maybe (newCell p) id (M.lookup p cells)) 50 | setCell c = do 51 | s <- get 52 | put $ s {s_cells = M.insert (c_pos c) c (s_cells s)} 53 | return c 54 | getDepGraph = walker [] 55 | where walker :: [Pos] -> [C] -> StateTy [(Pos,[Pos])] 56 | walker _ [] = return [] 57 | walker done cs = do 58 | deps <- mapM (\c -> (\deps -> (c_pos c, map c_pos deps)) 59 | <$> getCellDeps c) cs 60 | let done' = done ++ map fst deps 61 | next = filter (\p -> not $ any (== p) done') 62 | $ concatMap snd deps 63 | nextDeps <- mapM getCell next >>= walker done' 64 | return $ deps ++ nextDeps 65 | evalCells cs = do 66 | cdeps <- getDepGraph cs 67 | sortedDeps <- mapM getCell $ resolveDeps cdeps 68 | mapM_ (evalCell) sortedDeps 69 | getSetCells = do 70 | cells <- s_cells <$> get 71 | return $ M.elems cells 72 | importFile f simpleImport = do 73 | c <- liftIO $ importCells f simpleImport 74 | s <- get 75 | put $ s {s_cells = c} 76 | reval 77 | return () 78 | save f = do 79 | s <- get 80 | liftIO $ saveSheet s f 81 | load f = do 82 | res <- liftIO $ loadSheet f 83 | case res of 84 | Just save -> do 85 | s <- get 86 | put $ s {s_cells = save_cells save} 87 | reval 88 | Nothing -> return () 89 | reval = do 90 | s <- get 91 | put $ s { s_deps = M.empty } 92 | cs <- getSetCells 93 | mapM_ (\c -> setText (getText c) c) cs 94 | evalCells cs 95 | interrupt = do 96 | s <- get 97 | liftIO $ throwTo (s_ghciThread s) InterpreterInterrupt 98 | 99 | 100 | data Interrupt = InterpreterInterrupt 101 | deriving Show 102 | instance Exception Interrupt 103 | 104 | 105 | instance Cell S StateTy C E VAR VAL (Dep Pos) Pos where 106 | evalCell c = do 107 | let cPos = getCellPos c 108 | feedback <- s_visualFeedback <$> get 109 | liftIO $ feedback c CellUpdating 110 | -- Set uFlag to true, to prevent infinite recursion into cyclic cell dependencies 111 | jobChan <- s_jobsChan <$> get 112 | rangeableCells <- map (posToRef . getCellPos) 113 | <$> filter (not . null . getText) 114 | <$> getSetCells 115 | let (_, e) = preprocessCellDef (c_def c) rangeableCells 116 | let j = BackendJob (posToRef cPos) e $ 117 | \resCode res -> do 118 | c' <- getCell cPos 119 | setCell (c' { c_res = res }) 120 | case resCode of 121 | JobDefFailure -> liftIO $ feedback c' CellFailure 122 | JobShowFailure -> liftIO $ feedback c' CellDefined 123 | _ -> liftIO $ feedback c' CellSuccess 124 | return () 125 | liftIO $ writeChan jobChan j 126 | return () 127 | getEval = c_res 128 | getText = show . c_def 129 | setText str c = do 130 | let def = parseCellDef str 131 | rangeableCells <- map (posToRef . getCellPos) 132 | <$> filter (not . null . getText) 133 | <$> getSetCells 134 | let (oldRangeDeps, _) = preprocessCellDef (c_def c) rangeableCells 135 | let (newRangeDeps, _) = preprocessCellDef def rangeableCells 136 | let oldDeps = S.toList $ refsInExpr (c_def c) 137 | newDeps = S.toList $ refsInExpr def 138 | expired = map DepPos (oldDeps \\ newDeps) 139 | ++ (oldRangeDeps \\ newRangeDeps) 140 | appended = map DepPos (newDeps \\ oldDeps) 141 | ++ (newRangeDeps \\ oldRangeDeps) 142 | mapM_ (delCellDep c) expired 143 | mapM_ (addCellDep c) appended 144 | deps <- s_deps <$> get 145 | setCell (c {c_def = def}) 146 | getCellPos = c_pos 147 | newCell p = CellT (LetDef "") Nothing False p 148 | addCellDep c dep = do 149 | s <- get 150 | let deps = maybe [] id (M.lookup (c_pos c) (s_deps s)) 151 | put $ s {s_deps = M.insert (c_pos c) (dep:deps) (s_deps s)} 152 | delCellDep c dep = do 153 | s <- get 154 | let deps = maybe [] id (M.lookup (c_pos c) (s_deps s)) 155 | put $ s {s_deps = M.insert (c_pos c) (filter (/= dep) deps) (s_deps s)} 156 | getCellDeps c 157 | | cellDefHasExpr (c_def c) = do 158 | s <- get 159 | mapM getCell $ 160 | nub $ 161 | M.keys $ 162 | M.filter (any (posInDep (c_pos c))) (s_deps s) 163 | | otherwise = do 164 | filter (cellDefHasExpr . c_def) 165 | <$> getSetCells 166 | where cellDefHasExpr (LetDef _) = True 167 | cellDefHasExpr (IODef _) = True 168 | cellDefHasExpr _ = False 169 | 170 | 171 | posInDep :: Pos -> Dep Pos -> Bool 172 | posInDep _ DepAll = True 173 | posInDep p (DepPos depAt) = p == depAt 174 | posInDep p (DepRange depFrom depTo) = 175 | col p >= col depFrom && col p <= col depTo && 176 | row p >= row depFrom && row p <= row depTo 177 | posInDep p (DepRangeDown depFrom) = 178 | col p == col depFrom && 179 | row p >= row depFrom 180 | 181 | 182 | instance Var VAR Pos where 183 | posToRef (c,r) = 184 | toCol c ++ show r 185 | instance Expr S StateTy E VAR VAL Pos where 186 | refsInExpr (LetDef str) = 187 | case P.parseExp str of 188 | P.ParseFailed _ _ -> S.empty 189 | P.ParseOk p -> 190 | let fv = freeVars p 191 | in S.map fromJust 192 | $ S.filter isJust 193 | $ S.map fv2Pos fv 194 | where fv2Pos (P.Ident _ var) = parsePos var 195 | fv2Pos (P.Symbol _ _) = Nothing 196 | refsInExpr (IODef str) = 197 | case P.parseExp str of 198 | P.ParseFailed _ _ -> S.empty 199 | P.ParseOk p -> 200 | let fv = freeVars p 201 | in S.map fromJust 202 | $ S.filter isJust 203 | $ S.map fv2Pos fv 204 | where fv2Pos (P.Ident _ var) = parsePos var 205 | fv2Pos (P.Symbol _ _) = Nothing 206 | refsInExpr _ = S.empty 207 | 208 | 209 | -- | 'resetUpdateFields' removes the update flags of all cells. 210 | resetUpdateFields :: S -> S 211 | resetUpdateFields s = s {s_cells = M.map (\c -> c {c_uFlag = False}) (s_cells s)} 212 | 213 | 214 | -- | Subtraction on 'Pos' variables. 215 | posSubtr :: Pos -> Pos -> Pos 216 | posSubtr (r1,c1) (r2,c2) = (r1-r2,c1-c2) 217 | 218 | 219 | -- | Addition on 'Pos' variables. 220 | posAdd :: Pos -> Pos -> Pos 221 | posAdd (r1,c1) (r2,c2) = (r1+r2,c1+c2) 222 | 223 | 224 | -- | 'sliceList' grabs a part of list 'xs' that ranges from index 'from' to 225 | -- index 'to'. 226 | sliceList :: Int -> Int -> [a] -> [a] 227 | sliceList from to xs = 228 | take (to - from + 1) (drop from xs) 229 | 230 | 231 | -- | 'subLists' slices a list 'xs', where each slice has a length of at most 232 | -- 'i'. 233 | subLists :: Int -> [a] -> [[a]] 234 | subLists i xs = 235 | let is = [0,i..(length xs - 1)] 236 | in map (\i' -> sliceList i' (i'+i-1) xs) is 237 | 238 | 239 | initSheet :: (BackendJobResponse -> IO ()) -> (C -> CellStatus -> IO ()) -> IO S 240 | initSheet asyncResFunc visualFeedbackFunc = do 241 | jobChan <- newChan 242 | resChan <- newChan 243 | ghciThreadID <- forkIO (ghciThread jobChan asyncResFunc) 244 | return $ Sheet M.empty M.empty jobChan visualFeedbackFunc ghciThreadID 245 | 246 | 247 | data IState = IState { 248 | istate_imports :: [String], 249 | istate_loads :: [String], 250 | istate_exts :: [I.Extension] 251 | } deriving Show 252 | 253 | 254 | ghciThread :: ChanJobs -> (BackendJobResponse -> IO ()) -> IO () 255 | ghciThread jobs respF = do 256 | crash <- I.runInterpreter $ do 257 | I.setImports ["Prelude"] 258 | liftIO $ ghciLog $ ";\n;\n" 259 | let initState = IState ["Prelude"] [] [] 260 | flip loop initState $ \state -> do 261 | flip MC.catch (catchInterrupt state) $ do 262 | j <- liftIO $ readChan jobs 263 | 264 | liftIO $ ghciLog $ 265 | "------------------------\nNew job:\n" 266 | 267 | (state', res') <- case bJob_cDef j of 268 | LetDef str -> letdef j str state 269 | Import str -> importModule j str state 270 | Load str -> loadModule j str state 271 | IODef str -> iodef j str state 272 | LanguageExtension ext -> addExtension j (read ext) state 273 | liftIO $ respF res' 274 | return state' 275 | ghciLog (show crash) 276 | return () 277 | where catchDefErr :: IState -> BackendJob -> SomeException -> I.Interpreter (IState, BackendJobResponse) 278 | catchDefErr s j e = do 279 | liftIO $ ghciLog ("***********\n" ++ show e ++ "\n*************\n") 280 | I.runStmt $ "let " ++ bJob_cName j ++ " = undefined" 281 | return $ (s, BackendJobResponse (bJob_resBody j JobDefFailure Nothing)) 282 | catchShowErr :: IState -> BackendJob -> SomeException -> I.Interpreter (IState, BackendJobResponse) 283 | catchShowErr s j e = do 284 | liftIO $ ghciLog ("\t" ++ show e ++ "\n") 285 | return $ (s, BackendJobResponse (bJob_resBody j JobShowFailure Nothing)) 286 | catchModulesErr :: IState -> BackendJob -> SomeException -> I.Interpreter (IState, BackendJobResponse) 287 | catchModulesErr s j e = do 288 | liftIO $ ghciLog ("\t" ++ show e ++ "\n") 289 | I.setImports $ istate_imports s 290 | return $ (s, BackendJobResponse (bJob_resBody j JobShowFailure Nothing)) 291 | 292 | catchInterrupt :: a -> Interrupt -> I.Interpreter a 293 | catchInterrupt x e = return x 294 | 295 | importModule :: BackendJob -> String -> IState -> I.Interpreter (IState, BackendJobResponse) 296 | importModule j m s = do 297 | let i' = nub $ m : istate_imports s 298 | let s' = s { istate_imports = i' } 299 | flip MC.catch (catchModulesErr s j) $ do 300 | I.setImports i' 301 | return $ (s', BackendJobResponse (bJob_resBody j JobSuccess (Just m))) 302 | 303 | loadModule :: BackendJob -> String -> IState -> I.Interpreter (IState, BackendJobResponse) 304 | loadModule j m s = do 305 | let l' = nub $ m : istate_loads s 306 | let s' = s { istate_loads = l' } 307 | flip MC.catch (catchModulesErr s j) $ do 308 | I.loadModules l' 309 | I.setImports $ istate_imports s' 310 | I.setTopLevelModules $ map (\m_ -> take (fromJust . findIndex (=='.') $ m_) m_) l' 311 | return $ (s', BackendJobResponse (bJob_resBody j JobSuccess (Just m))) 312 | 313 | addExtension :: BackendJob -> I.Extension -> IState -> I.Interpreter (IState, BackendJobResponse) 314 | addExtension j ext s = do 315 | let exts' = nub $ ext : istate_exts s 316 | let s' = s { istate_exts = exts' } 317 | flip MC.catch (catchModulesErr s j) $ do 318 | I.set [I.languageExtensions I.:= exts'] 319 | return $ (s', BackendJobResponse (bJob_resBody j JobSuccess (Just $ show ext))) 320 | 321 | iodef :: BackendJob -> String -> IState -> I.Interpreter (IState, BackendJobResponse) 322 | iodef j cdef s = do 323 | let ioDef = bJob_cName j ++ " <- " ++ cdef 324 | liftIO $ ghciLog $ 325 | "\t" ++ ioDef ++ "\n" 326 | flip MC.catch (catchDefErr s j) $ do 327 | I.runStmt ioDef 328 | liftIO $ ghciLog $ 329 | "\tioDef executed\n" 330 | 331 | flip MC.catch (catchShowErr s j) $ do 332 | res <- I.eval (bJob_cName j) 333 | liftIO $ ghciLog $ 334 | "\tres: " ++ show res ++ "\n" 335 | return $ (s, BackendJobResponse (bJob_resBody j JobSuccess (Just res))) 336 | 337 | letdef :: BackendJob -> String -> IState -> I.Interpreter (IState, BackendJobResponse) 338 | letdef j cdef s = do 339 | let letDef = "let " ++ bJob_cName j ++ " = " ++ cdef 340 | liftIO $ ghciLog $ 341 | "\t" ++ letDef ++ "\n" 342 | flip MC.catch (catchDefErr s j) $ do 343 | I.runStmt letDef 344 | 345 | liftIO $ ghciLog $ 346 | "\tletDef executed\n" 347 | 348 | flip MC.catch (catchShowErr s j) $ do 349 | res <- I.eval (bJob_cName j) 350 | liftIO $ ghciLog $ 351 | "\tres: " ++ show res ++ "\n" 352 | return $ (s, BackendJobResponse (bJob_resBody j JobSuccess (Just res))) 353 | 354 | 355 | ghciLog :: String -> IO () 356 | ghciLog str = do 357 | appendFile "/tmp/fpsheet_ghci.log" str 358 | 359 | 360 | appLog :: String -> IO () 361 | appLog str = do 362 | appendFile "/tmp/fpsheet_app.log" str 363 | 364 | 365 | loop :: Monad m => (a -> m a) -> a -> m a 366 | loop action x = action x >>= loop action 367 | 368 | 369 | preprocessCellDef :: CellDef -> [String] -> ([Dep Pos], CellDef) 370 | preprocessCellDef (LetDef str) rangeableCells = 371 | let (dependencyRanges, str') = preprocessExprStr str rangeableCells 372 | in (dependencyRanges, LetDef str') 373 | preprocessCellDef (IODef str) rangeableCells = 374 | let (dependencyRanges, str') = preprocessExprStr str rangeableCells 375 | in (dependencyRanges, IODef str') 376 | preprocessCellDef def _ = ([], def) 377 | 378 | 379 | preprocessExprStr :: String -> [String] -> ([Dep Pos], String) 380 | preprocessExprStr eStr rangeableCells = 381 | case P.parseExp eStr of 382 | P.ParseFailed _ _ -> ([], eStr) 383 | P.ParseOk p -> 384 | let (dependencyRanges, p') = preprocessExpr p [] rangeableCells 385 | in (dependencyRanges, P.prettyPrintStyleMode (P.style {P.mode = P.LeftMode}) P.defaultMode p') 386 | 387 | 388 | preprocessExpr :: P.Exp P.SrcSpanInfo -> [String] -> [String] -> ([Dep Pos], P.Exp P.SrcSpanInfo) 389 | preprocessExpr e@(P.EnumFromTo _ enumFrom enumTo) unfree rangeableCells = 390 | let posFrom = posRef enumFrom 391 | posTo = posRef enumTo 392 | deps = 393 | if isJust posFrom && isJust posTo 394 | then [DepRange (fromJust posFrom) (fromJust posTo)] 395 | else [] 396 | rangeCells = 397 | if isJust posFrom && isJust posTo 398 | then let r = filter (\c -> any (==c) rangeableCells) 399 | $ map posToRef 400 | $ rangePos (fromJust posFrom) (fromJust posTo) 401 | in if isInfixOf r unfree 402 | then Nothing 403 | else Just r 404 | else Nothing 405 | in if isJust rangeCells 406 | then (,) deps 407 | $ P.List P.noSrcSpan 408 | $ map (P.Var P.noSrcSpan . P.UnQual P.noSrcSpan . P.Ident P.noSrcSpan) 409 | $ fromJust rangeCells 410 | else (deps, e) 411 | preprocessExpr e@(P.EnumFrom l enumFrom) unfree rangeableCells = 412 | let posFrom = posRef enumFrom 413 | deps = 414 | if isJust posFrom 415 | then [DepRangeDown (fromJust posFrom)] 416 | else [] 417 | rangeCells = 418 | if isJust posFrom 419 | then let maxPos = maximum 420 | $ (:) (fromJust posFrom) 421 | $ filter (\(c,_) -> c == (col . fromJust) posFrom) 422 | $ map (fromJust . parsePos) rangeableCells 423 | r = filter (\c -> any (==c) rangeableCells) 424 | $ map posToRef 425 | $ rangePos (fromJust posFrom) maxPos 426 | in if isInfixOf r unfree 427 | then Nothing 428 | else Just r 429 | else Nothing 430 | in if isJust rangeCells 431 | then (,) deps 432 | $ P.List P.noSrcSpan 433 | $ map (P.Var P.noSrcSpan . P.UnQual P.noSrcSpan . P.Ident P.noSrcSpan) 434 | $ fromJust rangeCells 435 | else (deps, e) 436 | preprocessExpr (P.App l e1 e2) unfree rangeableCells = 437 | let (rs1, e1') = preprocessExpr e1 unfree rangeableCells 438 | (rs2, e2') = preprocessExpr e2 unfree rangeableCells 439 | in (rs1++rs2, P.App l e1' e2') 440 | preprocessExpr (P.Let l binds e) unfree rangeableCells = 441 | let v = map unName 442 | $ S.toList 443 | $ bound 444 | $ allVars binds 445 | (rs, e') = preprocessExpr e (unfree ++ v) rangeableCells 446 | in (rs, P.Let l binds e') 447 | preprocessExpr (P.InfixApp l e1 op e2) unfree rangeableCells = 448 | let (rs1, e1') = preprocessExpr e1 unfree rangeableCells 449 | (rs2, e2') = preprocessExpr e2 unfree rangeableCells 450 | in (rs1++rs2, P.InfixApp l e1' op e2') 451 | preprocessExpr (P.Lambda l patterns e) unfree rangeableCells = 452 | let v = map unName 453 | $ S.toList 454 | $ bound 455 | $ allVars patterns 456 | (rs, e') = preprocessExpr e (unfree ++ v) rangeableCells 457 | in (rs, P.Lambda l patterns e') 458 | preprocessExpr e _ _ = ([], e) 459 | 460 | 461 | unName :: P.Name l -> String 462 | unName (P.Ident _ n) = n 463 | unName (P.Symbol _ n) = n 464 | 465 | 466 | posRef :: P.Exp P.SrcSpanInfo -> Maybe Pos 467 | posRef (P.Var _ (P.UnQual _ (P.Ident _ str))) = parsePos str 468 | posRef _ = Nothing 469 | 470 | 471 | rangePos :: Pos -> Pos -> [Pos] 472 | rangePos (c1,r1) (c2,r2) = 473 | [(c, r) | c <- [c1..c2], r <- [r1..r2]] 474 | 475 | 476 | col :: Pos -> Int 477 | col = fst 478 | 479 | 480 | row :: Pos -> Int 481 | row = snd 482 | -------------------------------------------------------------------------------- /lib/Sheet/Backend/Standard/Parsers.hs: -------------------------------------------------------------------------------- 1 | module Sheet.Backend.Standard.Parsers where 2 | 3 | import Control.Monad 4 | import Data.Maybe 5 | import Data.Char 6 | import ParseLib.Simple hiding ((>>=)) 7 | import Prelude hiding ((<$>), (<*>), (<*), (*>)) 8 | 9 | import Sheet.Backend.Standard.Types 10 | 11 | 12 | type SParser a = Parser Char a 13 | 14 | parseCellDef :: String -> CellDef 15 | parseCellDef str = 16 | let res = filter (null . snd) 17 | $ parse cellDefParser str 18 | in fst $ head $ res 19 | 20 | cellDefParser :: SParser CellDef 21 | cellDefParser = 22 | IODef <$> (symbol '`' *> many anySymbol <* symbol '`') 23 | <|> Import <$> (token ":m" *> pWhitespace *> many anySymbol) 24 | <|> Load <$> (token ":l" *> pWhitespace *> many anySymbol) 25 | <|> LanguageExtension <$> (token ":e" *> pWhitespace *> many anySymbol) 26 | <|> LetDef <$> greedy anySymbol 27 | 28 | parsePos :: String -> Maybe Pos 29 | parsePos str = 30 | let res = filter (null . snd) 31 | $ parse posParser str 32 | in if null res 33 | then Nothing 34 | else Just $ fst $ head $ res 35 | 36 | posParser :: SParser Pos 37 | posParser = 38 | (,) <$> pCol <*> pRow 39 | 40 | -- Might write this better (if it can be done better) later. 41 | -- For now a copy paste from: 42 | -- https://stackoverflow.com/questions/40950853/excel-column-to-int-and-vice-versa-improvements-sought 43 | -- 44 | -- given a spreadsheet column as a string 45 | -- returns integer giving the position of the column 46 | -- ex: 47 | -- toInt "A" = 1 48 | -- toInt "XFD" = 16384 49 | toInt :: String -> Int 50 | toInt = foldl fn 0 51 | where 52 | fn = \a c -> 26*a + ((ord c)-(ord 'a' - 1)) 53 | 54 | toCol :: Int -> String 55 | toCol c = ([0..] >>= flip replicateM ['a'..'z']) !! c 56 | 57 | pCol :: SParser Int 58 | pCol = 59 | toInt <$> some (satisfy (\c -> any (== c) ['a'..'z'])) 60 | pRow :: SParser Int 61 | pRow = 62 | natural 63 | 64 | pWhitespace = 65 | let wspace = [' ','\t','\n','\r'] 66 | in const () <$> greedy1 (satisfy (flip elem wspace)) 67 | 68 | -------------------------------------------------------------------------------- /lib/Sheet/Backend/Standard/Saves.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Sheet.Backend.Standard.Saves where 3 | 4 | import Sheet.Backend.Standard.Types 5 | 6 | import qualified Data.ByteString.Lazy as L 7 | import Codec.Xlsx 8 | --import Codec.Xlsx.Types 9 | 10 | import Control.Lens 11 | import qualified Data.Map as M 12 | import qualified Data.Text as T 13 | import Data.Tuple 14 | 15 | import Control.Applicative 16 | 17 | import Data.Aeson 18 | import qualified Data.Text.Lazy.Encoding as T 19 | import qualified Data.Text.Lazy.IO as T 20 | 21 | 22 | saveSheet :: Sheet C -> String -> IO () 23 | saveSheet s f = do 24 | let save = Save (s_cells s) 25 | T.writeFile f $ T.decodeUtf8 . encode $ save 26 | 27 | 28 | loadSheet :: String -> IO (Maybe Save) 29 | loadSheet f = do 30 | decode . T.encodeUtf8 <$> T.readFile f 31 | 32 | 33 | importCells :: String -> Bool -> IO (M.Map Pos C) 34 | importCells f simpleImport = do 35 | xlsxC <- loadXlsxCells f 36 | return 37 | $ M.mapKeys swap 38 | $ M.mapWithKey (fromXlsxCell simpleImport) xlsxC 39 | 40 | 41 | loadXlsxCells :: String -> IO CellMap 42 | loadXlsxCells f = do 43 | bs <- L.readFile f 44 | let xlsx = toXlsx bs 45 | mainSheet :: Worksheet 46 | mainSheet = snd $ head $ xlsx ^. xlSheets 47 | return $ mainSheet ^. wsCells 48 | 49 | 50 | fromXlsxCell :: Bool -> Pos -> Cell -> C 51 | fromXlsxCell simpleImport (row, col) cell = 52 | let content = (if simpleImport 53 | then empty 54 | else unCellExpression <$> _cellfExpression <$> cell ^. cellFormula) 55 | <|> unCellValue <$> cell ^. cellValue 56 | in CellT { 57 | c_def = maybe (LetDef "failed") LetDef content, 58 | c_res = Nothing, 59 | c_uFlag = False, 60 | c_pos = (col, row) 61 | } 62 | 63 | 64 | unCellValue :: CellValue -> String 65 | unCellValue (CellText x) = 66 | T.unpack x 67 | unCellValue (CellDouble x) = 68 | show x 69 | unCellValue (CellBool x) = 70 | show x 71 | unCellValue (CellRich xs) = 72 | show xs 73 | unCellValue (CellError err) = 74 | show err 75 | 76 | 77 | unCellExpression :: FormulaExpression -> String 78 | unCellExpression (NormalFormula formula) = 79 | T.unpack $ unFormula formula 80 | unCellExpression (SharedFormula formula) = 81 | unCellExpression $ _cellfExpression $ sharedFormulaByIndex formula 82 | -------------------------------------------------------------------------------- /lib/Sheet/Backend/Standard/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} 2 | {-| 3 | Module : Sheet.Backend.Types 4 | Description : A Sheet datatype, that contains a grid of cells 5 | Stability : experimental 6 | -} 7 | module Sheet.Backend.Standard.Types where 8 | 9 | import Control.Concurrent 10 | import Control.Concurrent.Chan 11 | 12 | import qualified GHC.Generics as GHC 13 | import qualified Language.Haskell.Interpreter as HInt 14 | 15 | import Data.Aeson 16 | import Data.Map (Map) 17 | import Data.Set (Set) 18 | import qualified Data.Map as M 19 | 20 | import Sheet.Backend.SheetAbstr 21 | 22 | 23 | -- | Each Cell is positioned on a 2-dimensional grid. Its position is 24 | -- defined by the ith col and jth row, where i and j are \"(i, j) :: 'Pos'\" 25 | type Pos = (Int,Int) 26 | 27 | data CellStatus = 28 | CellSuccess 29 | | CellDefined 30 | | CellUpdating 31 | | CellFailure 32 | | CellNoStatus 33 | 34 | data CellDef = 35 | LetDef String 36 | | Import String 37 | | Load String 38 | | IODef String 39 | | LanguageExtension String 40 | deriving (GHC.Generic, FromJSON, ToJSON, Eq) 41 | 42 | instance Show CellDef where 43 | show (LetDef str) = str 44 | show (IODef str) = "`" ++ str ++ "`" 45 | show (Load str) = ":l " ++ str 46 | show (Import str) = ":m " ++ str 47 | show (LanguageExtension str) = ":e " ++ str 48 | 49 | data CellT e = 50 | CellT { c_def :: e -- |User defined cell's text 51 | , c_res :: Maybe String -- |The result of the last evaluation of cStr 52 | , c_uFlag :: Bool -- |Cell has changed, used to check if an input field needs to be refreshed by the frontend 53 | , c_pos :: Pos 54 | } deriving (GHC.Generic, Show, FromJSON, ToJSON) 55 | 56 | data Sheet c = 57 | Sheet { s_cells :: Map Pos c 58 | , s_deps :: Map Pos [Dep Pos] 59 | , s_jobsChan :: ChanJobs 60 | , s_visualFeedback :: c -> CellStatus -> IO () 61 | , s_ghciThread :: ThreadId 62 | } 63 | 64 | type ExprT v = CellDef 65 | 66 | type VarT = String 67 | 68 | type VAR = VarT 69 | type VAL = String 70 | type E = ExprT VAR 71 | type C = CellT E 72 | type S = Sheet C 73 | 74 | data Save = 75 | Save { save_cells :: Map Pos C } 76 | deriving (GHC.Generic, FromJSON, ToJSON) 77 | 78 | type StateTy = StateT S IO 79 | 80 | type ChanJobs = Chan BackendJob 81 | type ChanResps = Chan BackendJobResponse 82 | 83 | data BackendJob = 84 | BackendJob { 85 | bJob_cName :: String, 86 | bJob_cDef :: CellDef, 87 | 88 | bJob_resBody :: JobResCode -> Maybe String -> StateTy () 89 | } 90 | 91 | data BackendJobResponse = 92 | BackendJobResponse { 93 | bJobRes :: StateTy () 94 | } 95 | 96 | data JobResCode = 97 | JobDefFailure | 98 | JobShowFailure | 99 | JobSuccess 100 | 101 | data Eq pos => Dep pos = 102 | DepPos pos | 103 | DepRange pos pos | 104 | DepRangeDown pos | 105 | DepAll 106 | deriving (Eq) 107 | 108 | instance (Show pos, Eq pos) => Show (Dep pos) where 109 | show (DepPos pos) = show pos 110 | show (DepRange from to) = show from ++ " -> " ++ show to 111 | show (DepRangeDown from) = show from ++ " -> .." 112 | show DepAll = "all" 113 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-12.13 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | extra-deps: 42 | - hint-0.9.0 43 | - uu-tc-2015.1.1 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=1.7" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | import PropertyTests 2 | import UnitTests 3 | 4 | 5 | main :: IO () 6 | main = do 7 | allUnitTests 8 | putStrLn "Done" 9 | -------------------------------------------------------------------------------- /test/PropertyTests.hs: -------------------------------------------------------------------------------- 1 | module PropertyTests where 2 | 3 | import Test.QuickCheck 4 | -------------------------------------------------------------------------------- /test/UnitTests.hs: -------------------------------------------------------------------------------- 1 | module UnitTests where 2 | 3 | import Test.Hspec 4 | 5 | import Sheet.Backend.Standard.Deps 6 | import Sheet.Backend.Standard.Parsers 7 | import Sheet.Backend.Standard.Types 8 | 9 | 10 | allUnitTests :: IO () 11 | allUnitTests = do 12 | resolveDepsTests 13 | parseCellDefTests 14 | parsePosTests 15 | 16 | 17 | parsePosTests :: IO () 18 | parsePosTests = hspec $ do 19 | describe "parse cell positions" $ do 20 | it "parseable" $ do 21 | parsePos "a1" `shouldBe` Just (1, 1) 22 | parsePos "a2" `shouldBe` Just (1, 2) 23 | parsePos "b1" `shouldBe` Just (2, 1) 24 | parsePos "b2" `shouldBe` Just (2, 2) 25 | parsePos "b10" `shouldBe` Just (2, 10) 26 | parsePos "aa10" `shouldBe` Just (27, 10) 27 | parsePos "ab10" `shouldBe` Just (28, 10) 28 | parsePos "ab11" `shouldBe` Just (28, 11) 29 | it "not parseable (empty)" $ do 30 | parsePos "" `shouldBe` Nothing 31 | it "not parseable (wrong order)" $ do 32 | parsePos "1a" `shouldBe` Nothing 33 | it "not parseable (missing row)" $ do 34 | parsePos "a" `shouldBe` Nothing 35 | it "not parseable (missing col)" $ do 36 | parsePos "1" `shouldBe` Nothing 37 | it "not parseable (bad trailing character)" $ do 38 | parsePos "a1a" `shouldBe` Nothing 39 | 40 | 41 | parseCellDefTests :: IO () 42 | parseCellDefTests = hspec $ do 43 | describe "parse cell definitions" $ do 44 | it "let def" $ do 45 | parseCellDef "x = 4" `shouldBe` LetDef "x = 4" 46 | parseCellDef "x = 'a'" `shouldBe` LetDef "x = 'a'" 47 | it "import" $ do 48 | parseCellDef ":m ALibModule.hs" `shouldBe` Import "ALibModule.hs" 49 | it "load" $ do 50 | parseCellDef ":l ACustomModule.hs" `shouldBe` Load "ACustomModule.hs" 51 | it "IO statement" $ do 52 | parseCellDef "`function 'a' 3`" `shouldBe` IODef "function 'a' 3" 53 | it "language extension" $ do 54 | parseCellDef ":e SomeExt" `shouldBe` LanguageExtension "SomeExt" 55 | 56 | 57 | resolveDepsTests :: IO () 58 | resolveDepsTests = hspec $ do 59 | describe "dependency resolver" $ do 60 | it "resolves to root only if no dependencies" $ do 61 | resolveDeps [ 62 | ((0,0),[]) 63 | ] `shouldBe` [(0,0)] 64 | it "resolves to root + root's dependencies (if no further deps)" $ do 65 | resolveDeps [ 66 | ((0,0),[(0,1)]), 67 | ((0,1),[]) 68 | ] `shouldBe` [(0,0),(0,1)] 69 | resolveDeps [ 70 | ((0,0),[(0,1),(0,2)]), 71 | ((0,1),[]), 72 | ((0,2),[]) 73 | ] `shouldSatisfy` \res -> 74 | res == [(0,0),(0,1),(0,2)] 75 | || res == [(0,0),(0,2),(0,1)] 76 | it "resolves to root + nested dependencies (simple: acyclic)" $ do 77 | resolveDeps [ 78 | ((0,0),[(0,1)]), 79 | ((0,2),[(1,0)]), 80 | ((1,0),[]) 81 | ] `shouldBe` [(0,0),(0,2),(1,0)] 82 | resolveDeps [ 83 | ((0,0),[(0,1)]), 84 | ((0,2),[(1,0),(2,0)]), 85 | ((1,0),[]), 86 | ((2,0),[]) 87 | ] `shouldSatisfy` \res -> 88 | res == [(0,0),(0,2),(1,0),(2,0)] 89 | || res == [(0,0),(0,2),(2,0),(1,0)] 90 | it "cyclic: intra looping cell (and dependencies of) is ignored" $ do 91 | resolveDeps [ 92 | ((0,0),[(0,0)]) 93 | ] `shouldBe` [] 94 | resolveDeps [ 95 | ((0,0),[(0,0)]), 96 | ((0,1),[]) 97 | ] `shouldBe` [(0,1)] 98 | it "cyclic: intra looping cell (and dependencies of) is ignored" $ do 99 | resolveDeps [ 100 | ((0,0),[(0,1),(0,0)]), 101 | ((0,1),[]) 102 | ] `shouldBe` [] 103 | it "cyclic: inter looping cells are ignored" $ do 104 | resolveDeps [ 105 | ((0,0),[(0,1)]), 106 | ((0,1),[(0,0)]) 107 | ] `shouldBe` [] 108 | resolveDeps [ 109 | ((0,0),[(0,1)]), 110 | ((0,1),[(0,0)]), 111 | ((0,2),[]) 112 | ] `shouldBe` [(0,2)] 113 | -------------------------------------------------------------------------------- /watchAppLog.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | tail -F /tmp/fpsheet_app.log 4 | -------------------------------------------------------------------------------- /watchGhciLog.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | tail -F /tmp/fpsheet_ghci.log 4 | --------------------------------------------------------------------------------