From 5f3bbc891aff61b8c1317c53562bdbaf8e399cfd Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 3 Sep 2020 00:38:53 +0200 Subject: [PATCH] add saving/loading --- .gitignore | 1 + MetaBrush.cabal | 4 + src/app/MetaBrush/Action.hs | 139 ++++++++++++++++++++---- src/app/MetaBrush/Document/Serialise.hs | 43 +++++++- src/app/MetaBrush/Event.hs | 4 +- src/app/MetaBrush/UI/Menu.hs | 28 ++--- 6 files changed, 183 insertions(+), 36 deletions(-) diff --git a/.gitignore b/.gitignore index 34a5407..a6d1196 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ assets/*.svg assets/*/ refs/ img/examples +files/ *.txt *.md diff --git a/MetaBrush.cabal b/MetaBrush.cabal index fe3c007..cfc0370 100644 --- a/MetaBrush.cabal +++ b/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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 6f7c1cf..b3e94a4 100644 --- a/src/app/MetaBrush/Action.hs +++ b/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 - ( HandleAction(..) - , quitEverything - , NewFile(..), OpenFile(..), Save(..), SaveAs(..), Close(..), Quit(..) - , Undo(..), Redo(..), Cut(..), Copy(..), Paste(..), Duplicate(..), Delete(..) - , Confirm(..) - , About(..) - , MouseMove(..), MouseClick(..), MouseRelease(..) - , Scroll(..), KeyboardPress(..), KeyboardRelease(..) - ) - where +module MetaBrush.Action 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 -- diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 7249a49..f26907e 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/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 diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 0c1891d..8a6913a 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NamedFieldPuns #-} module MetaBrush.Event ( handleEvents ) diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index ae576c3..3ad7dea 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/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 ) - , open :: !( MenuItem OpenFile NoSubresource rt ) - , save :: !( MenuItem Save NoSubresource rt ) - , saveAs :: !( MenuItem SaveAs NoSubresource rt ) - , close :: !( MenuItem Close NoSubresource rt ) - , quit :: !( MenuItem Quit NoSubresource rt ) + { new :: !( MenuItem NewFile NoSubresource rt ) + , openFile :: !( MenuItem OpenFile NoSubresource rt ) + , openFolder :: !( MenuItem OpenFolder NoSubresource rt ) + , save :: !( MenuItem Save NoSubresource rt ) + , saveAs :: !( MenuItem SaveAs 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 - , open = MenuItemDescription "Open" [ "submenuItem" ] ( OpenFile AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource - , save = MenuItemDescription "Save" [ "submenuItem" ] Save ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource - , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] SaveAs ( Just ( GDK.KEY_S, [ Control L, Shift 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 + { new = MenuItemDescription "New" [ "submenuItem" ] ( NewFile AfterCurrentTab ) ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource + , openFile = MenuItemDescription "Open file" [ "submenuItem" ] ( OpenFile AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource + , openFolder = MenuItemDescription "Open folder" [ "submenuItem" ] ( OpenFolder AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L, Shift L ] ) ) NoSubresource + , save = MenuItemDescription "Save" [ "submenuItem" ] Save ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource + , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] SaveAs ( Just ( GDK.KEY_S, [ Control L, Shift 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