add saving/loading

.gitignore

@@ -5,6 +5,7 @@ assets/*.svg
 assets/*/
 refs/
 img/examples
+files/
 
 *.txt
 *.md

MetaBrush.cabal

@@ -132,10 +132,14 @@ executable MetaBrush
 
     build-depends:
         MetaBrush
+      , atomic-file-ops
+          ^>= 0.3.0.0
       , bytestring
           ^>= 0.10.10.1
       , directory
           >= 1.3.4.0 && < 1.4
+      , filepath
+          ^>= 1.4.2.1
       , gi-gdk
           >= 3.0.22 && < 3.1
       , gi-gio

src/app/MetaBrush/Action.hs

@@ -6,29 +6,20 @@
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
-module MetaBrush.Action
+module MetaBrush.Action where
-  ( HandleAction(..)
-  , quitEverything
-  , NewFile(..), OpenFile(..), Save(..), SaveAs(..), Close(..), Quit(..)
-  , Undo(..), Redo(..), Cut(..), Copy(..), Paste(..), Duplicate(..), Delete(..)
-  , Confirm(..)
-  , About(..)
-  , MouseMove(..), MouseClick(..), MouseRelease(..)
-  , Scroll(..), KeyboardPress(..), KeyboardRelease(..)
-  )
-  where
 
 -- base
 import Control.Monad
-  ( guard, unless, void )
+  ( guard, when, unless, void )
 import Data.Foldable
   ( for_ )
 import Data.Maybe
-  ( catMaybes )
+  ( catMaybes, listToMaybe)
 import Data.Word
   ( Word32 )
 
@@ -41,6 +32,8 @@ import Data.Act
   )
 
 -- containers
+import qualified Data.Map as Map
+  ( insert )
 import Data.Sequence
   ( Seq(..) )
 import qualified Data.Sequence as Seq
@@ -48,6 +41,14 @@ import qualified Data.Sequence as Seq
 import qualified Data.Set as Set
   ( insert, delete )
 
+-- directory
+import System.Directory
+  ( doesDirectoryExist, listDirectory )
+
+-- filepath
+import System.FilePath
+  ( (</>), (<.>), takeExtension )
+
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
@@ -71,7 +72,7 @@ import MetaBrush.Context
   ( UIElements(..), Variables(..)
   , Modifier(..), modifierKey
   , HoldAction(..), PartialPath(..)
-  , withCurrentDocument, modifyingCurrentDocument
+  , currentDocument, withCurrentDocument, modifyingCurrentDocument
   )
 import MetaBrush.Document
   ( Document(..)
@@ -86,6 +87,8 @@ import MetaBrush.Document.Selection
   , translateSelection
   , deleteSelected
   )
+import MetaBrush.Document.Serialise
+  ( saveDocument, loadDocument )
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
 import MetaBrush.UI.InfoBar
@@ -125,7 +128,56 @@ data OpenFile = OpenFile TabLocation
   deriving stock Show
 
 instance HandleAction OpenFile where
-  handleAction _ _ _ = pure ()
+  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFile tabLoc ) = do
+    fileChooser <-
+      GTK.fileChooserNativeNew ( Just "Open MetaBrush document..." ) ( Just window )
+        GTK.FileChooserActionOpen
+        ( Just "Open" )
+        ( Just "Cancel" )
+    GTK.fileChooserSetSelectMultiple fileChooser True
+    GTK.nativeDialogSetModal fileChooser True
+    fileFilter <- GTK.fileFilterNew
+    GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
+    GTK.fileFilterAddPattern fileFilter "*.mb"
+    GTK.fileChooserAddFilter fileChooser fileFilter
+    void $ GTK.nativeDialogRun fileChooser
+    filePaths <- GTK.fileChooserGetFilenames fileChooser
+    for_ filePaths \ filePath -> do
+      mbDoc <- loadDocument uniqueSupply filePath
+      case mbDoc of
+        Left _errMessage -> pure () -- TODO: show warning dialog?
+        Right doc -> do
+          newFileTab vars uiElts ( Just doc ) tabLoc
+
+-----------------
+-- Open folder --
+-----------------
+
+data OpenFolder = OpenFolder TabLocation
+  deriving stock Show
+
+instance HandleAction OpenFolder where
+  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFolder tabLoc ) = do
+    fileChooser <-
+      GTK.fileChooserNativeNew ( Just "Select folder..." ) ( Just window )
+        GTK.FileChooserActionSelectFolder
+        ( Just "Select Folder" )
+        ( Just "Cancel" )
+    GTK.fileChooserSetSelectMultiple fileChooser True
+    GTK.nativeDialogSetModal fileChooser True
+    void $ GTK.nativeDialogRun fileChooser
+    folderPaths <- GTK.fileChooserGetFilenames fileChooser
+    for_ folderPaths \ folderPath -> do
+      exists <- doesDirectoryExist folderPath
+      when exists do
+        filePaths <- listDirectory folderPath
+        for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
+          mbDoc <- loadDocument uniqueSupply ( folderPath </> filePath )
+          case mbDoc of
+            Left _errMessage -> pure () -- TODO: show warning dialog?
+            Right doc -> do
+              newFileTab vars uiElts ( Just doc ) tabLoc
+    pure ()
 
 ---------------
 -- Save file --
@@ -134,9 +186,24 @@ instance HandleAction OpenFile where
 data Save = Save
   deriving stock Show
 
--- TODO
 instance HandleAction Save where
-  handleAction _ _ _ = pure ()
+  handleAction uiElts vars@( Variables { .. } ) _ = do
+    mbDoc <- STM.atomically $ currentDocument vars
+    case mbDoc of
+      Nothing  -> pure () -- could show a warning message
+      Just doc@( Document { mbFilePath, unsavedChanges } )
+        | Nothing <- mbFilePath
+        -> saveAs uiElts vars doc
+        | False <- unsavedChanges
+        -> pure ()
+        | Just filePath <- mbFilePath
+        -> do
+          saveDocument filePath doc
+          STM.atomically $
+            STM.modifyTVar' openDocumentsTVar
+              ( Map.insert ( documentUnique doc )
+                ( doc { unsavedChanges = False } )
+              )
 
 -------------
 -- Save as --
@@ -145,9 +212,43 @@ instance HandleAction Save where
 data SaveAs = SaveAs
   deriving stock Show
 
--- TODO
 instance HandleAction SaveAs where
-  handleAction _ _ _ = pure ()
+  handleAction uiElts vars _ = do
+    mbDoc <- STM.atomically $ currentDocument vars
+    case mbDoc of
+      Nothing  -> pure () -- could show a warning message
+      Just doc -> saveAs uiElts vars doc
+
+saveAs :: UIElements -> Variables -> Document -> IO ()
+saveAs ( UIElements { window } ) ( Variables { openDocumentsTVar } ) doc = do
+  fileChooser <-
+    GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
+      GTK.FileChooserActionSave
+      ( Just "Save" )
+      ( Just "Cancel" )
+  GTK.nativeDialogSetModal fileChooser True
+  GTK.fileChooserSetDoOverwriteConfirmation fileChooser True
+  fileFilter <- GTK.fileFilterNew
+  GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
+  GTK.fileFilterAddPattern fileFilter "*.mb"
+  GTK.fileChooserAddFilter fileChooser fileFilter
+  void $ GTK.nativeDialogRun fileChooser
+  mbFilePath <- listToMaybe <$> GTK.fileChooserGetFilenames fileChooser
+  for_ mbFilePath \ filePath -> do
+    -- set the document's new file path, and modify to indicate "no unsaved changes"
+    let
+      fullFilePath :: FilePath
+      fullFilePath
+        | ".mb" <- takeExtension filePath
+        = filePath
+        | otherwise
+        = filePath <.> "mb"
+    saveDocument fullFilePath doc
+    STM.atomically $
+      STM.modifyTVar' openDocumentsTVar
+        ( Map.insert ( documentUnique doc )
+          ( doc { mbFilePath = Just fullFilePath, unsavedChanges = False } )
+        )
 
 -----------
 -- Close --

src/app/MetaBrush/Document/Serialise.hs

@@ -5,10 +5,14 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module MetaBrush.Document.Serialise
-  ( documentToJSON, documentFromJSON )
+  ( documentToJSON, documentFromJSON
+  , saveDocument, loadDocument
+  )
   where
 
 -- base
+import Control.Monad
+  ( unless )
 import qualified Data.Bifunctor as Bifunctor
   ( first )
 import Data.Foldable
@@ -20,9 +24,15 @@ import Data.Functor.Identity
 import Unsafe.Coerce
   ( unsafeCoerce ) -- Tony Morris special
 
+-- atomic-file-ops
+import System.IO.AtomicFileOps
+  ( atomicReplaceFile )
+
 -- bytestring
 import qualified Data.ByteString as Strict
   ( ByteString )
+import qualified Data.ByteString as Strict.ByteString
+  ( readFile )
 import qualified Data.ByteString.Lazy as Lazy
   ( ByteString )
 import qualified Data.ByteString.Lazy.Builder as Lazy.ByteString.Builder
@@ -34,6 +44,14 @@ import Data.Sequence
 import qualified Data.Sequence as Seq
   ( fromList )
 
+-- directory
+import System.Directory
+  ( canonicalizePath, createDirectoryIfMissing, doesFileExist )
+
+-- filepath
+import System.FilePath
+  ( takeDirectory )
+
 -- scientific
 import qualified Data.Scientific as Scientific
   ( fromFloatDigits, toRealFloat )
@@ -119,6 +137,29 @@ documentFromJSON uniqueSupply mfp
 
 --------------------------------------------------------------------------------
 
+-- | Save a MetaBrush document to a file (in JSON format).
+saveDocument :: FilePath -> Document -> IO ()
+saveDocument path doc = do
+  path' <- canonicalizePath path
+  let
+    dir :: FilePath
+    dir = takeDirectory path'
+  createDirectoryIfMissing True dir
+  exists <- doesFileExist path
+  unless exists do
+    writeFile path ""
+  atomicReplaceFile Nothing path' ( documentToJSON doc )
+
+-- | Load a MetaBrush document.
+loadDocument :: UniqueSupply -> FilePath -> IO ( Either String Document )
+loadDocument uniqueSupply fp = do
+  exists <- doesFileExist fp
+  if exists
+  then Bifunctor.first show <$> ( documentFromJSON uniqueSupply ( Just fp ) =<< Strict.ByteString.readFile fp )
+  else pure ( Left $ "No file at " <> fp )
+
+--------------------------------------------------------------------------------
+
 encodeDouble :: Applicative f => JSON.Encoder f Double
 encodeDouble = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
 

src/app/MetaBrush/Event.hs

@@ -1,6 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NamedFieldPuns   #-}
-{-# LANGUAGE TypeOperators    #-}
 
 module MetaBrush.Event
   ( handleEvents )

src/app/MetaBrush/UI/Menu.hs

@@ -90,7 +90,7 @@ data instance MenuItem action submenu Description
     , menuItemAccel      :: !( Maybe ( Word32, [ Modifier ] ) )
     , submenuDescription :: !( submenu Description )
     }
-data instance MenuItem action submenu Object 
+data instance MenuItem action submenu Object
   = MenuItem
   { menuItem        :: !GTK.MenuItem
   , menuItemSubmenu :: !( submenu Object )
@@ -122,12 +122,13 @@ data Menu ( rt :: ResourceType )
 
 data FileMenu ( rt :: ResourceType )
   = FileMenu
-  { new    :: !( MenuItem NewFile  NoSubresource rt )
+  { new        :: !( MenuItem NewFile    NoSubresource rt )
-  , open   :: !( MenuItem OpenFile NoSubresource rt )
+  , openFile   :: !( MenuItem OpenFile   NoSubresource rt )
-  , save   :: !( MenuItem Save     NoSubresource rt )
+  , openFolder :: !( MenuItem OpenFolder NoSubresource rt )
-  , saveAs :: !( MenuItem SaveAs   NoSubresource rt )
+  , save       :: !( MenuItem Save       NoSubresource rt )
-  , close  :: !( MenuItem Close    NoSubresource rt )
+  , saveAs     :: !( MenuItem SaveAs     NoSubresource rt )
-  , quit   :: !( MenuItem Quit     NoSubresource rt )
+  , close      :: !( MenuItem Close      NoSubresource rt )
+  , quit       :: !( MenuItem Quit       NoSubresource rt )
   }
   deriving stock Generic
 
@@ -178,12 +179,13 @@ menuDescription
 fileMenuDescription :: FileMenu Description
 fileMenuDescription
   = FileMenu
-  { new    = MenuItemDescription "New"     [ "submenuItem" ] ( NewFile  AfterCurrentTab ) ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource
+  { new        = MenuItemDescription "New"         [ "submenuItem" ] ( NewFile    AfterCurrentTab ) ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource
-  , open   = MenuItemDescription "Open"    [ "submenuItem" ] ( OpenFile AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource
+  , openFile   = MenuItemDescription "Open file"   [ "submenuItem" ] ( OpenFile   AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource
-  , save   = MenuItemDescription "Save"    [ "submenuItem" ] Save                         ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource
+  , openFolder = MenuItemDescription "Open folder" [ "submenuItem" ] ( OpenFolder AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L, Shift L ] ) ) NoSubresource
-  , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] SaveAs                       ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource
+  , save       = MenuItemDescription "Save"        [ "submenuItem" ] Save                           ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource
-  , close  = MenuItemDescription "Close"   [ "submenuItem" ] Close                        ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource
+  , saveAs     = MenuItemDescription "Save as"     [ "submenuItem" ] SaveAs                         ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource
-  , quit   = MenuItemDescription "Quit"    [ "submenuItem" ] Quit                         ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource
+  , close      = MenuItemDescription "Close"       [ "submenuItem" ] Close                          ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource
+  , quit       = MenuItemDescription "Quit"        [ "submenuItem" ] Quit                           ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource
   }
 
 editMenuDescription :: EditMenu Description