hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

add saving/loading

Browse source
This commit is contained in:
sheaf 2020-09-03 00:38:53 +02:00
parent db4115c634
commit 5f3bbc891a
6 changed files with 183 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

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

4
MetaBrush.cabal
View file

@ -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

139
src/app/MetaBrush/Action.hs
View file

@ -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 --

43
src/app/MetaBrush/Document/Serialise.hs
View file

@ -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

4
src/app/MetaBrush/Event.hs
View file

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

28
src/app/MetaBrush/UI/Menu.hs
View file

@ -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