diff --git a/MetaBrush.cabal b/MetaBrush.cabal index c28a064..e4e8063 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -113,12 +113,18 @@ common common common extras build-depends: - directory + aeson + >= 2.2 && < 2.3 + , aeson-pretty + >= 0.8 && < 0.9 + , directory >= 1.3.4.0 && < 1.4 , filepath >= 1.4.2.1 && < 1.6 , hashable >= 1.3.0.0 && < 1.5 + , hermes-json + >= 0.6.1.0 && < 0.7 , lens >= 4.19.2 && < 6.0 , mtl @@ -133,16 +139,14 @@ common extras >= 2.0 && < 3 , unordered-containers >= 0.2.11 && < 0.3 - , waargonaut - ^>= 0.8.0.2 common gtk build-depends: gi-cairo-render - ^>= 0.1.0 + >= 0.1.0 && < 0.2 , gi-cairo-connector - ^>= 0.1.0 + >= 0.1.0 && < 0.2 , gi-gdk >= 4.0.9 && < 4.1 , gi-gio @@ -150,11 +154,11 @@ common gtk , gi-glib >= 2.0.23 && < 2.1 , gi-gobject - ^>= 2.0.24 + >= 2.0.24 && < 2.1 , gi-gtk >= 4.0.3 && < 4.1 , haskell-gi - >= 0.26.10 && < 0.27 + == 0.26.11 , haskell-gi-base >= 0.26.8 && < 0.27 @@ -246,6 +250,4 @@ executable MetaBrush -rtsopts build-depends: - metabrushes - , tardis - >= 0.4.2.0 && < 0.6 + metabrushes diff --git a/cabal.project b/cabal.project index 709450b..aa6b30c 100644 --- a/cabal.project +++ b/cabal.project @@ -5,45 +5,22 @@ constraints: -- brush-strokes +use-fma, fp-ieee +fma3, rounded-hw -pure-hs -c99 -avx512 +ghc-prim -x87-long-double, - text -simdutf --- text +simdutf causes the "digit" package to fail to build with undefined symbol linker errors - --- Fix a severe bug in Waargonaut (no corresponding Hackage release???) --- + GHC 9.10 compatibility -source-repository-package - type: git - location: https://github.com/sheaf/waargonaut - tag: ec171cd5d185309692b745e2e2f291eab4038fb9 + text +simdutf allow-newer: *:base, *:template-haskell, *:ghc-prim, *:Cabal, - acts:deepseq, - digit:lens, - eigen:primitive, - eigen:transformers, - falsify:tasty, - gi-cairo-connector:mtl, - hedgehog:containers, - hedgehog:resourcet, - hw-balancedparens:hedgehog, - indexed-traversable:containers, - JuicyPixels:zlib, - natural:lens, - natural:semigroupoids, - records-sop:deepseq, - th-abstraction:containers, - waargonaut:bifunctors, - waargonaut:bytestring, - waargonaut:containers, - waargonaut:hoist-error, - waargonaut:lens, - waargonaut:mtl, - waargonaut:records-sop, - waargonaut:semigroups, - waargonaut:semigroupoids, - waargonaut:text, - waargonaut:vector, - waargonaut:witherable, +-- acts:deepseq, +-- eigen:primitive, +-- eigen:transformers, + hermes-json:deepseq, +-- falsify:tasty, +-- gi-cairo-connector:mtl, +-- hedgehog:containers, +-- hedgehog:resourcet, +-- indexed-traversable:containers, +-- JuicyPixels:zlib, +-- records-sop:deepseq, +-- th-abstraction:containers, -------------- -- GHC 9.10 -- diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index ae4901c..162f998 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -223,7 +223,7 @@ instance HandleAction OpenFile where openFileWarningDialog :: GTK.IsWindow window - => window -> FilePath -> String -> IO () + => window -> FilePath -> Text -> IO () openFileWarningDialog window filePath errMess = do dialogWindow <- GTK.windowNew @@ -240,7 +240,7 @@ openFileWarningDialog window filePath errMess = do GTK.widgetSetMarginTop contentBox 20 GTK.widgetSetMarginBottom contentBox 20 - label <- GTK.labelNew $ Just $ "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack errMess + label <- GTK.labelNew $ Just $ "Could not load file at " <> Text.pack filePath <> ":\n" <> errMess GTK.boxAppend contentBox label closeButton <- GTK.buttonNew @@ -936,6 +936,7 @@ data MouseClick = deriving stock Show instance HandleAction MouseClick where + handleAction :: UIElements -> Variables -> MouseClick -> IO () handleAction uiElts@( UIElements { viewport = Viewport {..} } ) vars@( Variables {..} ) diff --git a/src/metabrushes/MetaBrush/Document/Serialise.hs b/src/metabrushes/MetaBrush/Document/Serialise.hs index 6d6b6cd..50ff67f 100644 --- a/src/metabrushes/MetaBrush/Document/Serialise.hs +++ b/src/metabrushes/MetaBrush/Document/Serialise.hs @@ -2,6 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module MetaBrush.Document.Serialise ( documentToJSON, documentFromJSON , saveDocument, loadDocument @@ -13,22 +15,28 @@ import Control.Monad ( unless ) import Control.Monad.ST ( RealWorld, stToIO ) +import Control.Exception + ( try ) import qualified Data.Bifunctor as Bifunctor ( first ) -import Data.Functor.Identity - ( Identity(..) ) import Data.Maybe ( fromMaybe ) import Data.STRef ( newSTRef ) +import Data.Traversable + ( for ) import Data.Version ( Version(versionBranch) ) import GHC.Exts ( Proxy# ) -import GHC.TypeLits - ( Symbol ) -import Unsafe.Coerce - ( unsafeCoerce ) -- Tony Morris special + +-- aeson +import Data.Aeson + ( (.=) ) +import qualified Data.Aeson as Aeson + +-- aeson-pretty +import qualified Data.Aeson.Encode.Pretty as PrettyAeson -- atomic-file-ops import System.IO.AtomicFileOps @@ -41,8 +49,6 @@ import qualified Data.ByteString as Strict.ByteString ( readFile ) import qualified Data.ByteString.Lazy as Lazy ( ByteString ) -import qualified Data.ByteString.Builder as Lazy.ByteString.Builder - ( toLazyByteString ) -- containers import qualified Data.Map.Strict as Map @@ -55,9 +61,8 @@ import System.Directory import System.FilePath ( takeDirectory ) --- mtl -import Control.Monad.Except - ( MonadError(throwError) ) +-- hermes-json +import qualified Data.Hermes as Hermes -- stm import qualified Control.Concurrent.STM as STM @@ -67,44 +72,17 @@ import qualified Control.Concurrent.STM as STM import Data.Text ( Text ) import qualified Data.Text as Text - ( unwords ) + ( pack, unwords, unpack ) -- transformers import Control.Monad.IO.Class ( MonadIO(liftIO) ) -import Control.Monad.Trans.Class - ( MonadTrans(lift) ) import qualified Control.Monad.Trans.Reader as Reader --- waargonaut -import qualified Waargonaut.Attoparsec as JSON.Decoder - ( decodeAttoparsecByteString ) -import qualified Waargonaut.Decode as JSON - ( Decoder ) -import qualified Waargonaut.Decode.Error as JSON - ( DecodeError(ParseFailed) ) -import qualified Waargonaut.Decode as JSON.Decoder -import qualified Waargonaut.Encode as JSON - ( Encoder ) -import qualified Waargonaut.Encode as JSON.Encoder -import qualified Waargonaut.Encode.Builder as JSON.Builder - ( waargonautBuilder, bsBuilder ) -import qualified Waargonaut.Encode.Builder.Whitespace as JSON.Builder - ( wsBuilder ) -import Waargonaut.Prettier - ( NumSpaces(..), IndentStep(..) ) -import qualified Waargonaut.Prettier as Inline - ( InlineOption(..) ) -import qualified Waargonaut.Prettier as JSON - ( prettyJson ) -import qualified Waargonaut.Prettier as TonyMorris - ( Natural ) -import qualified Waargonaut.Types.JObject as JSON - ( MapLikeObj ) -import Waargonaut.Types.Json - ( Json ) -import qualified Waargonaut.Types.Whitespace as JSON - ( WS ) +-- unordered-containers +import Data.HashMap.Strict + ( HashMap ) +import qualified Data.HashMap.Strict as HashMap -- brush-strokes import Math.Bezier.Spline @@ -112,7 +90,7 @@ import Math.Bezier.Spline import Math.Bezier.Stroke ( CachedStroke(..) ) import Math.Linear - ( ℝ(..), T(..) ) + ( ℝ(..) ) -- MetaBrush import MetaBrush.Asset.Brushes @@ -123,16 +101,11 @@ import MetaBrush.Document import MetaBrush.Layer ( LayerMetadata(..) ) import MetaBrush.Serialisable - ( Serialisable(..) - , encodeSpline, decodeSpline - ) import MetaBrush.Stroke import MetaBrush.Records ( Record, knownSymbols ) import MetaBrush.Unique ( UniqueSupply, freshUnique ) -import MetaBrush.Unique - ( Unique ) import qualified Paths_MetaBrush as Cabal ( version ) @@ -140,17 +113,31 @@ import qualified Paths_MetaBrush as Cabal -- | Serialise a document to JSON (in the form of a lazy bytestring). documentToJSON :: Document -> Lazy.ByteString -documentToJSON - = runIdentity - . fmap - ( Lazy.ByteString.Builder.toLazyByteString - . JSON.Builder.waargonautBuilder JSON.Builder.wsBuilder JSON.Builder.bsBuilder - . JSON.prettyJson Inline.Neither ( IndentStep four ) ( NumSpaces four ) - ) - . JSON.Encoder.runEncoder encodeDocument +documentToJSON = PrettyAeson.encodePretty' $ + PrettyAeson.Config + { PrettyAeson.confIndent = PrettyAeson.Spaces 4 + , PrettyAeson.confCompare = compFn + , PrettyAeson.confNumFormat = PrettyAeson.Generic + , PrettyAeson.confTrailingNewline = False + } where - four :: TonyMorris.Natural - four = unsafeCoerce ( 4 :: Integer ) + order :: HashMap Text Int + order = + HashMap.fromList $ + zip + [ "version", "name", "zoom", "center", "strokes", "splineStart", "point", "coords", "closed" ] + [ 0 .. ] + compFn :: Text -> Text -> Ordering + compFn x y + | x == y + = EQ + | let mbIx1 = HashMap.lookup x order + mbIx2 = HashMap.lookup y order + = case ( mbIx1, mbIx2 ) of + ( Nothing, Just {} ) -> GT + ( Just {}, Nothing ) -> LT + ( Just i1, Just i2 ) -> compare i1 i2 + ( Nothing, Nothing ) -> compare x y -- | Parse a document from JSON (given by a strict bytestring). -- @@ -159,10 +146,12 @@ documentFromJSON :: UniqueSupply -> Maybe FilePath -> Strict.ByteString - -> IO ( Either JSON.DecodeError Document ) -documentFromJSON uniqueSupply mfp - = fmap ( Bifunctor.first fst ) - . JSON.Decoder.decodeAttoparsecByteString ( decodeDocument uniqueSupply mfp ) + -> IO ( Either Text Document ) +documentFromJSON uniqueSupply mbFilePath docData = do + mbDoc <- + try @Hermes.HermesException $ + Hermes.decodeEitherIO ( decodeDocument uniqueSupply mbFilePath ) docData + return $ Bifunctor.first Hermes.formatException mbDoc -------------------------------------------------------------------------------- @@ -180,86 +169,70 @@ saveDocument path doc = do atomicReplaceFile Nothing path' ( documentToJSON doc ) -- | Load a MetaBrush document. -loadDocument :: UniqueSupply -> FilePath -> IO ( Either String Document ) +loadDocument :: UniqueSupply -> FilePath -> IO ( Either Text 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 ) + then ( documentFromJSON uniqueSupply ( Just fp ) =<< Strict.ByteString.readFile fp ) + else pure ( Left $ "No file at " <> Text.pack fp ) -------------------------------------------------------------------------------- -encodePointData - :: forall f ( flds :: [ Symbol ] ) brushParams - . ( Applicative f - , brushParams ~ Record flds - , Serialisable ( Record flds ) - ) - => JSON.Encoder f ( PointData brushParams ) -encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) -> - JSON.Encoder.atKey' "coords" ( encoder @( ℝ 2 ) ) pointCoords - . JSON.Encoder.atKey' "brushParams" ( encoder @( Record flds ) ) brushParams +instance Aeson.ToJSON brushParams => Aeson.ToJSON ( PointData brushParams ) where + toJSON ( PointData { pointCoords, brushParams } ) = + Aeson.object + [ "coords" .= pointCoords + , "brushParams" .= brushParams ] -decodePointData - :: forall m ( flds :: [ Symbol ] ) brushParams - . ( Monad m - , brushParams ~ Record flds - , Serialisable ( Record flds ) - ) - => JSON.Decoder m ( PointData brushParams ) -decodePointData = do - pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( ℝ 2 ) ) - brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Record flds ) ) - pure ( PointData { pointCoords, brushParams } ) +instance FromJSON brushParams => FromJSON ( PointData brushParams ) where + decoder = + Hermes.object $ do + pointCoords <- key "coords" + brushParams <- key "brushParams" + pure ( PointData { pointCoords, brushParams } ) -encodeFields :: Monad f => JSON.Encoder f [ Text ] -encodeFields = JSON.Encoder.list JSON.Encoder.text - -decodeFields :: Monad m => JSON.Decoder m [ Text ] +decodeFields :: Hermes.Decoder [ Text ] decodeFields = do - fields <- JSON.Decoder.list JSON.Decoder.text + fields <- Hermes.list Hermes.text case duplicates fields of [] -> pure fields - [dup] -> throwError ( JSON.ParseFailed $ "Duplicate field name " <> dup <> " in brush record type" ) - dups -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups ) + [dup] -> fail ( "Duplicate field name " <> Text.unpack dup <> " in brush record type" ) + dups -> fail ( "Duplicate field names in brush record type:\n" <> Text.unpack ( Text.unwords dups ) ) -encodeBrush :: Applicative f => JSON.Encoder f ( NamedBrush brushFields ) -encodeBrush = JSON.Encoder.mapLikeObj - \ ( NamedBrush { brushName } ) -> - JSON.Encoder.atKey' "name" JSON.Encoder.text brushName +instance Aeson.ToJSON ( NamedBrush brushFields ) where + toJSON ( NamedBrush { brushName } ) = Aeson.object [ "name" .= brushName ] +instance FromJSON SomeBrush where + decoder = + Hermes.object $ do + brushName <- key "name" + case lookupBrush brushName of + Nothing -> fail ( "Unknown brush " <> Text.unpack brushName ) + Just b -> return b -decodeBrush :: Monad m => JSON.Decoder m SomeBrush -decodeBrush = do - brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text - case lookupBrush brushName of - Nothing -> throwError ( JSON.ParseFailed ( "Unknown brush " <> brushName ) ) - Just b -> return b - - -encodeStroke :: Monad f => JSON.Encoder f Stroke -encodeStroke = JSON.Encoder.mapLikeObj - \ ( Stroke +instance Aeson.ToJSON Stroke where + toJSON + ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields ) , strokeBrush } - ) -> + ) = let closed :: Bool closed = case ssplineType @clo of SClosed -> True SOpen -> False - mbEncodeBrush :: JSON.MapLikeObj JSON.WS Json -> JSON.MapLikeObj JSON.WS Json mbEncodeBrush = case strokeBrush of - Nothing -> id - Just brush -> JSON.Encoder.atKey' "brush" encodeBrush brush + Nothing -> [] + Just brush -> [ "brush" .= brush ] in - JSON.Encoder.atKey' "closed" JSON.Encoder.bool closed - . JSON.Encoder.atKey' "pointFields" encodeFields ( knownSymbols @pointFields ) - . mbEncodeBrush - . JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline + Aeson.object $ + [ "closed" .= closed + , "pointFields" .= knownSymbols @pointFields + , "spline" .= strokeSpline + ] ++ mbEncodeBrush -newCurveData :: MonadIO m => ( Integer -> m ( CurveData RealWorld ) ) +newCurveData :: Integer -> Hermes.FieldsDecoder ( CurveData RealWorld ) newCurveData i = do noCache <- liftIO . stToIO $ CachedStroke <$> newSTRef Nothing return $ @@ -268,115 +241,123 @@ newCurveData i = do , cachedStroke = noCache } -decodeStroke :: MonadIO m => JSON.Decoder m Stroke -decodeStroke = do - strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool - mbSomeBrush <- JSON.Decoder.atKeyOptional "brush" decodeBrush - pointFields <- JSON.Decoder.atKey "pointFields" decodeFields - -- decodeFields ensured there were no duplicate field names. - provePointFields pointFields \ ( _ :: Proxy# pointFields ) -> - if strokeClosed - then do - strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) decodePointData newCurveData ) - pure $ case mbSomeBrush of - Nothing -> - Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) } - Just (SomeBrush brush) -> - Stroke { strokeSpline, strokeBrush = Just brush } - else do - strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) decodePointData newCurveData ) - pure $ case mbSomeBrush of - Nothing -> - Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) } - Just (SomeBrush brush) -> - Stroke { strokeSpline, strokeBrush = Just brush } +instance FromJSON Stroke where + decoder = Hermes.object do + strokeClosed <- key "closed" + mbSomeBrush <- keyOptional "brush" + pointFields <- Hermes.atKey "pointFields" decodeFields + -- decodeFields ensured there were no duplicate field names. + provePointFields pointFields \ ( _ :: Proxy# pointFields ) -> + if strokeClosed + then do + strokeSpline <- Hermes.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) newCurveData ) + pure $ case mbSomeBrush of + Nothing -> + Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) } + Just (SomeBrush brush) -> + Stroke { strokeSpline, strokeBrush = Just brush } + else do + strokeSpline <- Hermes.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) newCurveData ) + pure $ case mbSomeBrush of + Nothing -> + Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) } + Just (SomeBrush brush) -> + Stroke { strokeSpline, strokeBrush = Just brush } -encodeLayer :: Monad f => JSON.Encoder f Layer -encodeLayer = - JSON.Encoder.mapLikeObj \ layer -> - let - encodeLayerData = case layer of +instance Aeson.ToJSON Layer where + toJSON layer = + Aeson.object $ + [ "name" .= layerName layer + ] ++ ( if layerVisible layer then [ ] else [ "visible" .= False ] ) + ++ ( if layerLocked layer then [ "locked" .= True ] else [] ) + ++ case layer of GroupLayer { groupChildren } -> - JSON.Encoder.atKey' "contents" ( JSON.Encoder.list encodeLayer ) groupChildren + [ "contents" .= groupChildren ] StrokeLayer { layerStroke } -> - JSON.Encoder.atKey' "stroke" encodeStroke layerStroke - in - JSON.Encoder.atKey' "name" JSON.Encoder.text ( layerName layer ) - . JSON.Encoder.atOptKey' "visible" JSON.Encoder.bool ( if layerVisible layer then Nothing else Just False ) - . JSON.Encoder.atOptKey' "locked" JSON.Encoder.bool ( if layerLocked layer then Just True else Nothing ) - . encodeLayerData + [ "stroke" .= layerStroke ] -decodeLayer :: MonadIO m => JSON.Decoder m Layer -decodeLayer = do - mbLayerName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text - mbLayerVisible <- JSON.Decoder.atKeyOptional "visible" JSON.Decoder.bool - mbLayerLocked <- JSON.Decoder.atKeyOptional "locked" JSON.Decoder.bool - let layerVisible = fromMaybe True mbLayerVisible - layerLocked = fromMaybe False mbLayerLocked - mbLayerStroke <- JSON.Decoder.atKeyOptional "stroke" decodeStroke - case mbLayerStroke of - Nothing -> do - let layerName = fromMaybe "Group" mbLayerName - groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list decodeLayer ) - pure ( GroupLayer { layerName, layerVisible, layerLocked, groupChildren } ) - Just layerStroke -> do - let layerName = fromMaybe "Stroke" mbLayerName - pure ( StrokeLayer { layerName, layerVisible, layerLocked, layerStroke } ) +decodeLayer :: UniqueSupply -> Hermes.Decoder Layer +decodeLayer uniqueSupply = Hermes.object $ do + mbLayerName <- keyOptional "name" + mbLayerVisible <- keyOptional "visible" + mbLayerLocked <- keyOptional "locked" + let layerVisible = fromMaybe True mbLayerVisible + layerLocked = fromMaybe False mbLayerLocked + mbLayerStroke <- keyOptional "stroke" + case mbLayerStroke of + Nothing -> do + let layerName = fromMaybe "Group" mbLayerName + groupChildren <- fromMaybe [] <$> Hermes.atKeyOptional "contents" ( Hermes.list ( decodeLayer uniqueSupply ) ) + pure ( GroupLayer { layerName, layerVisible, layerLocked, groupChildren } ) + Just layerStroke -> do + let layerName = fromMaybe "Stroke" mbLayerName + pure ( StrokeLayer { layerName, layerVisible, layerLocked, layerStroke } ) -encodeGuide :: Applicative f => JSON.Encoder f Guide -encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) -> - JSON.Encoder.atKey' "point" ( encoder @( ℝ 2 ) ) guidePoint - . JSON.Encoder.atKey' "normal" ( encoder @( T ( ℝ 2 ) ) ) guideNormal -decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m ( Unique, Guide ) -decodeGuide uniqueSupply = do - guideUnique <- lift ( liftIO . STM.atomically $ Reader.runReaderT freshUnique uniqueSupply ) - guidePoint <- JSON.Decoder.atKey "point" ( decoder @( ℝ 2 ) ) - guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( ℝ 2 ) ) ) - pure ( guideUnique, Guide { guidePoint, guideNormal } ) +instance Aeson.ToJSON Guide where + toJSON ( Guide { guidePoint, guideNormal } ) = + Aeson.object + [ "point" .= guidePoint, "normal" .= guideNormal ] + +instance FromJSON Guide where + decoder = Hermes.object do + guidePoint <- key "point" + guideNormal <- key "normal" + return $ Guide { guidePoint, guideNormal } + decodeDocumentMetadata - :: MonadIO m - => UniqueSupply + :: UniqueSupply -> Maybe FilePath -> LayerMetadata - -> JSON.Decoder m DocumentMetadata + -> Hermes.FieldsDecoder DocumentMetadata decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do - documentName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text - viewportCenter <- JSON.Decoder.atKeyOptional "center" ( decoder @( ℝ 2 ) ) - zoomFactor <- JSON.Decoder.atKeyOptional "zoom" ( decoder @Double ) - guides <- JSON.Decoder.atKeyOptional "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply ) - pure $ + documentName <- keyOptional "name" + viewportCenter <- keyOptional "center" + zoomFactor <- keyOptional "zoom" + guides <- keyOptional "guides" + documentGuides <- fmap Map.fromList . liftIO . STM.atomically $ + for ( fromMaybe [] guides ) $ \ guide -> do + u <- Reader.runReaderT freshUnique uniqueSupply + return ( u, guide ) + return $ Metadata { documentName = fromMaybe "Document" documentName , documentFilePath = mbFilePath , viewportCenter = fromMaybe ( ℝ2 0 0 ) viewportCenter , documentZoom = maybe ( Zoom 1 ) Zoom zoomFactor - , documentGuides = Map.fromList $ fromMaybe [] guides + , documentGuides , layerMetadata , selectedPoints = mempty } -encodeDocument :: Applicative f => JSON.Encoder f Document -encodeDocument = JSON.Encoder.mapLikeObj - \ ( Document { documentMetadata = meta, documentContent } ) -> - JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version ) - . JSON.Encoder.atKey' "name" JSON.Encoder.text ( documentName meta ) - . JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) ( viewportCenter meta ) - . JSON.Encoder.atKey' "zoom" ( encoder @Double ) ( zoomFactor $ documentZoom meta ) - . JSON.Encoder.atKey' "guides" ( JSON.Encoder.list encodeGuide ) ( Map.elems $ documentGuides meta ) - . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) ( strokeHierarchyLayers ( layerMetadata meta ) ( strokeHierarchy documentContent ) ) +instance Aeson.ToJSON Document where + toJSON ( Document { documentMetadata = meta, documentContent } ) = + Aeson.object $ + [ "version" .= versionBranch Cabal.version + , "name" .= documentName meta + , "center" .= viewportCenter meta + , "zoom" .= ( zoomFactor $ documentZoom meta ) + , "strokes" .= ( strokeHierarchyLayers ( layerMetadata meta ) ( strokeHierarchy documentContent ) ) + ] ++ if null guides then [] else [ "guides" .= guides ] + where + guides = Map.elems $ documentGuides meta -decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document -decodeDocument uniqueSupply mbFilePath = do - let - unsavedChanges :: Bool - unsavedChanges = False - mbLayers1 <- JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer ) - -- Preserve back-compat (a previous format used 'content.strokes' instead of 'strokes'). - mbLayers2 <- JSON.Decoder.atKeyOptional "content" ( JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer ) ) - let layers = fromMaybe [] mbLayers1 <> fromMaybe [] ( fromMaybe ( Just [] ) mbLayers2 ) - ( layerMetadata, strokeHierarchy ) <- lift $ ( `Reader.runReaderT` uniqueSupply ) $ layersStrokeHierarchy layers - let documentContent = Content { unsavedChanges, strokeHierarchy } - documentMetadata <- decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata - pure ( Document { documentMetadata, documentContent } ) +decodeDocument :: UniqueSupply -> Maybe FilePath -> Hermes.Decoder Document +decodeDocument uniqueSupply mbFilePath = + Hermes.object do + let + unsavedChanges :: Bool + unsavedChanges = False + mbLayers1 <- Hermes.atKeyOptional "strokes" ( Hermes.list ( decodeLayer uniqueSupply ) ) + -- Preserve back-compat (a previous format used 'content.strokes' instead of 'strokes'). + mbLayers2 <- Hermes.atKeyOptional "content" ( Hermes.object $ Hermes.atKeyOptional "strokes" ( Hermes.list ( decodeLayer uniqueSupply ) ) ) + let layers = fromMaybe [] mbLayers1 <> fromMaybe [] ( fromMaybe ( Just [] ) mbLayers2 ) + ( layerMetadata, strokeHierarchy ) <- ( `Reader.runReaderT` uniqueSupply ) $ layersStrokeHierarchy layers + let documentContent = Content { unsavedChanges, strokeHierarchy } + documentMetadata <- decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata + return $ + Document + { documentMetadata + , documentContent + } diff --git a/src/metabrushes/MetaBrush/Serialisable.hs b/src/metabrushes/MetaBrush/Serialisable.hs index caf305b..922e67c 100644 --- a/src/metabrushes/MetaBrush/Serialisable.hs +++ b/src/metabrushes/MetaBrush/Serialisable.hs @@ -2,39 +2,46 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module MetaBrush.Serialisable - ( Serialisable(..) - , encodeSequence, decodeSequence - , encodeCurve, decodeCurve - , encodeCurves, decodeCurves - , encodeSpline, decodeSpline + ( Serialisable + + -- * FromJSON (using hermes-json) + , FromJSON(..) + , key, keyOptional + + , decodeSequence + , decodeCurve + , decodeCurves + , decodeSpline ) where -- base - -import Data.Foldable - ( toList ) import Data.Functor ( (<&>) ) -import Data.Functor.Contravariant - ( contramap ) -import Data.Functor.Identity - ( Identity(..) ) import Data.IORef ( newIORef, atomicModifyIORef' ) -import Data.Traversable - ( for ) +import Data.Maybe + ( fromMaybe ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- aeson +import Data.Aeson + ( ToJSON(..), (.=) ) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Aeson -- containers import Data.Sequence ( Seq ) import qualified Data.Sequence as Seq - ( fromList ) + ( empty, fromList ) --- scientific -import qualified Data.Scientific as Scientific - ( fromFloatDigits, toRealFloat ) +-- hermes-json +import qualified Data.Hermes as Hermes -- text import Data.Text @@ -43,16 +50,6 @@ import Data.Text -- transformers import Control.Monad.IO.Class ( MonadIO(liftIO) ) -import Control.Monad.Trans.Class - ( MonadTrans(lift) ) - --- waargonaut -import qualified Waargonaut.Decode as JSON - ( Decoder ) -import qualified Waargonaut.Decode as JSON.Decoder -import qualified Waargonaut.Encode as JSON - ( Encoder ) -import qualified Waargonaut.Encode as JSON.Encoder -- meta-brushes import Math.Bezier.Spline @@ -67,197 +64,163 @@ import MetaBrush.Records -------------------------------------------------------------------------------- -class Serialisable a where - encoder :: Monad f => JSON.Encoder f a - decoder :: Monad m => JSON.Decoder m a +class ( Aeson.ToJSON a, FromJSON a ) => Serialisable a where +instance ( Aeson.ToJSON a, FromJSON a ) => Serialisable a where -instance Serialisable Double where - encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific - decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific +class FromJSON a where + decoder :: Hermes.Decoder a -instance Serialisable ( ℝ 2 ) where - encoder = JSON.Encoder.mapLikeObj \ ( ℝ2 x y ) -> - JSON.Encoder.atKey' "x" encoder x - . JSON.Encoder.atKey' "y" encoder y - decoder = ℝ2 <$> JSON.Decoder.atKey "x" decoder - <*> JSON.Decoder.atKey "y" decoder -instance Serialisable ( T ( ℝ 2 ) ) where - encoder = JSON.Encoder.mapLikeObj \ ( V2 x y ) -> - JSON.Encoder.atKey' "x" encoder x - . JSON.Encoder.atKey' "y" encoder y - decoder = V2 <$> JSON.Decoder.atKey "x" decoder - <*> JSON.Decoder.atKey "y" decoder +instance FromJSON Bool where + decoder = Hermes.bool +instance FromJSON Double where + decoder = Hermes.double +instance FromJSON Text where + decoder = Hermes.text +instance FromJSON a => FromJSON [a] where + decoder = Hermes.list decoder + +key :: FromJSON a => Text -> Hermes.FieldsDecoder a +key k = Hermes.atKey k decoder +keyOptional :: FromJSON a => Text -> Hermes.FieldsDecoder (Maybe a) +keyOptional k = Hermes.atKeyOptional k decoder + +instance MonadIO Hermes.Decoder where + liftIO a = unsafeCoerce $ \ ( _ :: Hermes.Object ) ( _ :: Hermes.HermesEnv ) -> a +instance MonadIO Hermes.FieldsDecoder where + liftIO a = unsafeCoerce $ \ ( _ :: Hermes.Object ) -> ( liftIO @Hermes.Decoder a ) + +instance Aeson.ToJSON ( ℝ 2 ) where + toJSON ( ℝ2 x y ) = Aeson.object [ "x" .= x, "y" .= y ] + toEncoding ( ℝ2 x y ) = Aeson.pairs ( "x" .= x <> "y" .= y ) + +instance FromJSON ( ℝ 2 ) where + decoder = + Hermes.object $ + ℝ2 <$> key "x" <*> key "y" + +deriving newtype instance Aeson.ToJSON ( T ( ℝ 2 ) ) +instance FromJSON ( T ( ℝ 2 ) ) where + decoder = T <$> decoder @( ℝ 2 ) instance ( KnownSymbols ks, Representable Double ( ℝ ( Length ks ) ) ) - => Serialisable ( Record ks ) where - encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) ) - where - encodeFields :: Record ks -> [ ( Text, Double ) ] - encodeFields ( MkR r ) = - zip [1..] ( knownSymbols @ks ) <&> \ ( i, fld ) -> - ( fld, index r ( Fin i ) ) + => Aeson.ToJSON ( Record ks ) where + toJSON r = Aeson.object $ + zip [1..] ( knownSymbols @ks ) <&> \ ( i, fld ) -> + ( Aeson.fromText fld .= index r ( Fin i ) ) - decoder = fmap decodeFields $ for ( knownSymbols @ks ) \ k -> JSON.Decoder.atKey k ( decoder @Double ) +instance ( KnownSymbols ks, Representable Double ( ℝ ( Length ks ) ) ) + => FromJSON ( Record ks ) where + decoder = + Hermes.object $ + decodeFields <$> + traverse key ( knownSymbols @ks ) where decodeFields :: [ Double ] -> Record ks - decodeFields coords = MkR $ tabulate \ ( Fin i ) -> - coords !! ( fromIntegral i - 1 ) + decodeFields coords = + MkR $ tabulate \ ( Fin i ) -> + coords !! ( fromIntegral i - 1 ) -------------------------------------------------------------------------------- -encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a ) -encodeSequence enc = contramap toList ( JSON.Encoder.list enc ) +instance ( SplineTypeI clo, Aeson.ToJSON ptData ) => Aeson.ToJSON ( Curve clo crvData ptData ) where + toJSON curve = Aeson.object $ + case ssplineType @clo of + SOpen -> + case curve of + LineTo ( NextPoint p1 ) _ -> + [ "p1" .= p1 ] + Bezier2To p1 ( NextPoint p2 ) _ -> + [ "p1" .= p1, "p2" .= p2 ] + Bezier3To p1 p2 ( NextPoint p3 ) _ -> + [ "p1" .= p1, "p2" .= p2, "p3" .= p3 ] + SClosed -> + case curve of + LineTo BackToStart _ -> [] + Bezier2To p1 BackToStart _ -> + [ "p1" .= p1 ] + Bezier3To p1 p2 BackToStart _ -> + [ "p1" .= p1, "p2" .= p2 ] +instance ( SplineTypeI clo, Aeson.ToJSON ptData ) => Aeson.ToJSON ( Curves clo crvData ptData ) where + toJSON curves = case ssplineType @clo of + SOpen -> toJSON ( openCurves curves ) + SClosed -> + case curves of + NoCurves -> Aeson.object [ ] + ClosedCurves prevs lst -> + Aeson.object + [ "prevOpenCurves" .= prevs + , "lastClosedCurve" .= lst + ] +instance ( SplineTypeI clo, Aeson.ToJSON ptData ) => Aeson.ToJSON ( Spline clo crvData ptData ) where + toJSON ( Spline { splineStart, splineCurves } ) = + Aeson.object + [ "splineStart" .= splineStart + , "splineCurves" .= splineCurves ] -decodeSequence :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Seq a ) -decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec - -{- -encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a ) -encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) -> - JSON.Encoder.atKey' "m00" enc m00 - . JSON.Encoder.atKey' "m01" enc m01 - . JSON.Encoder.atKey' "m10" enc m10 - . JSON.Encoder.atKey' "m11" enc m11 - -decodeMat22 :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Mat22 a ) -decodeMat22 dec = - Mat22 <$> JSON.Decoder.atKey "m00" dec - <*> JSON.Decoder.atKey "m01" dec - <*> JSON.Decoder.atKey "m10" dec - <*> JSON.Decoder.atKey "m11" dec - - - -encodeAABB :: Applicative f => JSON.Encoder f AABB -encodeAABB = JSON.Encoder.mapLikeObj \ ( AABB { topLeft, botRight } ) -> - JSON.Encoder.atKey' "topLeft" enc topLeft - . JSON.Encoder.atKey' "botRight" enc botRight - where - enc :: JSON.Encoder' ( Point2D Double ) - enc = encodePoint2D encodeDouble - -decodeAABB :: forall m. Monad m => JSON.Decoder m AABB -decodeAABB = do - topLeft <- JSON.Decoder.atKey "topLeft" dec - botRight <- JSON.Decoder.atKey "botRight" dec - pure ( AABB { topLeft, botRight } ) - where - dec :: JSON.Decoder m ( Point2D Double ) - dec = decodePoint2D decodeDouble --} - - -encodeCurve - :: forall clo crvData ptData f - . ( SplineTypeI clo, Applicative f ) - => JSON.Encoder Identity ptData - -> JSON.Encoder f ( Curve clo crvData ptData ) -encodeCurve encodePtData = case ssplineType @clo of - SOpen -> JSON.Encoder.mapLikeObj \case - LineTo ( NextPoint p1 ) _ -> - JSON.Encoder.atKey' "p1" encodePtData p1 - Bezier2To p1 ( NextPoint p2 ) _ -> - JSON.Encoder.atKey' "p1" encodePtData p1 - . JSON.Encoder.atKey' "p2" encodePtData p2 - Bezier3To p1 p2 ( NextPoint p3 ) _ -> - JSON.Encoder.atKey' "p1" encodePtData p1 - . JSON.Encoder.atKey' "p2" encodePtData p2 - . JSON.Encoder.atKey' "p3" encodePtData p3 - SClosed -> JSON.Encoder.mapLikeObj \case - LineTo BackToStart _ -> id - Bezier2To p1 BackToStart _ -> - JSON.Encoder.atKey' "p1" encodePtData p1 - Bezier3To p1 p2 BackToStart _ -> - JSON.Encoder.atKey' "p1" encodePtData p1 - . JSON.Encoder.atKey' "p2" encodePtData p2 +decodeSequence :: Hermes.Decoder a -> Hermes.Decoder ( Seq a ) +decodeSequence dec = Seq.fromList <$> Hermes.list dec decodeCurve - :: forall clo ptData crvData m - . ( SplineTypeI clo, MonadIO m ) - => JSON.Decoder m ptData - -> JSON.Decoder m crvData - -> JSON.Decoder m ( Curve clo crvData ptData ) -decodeCurve decodePtData decodeCrvData = do - crv <- decodeCrvData - case ssplineType @clo of - SOpen -> do - p1 <- JSON.Decoder.atKey "p1" decodePtData - mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData - case mb_p2 of - Nothing -> - pure ( LineTo ( NextPoint p1 ) crv) - Just p2 -> do - mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData - case mb_p3 of - Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) crv ) - Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) crv ) - SClosed -> do - mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData - case mb_p1 of - Nothing -> - pure ( LineTo BackToStart crv ) - Just p1 -> do - mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData - case mb_p2 of - Nothing -> pure ( Bezier2To p1 BackToStart crv ) - Just p2 -> pure ( Bezier3To p1 p2 BackToStart crv ) - -encodeCurves - :: forall clo crvData ptData f - . ( SplineTypeI clo, Applicative f ) - => JSON.Encoder Identity ptData - -> JSON.Encoder f ( Curves clo crvData ptData ) -encodeCurves encodePtData = case ssplineType @clo of - SOpen -> contramap ( openCurves ) ( encodeSequence $ encodeCurve @Open encodePtData ) - SClosed -> contramap ( \case { NoCurves -> Left (); ClosedCurves prevs lst -> Right ( prevs, lst ) } ) ( JSON.Encoder.either encodeL encodeR ) - where - encodeL :: JSON.Encoder f () - encodeL = contramap ( const "NoCurves" ) JSON.Encoder.text - encodeR :: JSON.Encoder f ( Seq ( Curve Open crvData ptData ), Curve Closed crvData ptData ) - encodeR = JSON.Encoder.mapLikeObj \ ( openCurves, closedCurve ) -> - JSON.Encoder.atKey' "prevOpenCurves" ( encodeSequence $ encodeCurve @Open encodePtData ) openCurves - . JSON.Encoder.atKey' "lastClosedCurve" ( encodeCurve @Closed encodePtData ) closedCurve + :: forall clo ptData crvData + . ( SplineTypeI clo, FromJSON ptData ) + => Hermes.FieldsDecoder crvData + -> Hermes.Decoder ( Curve clo crvData ptData ) +decodeCurve decodeCurveData = do + Hermes.object do + crvData <- decodeCurveData + case ssplineType @clo of + SOpen -> do + p1 <- key "p1" + mb_p2 <- keyOptional "p2" + case mb_p2 of + Nothing -> + pure $ LineTo ( NextPoint p1 ) crvData + Just p2 -> do + mb_p3 <- keyOptional "p3" + case mb_p3 of + Nothing -> pure $ Bezier2To p1 ( NextPoint p2 ) crvData + Just p3 -> pure $ Bezier3To p1 p2 ( NextPoint p3 ) crvData + SClosed -> do + mb_p1 <- keyOptional "p1" + case mb_p1 of + Nothing -> + pure $ LineTo BackToStart crvData + Just p1 -> do + mb_p2 <- keyOptional "p2" + case mb_p2 of + Nothing -> pure $ Bezier2To p1 BackToStart crvData + Just p2 -> pure $ Bezier3To p1 p2 BackToStart crvData decodeCurves - :: forall clo ptData crvData m - . ( SplineTypeI clo, MonadIO m ) - => JSON.Decoder m ptData - -> JSON.Decoder m crvData - -> JSON.Decoder m ( Curves clo crvData ptData ) -decodeCurves decodePtData decodeCrvData = case ssplineType @clo of - SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData decodeCrvData ) - SClosed -> do - mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text ) - case mbNoCurves of - Just _ -> pure NoCurves - Nothing -> do - prevCurves <- JSON.Decoder.atKey "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodePtData decodeCrvData ) - lastCurve <- JSON.Decoder.atKey "lastClosedCurve" ( decodeCurve @Closed decodePtData decodeCrvData ) - pure ( ClosedCurves prevCurves lastCurve ) - - - -encodeSpline - :: forall clo crvData ptData f - . ( SplineTypeI clo, Applicative f ) - => JSON.Encoder Identity ptData - -> JSON.Encoder f ( Spline clo crvData ptData ) -encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, splineCurves } ) -> - JSON.Encoder.atKey' "splineStart" encodePtData splineStart - . JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves + :: forall clo ptData crvData + . ( SplineTypeI clo, FromJSON ptData ) + => Hermes.FieldsDecoder crvData + -> Hermes.Decoder ( Curves clo crvData ptData ) +decodeCurves decodeCrvData = do + case ssplineType @clo of + SOpen -> do + OpenCurves <$> decodeSequence ( decodeCurve @Open decodeCrvData ) + SClosed -> Hermes.object do + mbLastCurve <- Hermes.atKeyOptional "lastClosedCurve" ( decodeCurve @Closed decodeCrvData ) + case mbLastCurve of + Nothing -> pure NoCurves + Just lastCurve -> do + prevCurves <- fromMaybe Seq.empty <$> + Hermes.atKeyOptional "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodeCrvData ) + pure ( ClosedCurves prevCurves lastCurve ) decodeSpline - :: forall clo ptData crvData m - . ( SplineTypeI clo, MonadIO m ) - => JSON.Decoder m ptData - -> ( Integer -> m crvData ) - -> JSON.Decoder m ( Spline clo crvData ptData ) -decodeSpline decodePtData newCurve = do - ref <- lift $ liftIO $ newIORef 0 - let newCrvData :: m crvData + :: forall clo ptData crvData + . ( SplineTypeI clo, FromJSON ptData ) + => ( Integer -> Hermes.FieldsDecoder crvData ) + -> Hermes.Decoder ( Spline clo crvData ptData ) +decodeSpline newCurve = do + ref <- liftIO $ newIORef 0 + let newCrvData :: Hermes.FieldsDecoder crvData newCrvData = do i <- liftIO $ atomicModifyIORef' ref ( \ o -> ( o + 1, o ) ) newCurve i - splineStart <- JSON.Decoder.atKey "splineStart" decodePtData - splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData ( lift newCrvData ) ) - pure ( Spline { splineStart, splineCurves } ) + Hermes.object $ do + splineStart <- key "splineStart" + splineCurves <- Hermes.atKey "splineCurves" ( decodeCurves @clo newCrvData ) + pure ( Spline { splineStart, splineCurves } )