hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

Migrate waargonaut -> {aeson, aeson-pretty, hermes-json}

Browse source
This commit is contained in:
sheaf 2024-10-23 14:49:42 +02:00
parent 60287fbf7e
commit 7b1dcefd46
5 changed files with 383 additions and 459 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
MetaBrush.cabal
View file

@ -113,12 +113,18 @@ common common
common extras common extras
build-depends: build-depends:
directory aeson
>= 2.2 && < 2.3
, aeson-pretty
>= 0.8 && < 0.9
, directory
>= 1.3.4.0 && < 1.4 >= 1.3.4.0 && < 1.4
, filepath , filepath
>= 1.4.2.1 && < 1.6 >= 1.4.2.1 && < 1.6
, hashable , hashable
>= 1.3.0.0 && < 1.5 >= 1.3.0.0 && < 1.5
, hermes-json
>= 0.6.1.0 && < 0.7
, lens , lens
>= 4.19.2 && < 6.0 >= 4.19.2 && < 6.0
, mtl , mtl
@ -133,16 +139,14 @@ common extras
>= 2.0 && < 3 >= 2.0 && < 3
, unordered-containers , unordered-containers
>= 0.2.11 && < 0.3 >= 0.2.11 && < 0.3
, waargonaut
^>= 0.8.0.2
common gtk common gtk
build-depends: build-depends:
gi-cairo-render gi-cairo-render
^>= 0.1.0 >= 0.1.0 && < 0.2
, gi-cairo-connector , gi-cairo-connector
^>= 0.1.0 >= 0.1.0 && < 0.2
, gi-gdk , gi-gdk
>= 4.0.9 && < 4.1 >= 4.0.9 && < 4.1
, gi-gio , gi-gio
@ -150,11 +154,11 @@ common gtk
, gi-glib , gi-glib
>= 2.0.23 && < 2.1 >= 2.0.23 && < 2.1
, gi-gobject , gi-gobject
^>= 2.0.24 >= 2.0.24 && < 2.1
, gi-gtk , gi-gtk
>= 4.0.3 && < 4.1 >= 4.0.3 && < 4.1
, haskell-gi , haskell-gi
>= 0.26.10 && < 0.27 == 0.26.11
, haskell-gi-base , haskell-gi-base
>= 0.26.8 && < 0.27 >= 0.26.8 && < 0.27
@ -246,6 +250,4 @@ executable MetaBrush
-rtsopts -rtsopts
build-depends: build-depends:
metabrushes metabrushes
, tardis
>= 0.4.2.0 && < 0.6

49
cabal.project
View file

@ -5,45 +5,22 @@ constraints:
-- brush-strokes +use-fma, -- brush-strokes +use-fma,
fp-ieee +fma3, fp-ieee +fma3,
rounded-hw -pure-hs -c99 -avx512 +ghc-prim -x87-long-double, rounded-hw -pure-hs -c99 -avx512 +ghc-prim -x87-long-double,
text -simdutf 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
allow-newer: allow-newer:
*:base, *:template-haskell, *:ghc-prim, *:Cabal, *:base, *:template-haskell, *:ghc-prim, *:Cabal,
acts:deepseq, -- acts:deepseq,
digit:lens, -- eigen:primitive,
eigen:primitive, -- eigen:transformers,
eigen:transformers, hermes-json:deepseq,
falsify:tasty, -- falsify:tasty,
gi-cairo-connector:mtl, -- gi-cairo-connector:mtl,
hedgehog:containers, -- hedgehog:containers,
hedgehog:resourcet, -- hedgehog:resourcet,
hw-balancedparens:hedgehog, -- indexed-traversable:containers,
indexed-traversable:containers, -- JuicyPixels:zlib,
JuicyPixels:zlib, -- records-sop:deepseq,
natural:lens, -- th-abstraction:containers,
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,
-------------- --------------
-- GHC 9.10 -- -- GHC 9.10 --

5
src/app/MetaBrush/Application/Action.hs
View file

@ -223,7 +223,7 @@ instance HandleAction OpenFile where
openFileWarningDialog openFileWarningDialog
:: GTK.IsWindow window :: GTK.IsWindow window
=> window -> FilePath -> String -> IO () => window -> FilePath -> Text -> IO ()
openFileWarningDialog window filePath errMess = do openFileWarningDialog window filePath errMess = do
dialogWindow <- GTK.windowNew dialogWindow <- GTK.windowNew
@ -240,7 +240,7 @@ openFileWarningDialog window filePath errMess = do
GTK.widgetSetMarginTop contentBox 20 GTK.widgetSetMarginTop contentBox 20
GTK.widgetSetMarginBottom 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 GTK.boxAppend contentBox label
closeButton <- GTK.buttonNew closeButton <- GTK.buttonNew
@ -936,6 +936,7 @@ data MouseClick =
deriving stock Show deriving stock Show
instance HandleAction MouseClick where instance HandleAction MouseClick where
handleAction :: UIElements -> Variables -> MouseClick -> IO ()
handleAction handleAction
uiElts@( UIElements { viewport = Viewport {..} } ) uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables {..} ) vars@( Variables {..} )

399
src/metabrushes/MetaBrush/Document/Serialise.hs
View file

@ -2,6 +2,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module MetaBrush.Document.Serialise module MetaBrush.Document.Serialise
( documentToJSON, documentFromJSON ( documentToJSON, documentFromJSON
, saveDocument, loadDocument , saveDocument, loadDocument
@ -13,22 +15,28 @@ import Control.Monad
( unless ) ( unless )
import Control.Monad.ST import Control.Monad.ST
( RealWorld, stToIO ) ( RealWorld, stToIO )
import Control.Exception
( try )
import qualified Data.Bifunctor as Bifunctor import qualified Data.Bifunctor as Bifunctor
( first ) ( first )
import Data.Functor.Identity
( Identity(..) )
import Data.Maybe import Data.Maybe
( fromMaybe ) ( fromMaybe )
import Data.STRef import Data.STRef
( newSTRef ) ( newSTRef )
import Data.Traversable
( for )
import Data.Version import Data.Version
( Version(versionBranch) ) ( Version(versionBranch) )
import GHC.Exts import GHC.Exts
( Proxy# ) ( Proxy# )
import GHC.TypeLits
( Symbol ) -- aeson
import Unsafe.Coerce import Data.Aeson
( unsafeCoerce ) -- Tony Morris special ( (.=) )
import qualified Data.Aeson as Aeson
-- aeson-pretty
import qualified Data.Aeson.Encode.Pretty as PrettyAeson
-- atomic-file-ops -- atomic-file-ops
import System.IO.AtomicFileOps import System.IO.AtomicFileOps
@ -41,8 +49,6 @@ import qualified Data.ByteString as Strict.ByteString
( readFile ) ( readFile )
import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy as Lazy
( ByteString ) ( ByteString )
import qualified Data.ByteString.Builder as Lazy.ByteString.Builder
( toLazyByteString )
-- containers -- containers
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
@ -55,9 +61,8 @@ import System.Directory
import System.FilePath import System.FilePath
( takeDirectory ) ( takeDirectory )
-- mtl -- hermes-json
import Control.Monad.Except import qualified Data.Hermes as Hermes
( MonadError(throwError) )
-- stm -- stm
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
@ -67,44 +72,17 @@ import qualified Control.Concurrent.STM as STM
import Data.Text import Data.Text
( Text ) ( Text )
import qualified Data.Text as Text import qualified Data.Text as Text
( unwords ) ( pack, unwords, unpack )
-- transformers -- transformers
import Control.Monad.IO.Class import Control.Monad.IO.Class
( MonadIO(liftIO) ) ( MonadIO(liftIO) )
import Control.Monad.Trans.Class
( MonadTrans(lift) )
import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.Reader as Reader
-- waargonaut -- unordered-containers
import qualified Waargonaut.Attoparsec as JSON.Decoder import Data.HashMap.Strict
( decodeAttoparsecByteString ) ( HashMap )
import qualified Waargonaut.Decode as JSON import qualified Data.HashMap.Strict as HashMap
( 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 )
-- brush-strokes -- brush-strokes
import Math.Bezier.Spline import Math.Bezier.Spline
@ -112,7 +90,7 @@ import Math.Bezier.Spline
import Math.Bezier.Stroke import Math.Bezier.Stroke
( CachedStroke(..) ) ( CachedStroke(..) )
import Math.Linear import Math.Linear
( ℝ(..), T(..) ) ( ℝ(..) )
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Brushes import MetaBrush.Asset.Brushes
@ -123,16 +101,11 @@ import MetaBrush.Document
import MetaBrush.Layer import MetaBrush.Layer
( LayerMetadata(..) ) ( LayerMetadata(..) )
import MetaBrush.Serialisable import MetaBrush.Serialisable
( Serialisable(..)
, encodeSpline, decodeSpline
)
import MetaBrush.Stroke import MetaBrush.Stroke
import MetaBrush.Records import MetaBrush.Records
( Record, knownSymbols ) ( Record, knownSymbols )
import MetaBrush.Unique import MetaBrush.Unique
( UniqueSupply, freshUnique ) ( UniqueSupply, freshUnique )
import MetaBrush.Unique
( Unique )
import qualified Paths_MetaBrush as Cabal import qualified Paths_MetaBrush as Cabal
( version ) ( version )
@ -140,17 +113,31 @@ import qualified Paths_MetaBrush as Cabal
-- | Serialise a document to JSON (in the form of a lazy bytestring). -- | Serialise a document to JSON (in the form of a lazy bytestring).
documentToJSON :: Document -> Lazy.ByteString documentToJSON :: Document -> Lazy.ByteString
documentToJSON documentToJSON = PrettyAeson.encodePretty' $
= runIdentity PrettyAeson.Config
. fmap { PrettyAeson.confIndent = PrettyAeson.Spaces 4
( Lazy.ByteString.Builder.toLazyByteString , PrettyAeson.confCompare = compFn
. JSON.Builder.waargonautBuilder JSON.Builder.wsBuilder JSON.Builder.bsBuilder , PrettyAeson.confNumFormat = PrettyAeson.Generic
. JSON.prettyJson Inline.Neither ( IndentStep four ) ( NumSpaces four ) , PrettyAeson.confTrailingNewline = False
) }
. JSON.Encoder.runEncoder encodeDocument
where where
four :: TonyMorris.Natural order :: HashMap Text Int
four = unsafeCoerce ( 4 :: Integer ) 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). -- | Parse a document from JSON (given by a strict bytestring).
-- --
@ -159,10 +146,12 @@ documentFromJSON
:: UniqueSupply :: UniqueSupply
-> Maybe FilePath -> Maybe FilePath
-> Strict.ByteString -> Strict.ByteString
-> IO ( Either JSON.DecodeError Document ) -> IO ( Either Text Document )
documentFromJSON uniqueSupply mfp documentFromJSON uniqueSupply mbFilePath docData = do
= fmap ( Bifunctor.first fst ) mbDoc <-
. JSON.Decoder.decodeAttoparsecByteString ( decodeDocument uniqueSupply mfp ) 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 ) atomicReplaceFile Nothing path' ( documentToJSON doc )
-- | Load a MetaBrush document. -- | Load a MetaBrush document.
loadDocument :: UniqueSupply -> FilePath -> IO ( Either String Document ) loadDocument :: UniqueSupply -> FilePath -> IO ( Either Text Document )
loadDocument uniqueSupply fp = do loadDocument uniqueSupply fp = do
exists <- doesFileExist fp exists <- doesFileExist fp
if exists if exists
then Bifunctor.first show <$> ( documentFromJSON uniqueSupply ( Just fp ) =<< Strict.ByteString.readFile fp ) then ( documentFromJSON uniqueSupply ( Just fp ) =<< Strict.ByteString.readFile fp )
else pure ( Left $ "No file at " <> fp ) else pure ( Left $ "No file at " <> Text.pack fp )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
encodePointData instance Aeson.ToJSON brushParams => Aeson.ToJSON ( PointData brushParams ) where
:: forall f ( flds :: [ Symbol ] ) brushParams toJSON ( PointData { pointCoords, brushParams } ) =
. ( Applicative f Aeson.object
, brushParams ~ Record flds [ "coords" .= pointCoords
, Serialisable ( Record flds ) , "brushParams" .= brushParams ]
)
=> 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
decodePointData instance FromJSON brushParams => FromJSON ( PointData brushParams ) where
:: forall m ( flds :: [ Symbol ] ) brushParams decoder =
. ( Monad m Hermes.object $ do
, brushParams ~ Record flds pointCoords <- key "coords"
, Serialisable ( Record flds ) brushParams <- key "brushParams"
) pure ( PointData { pointCoords, brushParams } )
=> 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 } )
encodeFields :: Monad f => JSON.Encoder f [ Text ] decodeFields :: Hermes.Decoder [ Text ]
encodeFields = JSON.Encoder.list JSON.Encoder.text
decodeFields :: Monad m => JSON.Decoder m [ Text ]
decodeFields = do decodeFields = do
fields <- JSON.Decoder.list JSON.Decoder.text fields <- Hermes.list Hermes.text
case duplicates fields of case duplicates fields of
[] -> pure fields [] -> pure fields
[dup] -> throwError ( JSON.ParseFailed $ "Duplicate field name " <> dup <> " in brush record type" ) [dup] -> fail ( "Duplicate field name " <> Text.unpack dup <> " in brush record type" )
dups -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups ) dups -> fail ( "Duplicate field names in brush record type:\n" <> Text.unpack ( Text.unwords dups ) )
encodeBrush :: Applicative f => JSON.Encoder f ( NamedBrush brushFields ) instance Aeson.ToJSON ( NamedBrush brushFields ) where
encodeBrush = JSON.Encoder.mapLikeObj toJSON ( NamedBrush { brushName } ) = Aeson.object [ "name" .= brushName ]
\ ( NamedBrush { brushName } ) -> instance FromJSON SomeBrush where
JSON.Encoder.atKey' "name" JSON.Encoder.text brushName 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 instance Aeson.ToJSON Stroke where
decodeBrush = do toJSON
brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text ( Stroke
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
{ strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields ) { strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields )
, strokeBrush , strokeBrush
} }
) -> ) =
let let
closed :: Bool closed :: Bool
closed = case ssplineType @clo of closed = case ssplineType @clo of
SClosed -> True SClosed -> True
SOpen -> False SOpen -> False
mbEncodeBrush :: JSON.MapLikeObj JSON.WS Json -> JSON.MapLikeObj JSON.WS Json
mbEncodeBrush = case strokeBrush of mbEncodeBrush = case strokeBrush of
Nothing -> id Nothing -> []
Just brush -> JSON.Encoder.atKey' "brush" encodeBrush brush Just brush -> [ "brush" .= brush ]
in in
JSON.Encoder.atKey' "closed" JSON.Encoder.bool closed Aeson.object $
. JSON.Encoder.atKey' "pointFields" encodeFields ( knownSymbols @pointFields ) [ "closed" .= closed
. mbEncodeBrush , "pointFields" .= knownSymbols @pointFields
. JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline , "spline" .= strokeSpline
] ++ mbEncodeBrush
newCurveData :: MonadIO m => ( Integer -> m ( CurveData RealWorld ) ) newCurveData :: Integer -> Hermes.FieldsDecoder ( CurveData RealWorld )
newCurveData i = do newCurveData i = do
noCache <- liftIO . stToIO $ CachedStroke <$> newSTRef Nothing noCache <- liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
return $ return $
@ -268,115 +241,123 @@ newCurveData i = do
, cachedStroke = noCache , cachedStroke = noCache
} }
decodeStroke :: MonadIO m => JSON.Decoder m Stroke instance FromJSON Stroke where
decodeStroke = do decoder = Hermes.object do
strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool strokeClosed <- key "closed"
mbSomeBrush <- JSON.Decoder.atKeyOptional "brush" decodeBrush mbSomeBrush <- keyOptional "brush"
pointFields <- JSON.Decoder.atKey "pointFields" decodeFields pointFields <- Hermes.atKey "pointFields" decodeFields
-- decodeFields ensured there were no duplicate field names. -- decodeFields ensured there were no duplicate field names.
provePointFields pointFields \ ( _ :: Proxy# pointFields ) -> provePointFields pointFields \ ( _ :: Proxy# pointFields ) ->
if strokeClosed if strokeClosed
then do then do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) decodePointData newCurveData ) strokeSpline <- Hermes.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) newCurveData )
pure $ case mbSomeBrush of pure $ case mbSomeBrush of
Nothing -> Nothing ->
Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) } Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
Just (SomeBrush brush) -> Just (SomeBrush brush) ->
Stroke { strokeSpline, strokeBrush = Just brush } Stroke { strokeSpline, strokeBrush = Just brush }
else do else do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) decodePointData newCurveData ) strokeSpline <- Hermes.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) newCurveData )
pure $ case mbSomeBrush of pure $ case mbSomeBrush of
Nothing -> Nothing ->
Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) } Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
Just (SomeBrush brush) -> Just (SomeBrush brush) ->
Stroke { strokeSpline, strokeBrush = Just brush } Stroke { strokeSpline, strokeBrush = Just brush }
encodeLayer :: Monad f => JSON.Encoder f Layer instance Aeson.ToJSON Layer where
encodeLayer = toJSON layer =
JSON.Encoder.mapLikeObj \ layer -> Aeson.object $
let [ "name" .= layerName layer
encodeLayerData = case layer of ] ++ ( if layerVisible layer then [ ] else [ "visible" .= False ] )
++ ( if layerLocked layer then [ "locked" .= True ] else [] )
++ case layer of
GroupLayer { groupChildren } -> GroupLayer { groupChildren } ->
JSON.Encoder.atKey' "contents" ( JSON.Encoder.list encodeLayer ) groupChildren [ "contents" .= groupChildren ]
StrokeLayer { layerStroke } -> StrokeLayer { layerStroke } ->
JSON.Encoder.atKey' "stroke" encodeStroke layerStroke [ "stroke" .= 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
decodeLayer :: MonadIO m => JSON.Decoder m Layer decodeLayer :: UniqueSupply -> Hermes.Decoder Layer
decodeLayer = do decodeLayer uniqueSupply = Hermes.object $ do
mbLayerName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text mbLayerName <- keyOptional "name"
mbLayerVisible <- JSON.Decoder.atKeyOptional "visible" JSON.Decoder.bool mbLayerVisible <- keyOptional "visible"
mbLayerLocked <- JSON.Decoder.atKeyOptional "locked" JSON.Decoder.bool mbLayerLocked <- keyOptional "locked"
let layerVisible = fromMaybe True mbLayerVisible let layerVisible = fromMaybe True mbLayerVisible
layerLocked = fromMaybe False mbLayerLocked layerLocked = fromMaybe False mbLayerLocked
mbLayerStroke <- JSON.Decoder.atKeyOptional "stroke" decodeStroke mbLayerStroke <- keyOptional "stroke"
case mbLayerStroke of case mbLayerStroke of
Nothing -> do Nothing -> do
let layerName = fromMaybe "Group" mbLayerName let layerName = fromMaybe "Group" mbLayerName
groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list decodeLayer ) groupChildren <- fromMaybe [] <$> Hermes.atKeyOptional "contents" ( Hermes.list ( decodeLayer uniqueSupply ) )
pure ( GroupLayer { layerName, layerVisible, layerLocked, groupChildren } ) pure ( GroupLayer { layerName, layerVisible, layerLocked, groupChildren } )
Just layerStroke -> do Just layerStroke -> do
let layerName = fromMaybe "Stroke" mbLayerName let layerName = fromMaybe "Stroke" mbLayerName
pure ( StrokeLayer { layerName, layerVisible, layerLocked, layerStroke } ) 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 ) instance Aeson.ToJSON Guide where
decodeGuide uniqueSupply = do toJSON ( Guide { guidePoint, guideNormal } ) =
guideUnique <- lift ( liftIO . STM.atomically $ Reader.runReaderT freshUnique uniqueSupply ) Aeson.object
guidePoint <- JSON.Decoder.atKey "point" ( decoder @( ℝ 2 ) ) [ "point" .= guidePoint, "normal" .= guideNormal ]
guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( ℝ 2 ) ) )
pure ( guideUnique, Guide { guidePoint, guideNormal } ) instance FromJSON Guide where
decoder = Hermes.object do
guidePoint <- key "point"
guideNormal <- key "normal"
return $ Guide { guidePoint, guideNormal }
decodeDocumentMetadata decodeDocumentMetadata
:: MonadIO m :: UniqueSupply
=> UniqueSupply
-> Maybe FilePath -> Maybe FilePath
-> LayerMetadata -> LayerMetadata
-> JSON.Decoder m DocumentMetadata -> Hermes.FieldsDecoder DocumentMetadata
decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do
documentName <- JSON.Decoder.atKeyOptional "name" JSON.Decoder.text documentName <- keyOptional "name"
viewportCenter <- JSON.Decoder.atKeyOptional "center" ( decoder @( ℝ 2 ) ) viewportCenter <- keyOptional "center"
zoomFactor <- JSON.Decoder.atKeyOptional "zoom" ( decoder @Double ) zoomFactor <- keyOptional "zoom"
guides <- JSON.Decoder.atKeyOptional "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply ) guides <- keyOptional "guides"
pure $ documentGuides <- fmap Map.fromList . liftIO . STM.atomically $
for ( fromMaybe [] guides ) $ \ guide -> do
u <- Reader.runReaderT freshUnique uniqueSupply
return ( u, guide )
return $
Metadata Metadata
{ documentName = fromMaybe "Document" documentName { documentName = fromMaybe "Document" documentName
, documentFilePath = mbFilePath , documentFilePath = mbFilePath
, viewportCenter = fromMaybe ( ℝ2 0 0 ) viewportCenter , viewportCenter = fromMaybe ( ℝ2 0 0 ) viewportCenter
, documentZoom = maybe ( Zoom 1 ) Zoom zoomFactor , documentZoom = maybe ( Zoom 1 ) Zoom zoomFactor
, documentGuides = Map.fromList $ fromMaybe [] guides , documentGuides
, layerMetadata , layerMetadata
, selectedPoints = mempty , selectedPoints = mempty
} }
encodeDocument :: Applicative f => JSON.Encoder f Document instance Aeson.ToJSON Document where
encodeDocument = JSON.Encoder.mapLikeObj toJSON ( Document { documentMetadata = meta, documentContent } ) =
\ ( Document { documentMetadata = meta, documentContent } ) -> Aeson.object $
JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version ) [ "version" .= versionBranch Cabal.version
. JSON.Encoder.atKey' "name" JSON.Encoder.text ( documentName meta ) , "name" .= documentName meta
. JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) ( viewportCenter meta ) , "center" .= viewportCenter meta
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) ( zoomFactor $ documentZoom meta ) , "zoom" .= ( zoomFactor $ documentZoom meta )
. JSON.Encoder.atKey' "guides" ( JSON.Encoder.list encodeGuide ) ( Map.elems $ documentGuides meta ) , "strokes" .= ( strokeHierarchyLayers ( layerMetadata meta ) ( strokeHierarchy documentContent ) )
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) ( 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 -> Maybe FilePath -> Hermes.Decoder Document
decodeDocument uniqueSupply mbFilePath = do decodeDocument uniqueSupply mbFilePath =
let Hermes.object do
unsavedChanges :: Bool let
unsavedChanges = False unsavedChanges :: Bool
mbLayers1 <- JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer ) unsavedChanges = False
-- Preserve back-compat (a previous format used 'content.strokes' instead of 'strokes'). mbLayers1 <- Hermes.atKeyOptional "strokes" ( Hermes.list ( decodeLayer uniqueSupply ) )
mbLayers2 <- JSON.Decoder.atKeyOptional "content" ( JSON.Decoder.atKeyOptional "strokes" ( JSON.Decoder.list decodeLayer ) ) -- Preserve back-compat (a previous format used 'content.strokes' instead of 'strokes').
let layers = fromMaybe [] mbLayers1 <> fromMaybe [] ( fromMaybe ( Just [] ) mbLayers2 ) mbLayers2 <- Hermes.atKeyOptional "content" ( Hermes.object $ Hermes.atKeyOptional "strokes" ( Hermes.list ( decodeLayer uniqueSupply ) ) )
( layerMetadata, strokeHierarchy ) <- lift $ ( `Reader.runReaderT` uniqueSupply ) $ layersStrokeHierarchy layers let layers = fromMaybe [] mbLayers1 <> fromMaybe [] ( fromMaybe ( Just [] ) mbLayers2 )
let documentContent = Content { unsavedChanges, strokeHierarchy } ( layerMetadata, strokeHierarchy ) <- ( `Reader.runReaderT` uniqueSupply ) $ layersStrokeHierarchy layers
documentMetadata <- decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata let documentContent = Content { unsavedChanges, strokeHierarchy }
pure ( Document { documentMetadata, documentContent } ) documentMetadata <- decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata
return $
Document
{ documentMetadata
, documentContent
}

367
src/metabrushes/MetaBrush/Serialisable.hs
View file

@ -2,39 +2,46 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module MetaBrush.Serialisable module MetaBrush.Serialisable
( Serialisable(..) ( Serialisable
, encodeSequence, decodeSequence
, encodeCurve, decodeCurve -- * FromJSON (using hermes-json)
, encodeCurves, decodeCurves , FromJSON(..)
, encodeSpline, decodeSpline , key, keyOptional
, decodeSequence
, decodeCurve
, decodeCurves
, decodeSpline
) )
where where
-- base -- base
import Data.Foldable
( toList )
import Data.Functor import Data.Functor
( (<&>) ) ( (<&>) )
import Data.Functor.Contravariant
( contramap )
import Data.Functor.Identity
( Identity(..) )
import Data.IORef import Data.IORef
( newIORef, atomicModifyIORef' ) ( newIORef, atomicModifyIORef' )
import Data.Traversable import Data.Maybe
( for ) ( fromMaybe )
import Unsafe.Coerce
( unsafeCoerce )
-- aeson
import Data.Aeson
( ToJSON(..), (.=) )
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson
-- containers -- containers
import Data.Sequence import Data.Sequence
( Seq ) ( Seq )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
( fromList ) ( empty, fromList )
-- scientific -- hermes-json
import qualified Data.Scientific as Scientific import qualified Data.Hermes as Hermes
( fromFloatDigits, toRealFloat )
-- text -- text
import Data.Text import Data.Text
@ -43,16 +50,6 @@ import Data.Text
-- transformers -- transformers
import Control.Monad.IO.Class import Control.Monad.IO.Class
( MonadIO(liftIO) ) ( 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 -- meta-brushes
import Math.Bezier.Spline import Math.Bezier.Spline
@ -67,197 +64,163 @@ import MetaBrush.Records
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
class Serialisable a where class ( Aeson.ToJSON a, FromJSON a ) => Serialisable a where
encoder :: Monad f => JSON.Encoder f a instance ( Aeson.ToJSON a, FromJSON a ) => Serialisable a where
decoder :: Monad m => JSON.Decoder m a
instance Serialisable Double where class FromJSON a where
encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific decoder :: Hermes.Decoder a
decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific
instance Serialisable ( ℝ 2 ) where instance FromJSON Bool where
encoder = JSON.Encoder.mapLikeObj \ ( ℝ2 x y ) -> decoder = Hermes.bool
JSON.Encoder.atKey' "x" encoder x instance FromJSON Double where
. JSON.Encoder.atKey' "y" encoder y decoder = Hermes.double
decoder = ℝ2 <$> JSON.Decoder.atKey "x" decoder instance FromJSON Text where
<*> JSON.Decoder.atKey "y" decoder decoder = Hermes.text
instance Serialisable ( T ( ℝ 2 ) ) where instance FromJSON a => FromJSON [a] where
encoder = JSON.Encoder.mapLikeObj \ ( V2 x y ) -> decoder = Hermes.list decoder
JSON.Encoder.atKey' "x" encoder x
. JSON.Encoder.atKey' "y" encoder y key :: FromJSON a => Text -> Hermes.FieldsDecoder a
decoder = V2 <$> JSON.Decoder.atKey "x" decoder key k = Hermes.atKey k decoder
<*> JSON.Decoder.atKey "y" 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 ) ) ) instance ( KnownSymbols ks, Representable Double ( ℝ ( Length ks ) ) )
=> Serialisable ( Record ks ) where => Aeson.ToJSON ( Record ks ) where
encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) ) toJSON r = Aeson.object $
where zip [1..] ( knownSymbols @ks ) <&> \ ( i, fld ) ->
encodeFields :: Record ks -> [ ( Text, Double ) ] ( Aeson.fromText fld .= index r ( Fin i ) )
encodeFields ( MkR r ) =
zip [1..] ( knownSymbols @ks ) <&> \ ( i, fld ) ->
( 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 where
decodeFields :: [ Double ] -> Record ks decodeFields :: [ Double ] -> Record ks
decodeFields coords = MkR $ tabulate \ ( Fin i ) -> decodeFields coords =
coords !! ( fromIntegral i - 1 ) MkR $ tabulate \ ( Fin i ) ->
coords !! ( fromIntegral i - 1 )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a ) instance ( SplineTypeI clo, Aeson.ToJSON ptData ) => Aeson.ToJSON ( Curve clo crvData ptData ) where
encodeSequence enc = contramap toList ( JSON.Encoder.list enc ) 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 :: Hermes.Decoder a -> Hermes.Decoder ( Seq a )
decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec decodeSequence dec = Seq.fromList <$> Hermes.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
decodeCurve decodeCurve
:: forall clo ptData crvData m :: forall clo ptData crvData
. ( SplineTypeI clo, MonadIO m ) . ( SplineTypeI clo, FromJSON ptData )
=> JSON.Decoder m ptData => Hermes.FieldsDecoder crvData
-> JSON.Decoder m crvData -> Hermes.Decoder ( Curve clo crvData ptData )
-> JSON.Decoder m ( Curve clo crvData ptData ) decodeCurve decodeCurveData = do
decodeCurve decodePtData decodeCrvData = do Hermes.object do
crv <- decodeCrvData crvData <- decodeCurveData
case ssplineType @clo of case ssplineType @clo of
SOpen -> do SOpen -> do
p1 <- JSON.Decoder.atKey "p1" decodePtData p1 <- key "p1"
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData mb_p2 <- keyOptional "p2"
case mb_p2 of case mb_p2 of
Nothing -> Nothing ->
pure ( LineTo ( NextPoint p1 ) crv) pure $ LineTo ( NextPoint p1 ) crvData
Just p2 -> do Just p2 -> do
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData mb_p3 <- keyOptional "p3"
case mb_p3 of case mb_p3 of
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) crv ) Nothing -> pure $ Bezier2To p1 ( NextPoint p2 ) crvData
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) crv ) Just p3 -> pure $ Bezier3To p1 p2 ( NextPoint p3 ) crvData
SClosed -> do SClosed -> do
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData mb_p1 <- keyOptional "p1"
case mb_p1 of case mb_p1 of
Nothing -> Nothing ->
pure ( LineTo BackToStart crv ) pure $ LineTo BackToStart crvData
Just p1 -> do Just p1 -> do
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData mb_p2 <- keyOptional "p2"
case mb_p2 of case mb_p2 of
Nothing -> pure ( Bezier2To p1 BackToStart crv ) Nothing -> pure $ Bezier2To p1 BackToStart crvData
Just p2 -> pure ( Bezier3To p1 p2 BackToStart crv ) Just p2 -> pure $ Bezier3To p1 p2 BackToStart crvData
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
decodeCurves decodeCurves
:: forall clo ptData crvData m :: forall clo ptData crvData
. ( SplineTypeI clo, MonadIO m ) . ( SplineTypeI clo, FromJSON ptData )
=> JSON.Decoder m ptData => Hermes.FieldsDecoder crvData
-> JSON.Decoder m crvData -> Hermes.Decoder ( Curves clo crvData ptData )
-> JSON.Decoder m ( Curves clo crvData ptData ) decodeCurves decodeCrvData = do
decodeCurves decodePtData decodeCrvData = case ssplineType @clo of case ssplineType @clo of
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData decodeCrvData ) SOpen -> do
SClosed -> do OpenCurves <$> decodeSequence ( decodeCurve @Open decodeCrvData )
mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text ) SClosed -> Hermes.object do
case mbNoCurves of mbLastCurve <- Hermes.atKeyOptional "lastClosedCurve" ( decodeCurve @Closed decodeCrvData )
Just _ -> pure NoCurves case mbLastCurve of
Nothing -> do Nothing -> pure NoCurves
prevCurves <- JSON.Decoder.atKey "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodePtData decodeCrvData ) Just lastCurve -> do
lastCurve <- JSON.Decoder.atKey "lastClosedCurve" ( decodeCurve @Closed decodePtData decodeCrvData ) prevCurves <- fromMaybe Seq.empty <$>
pure ( ClosedCurves prevCurves lastCurve ) Hermes.atKeyOptional "prevOpenCurves" ( decodeSequence $ decodeCurve @Open 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
decodeSpline decodeSpline
:: forall clo ptData crvData m :: forall clo ptData crvData
. ( SplineTypeI clo, MonadIO m ) . ( SplineTypeI clo, FromJSON ptData )
=> JSON.Decoder m ptData => ( Integer -> Hermes.FieldsDecoder crvData )
-> ( Integer -> m crvData ) -> Hermes.Decoder ( Spline clo crvData ptData )
-> JSON.Decoder m ( Spline clo crvData ptData ) decodeSpline newCurve = do
decodeSpline decodePtData newCurve = do ref <- liftIO $ newIORef 0
ref <- lift $ liftIO $ newIORef 0 let newCrvData :: Hermes.FieldsDecoder crvData
let newCrvData :: m crvData
newCrvData = do newCrvData = do
i <- liftIO $ atomicModifyIORef' ref ( \ o -> ( o + 1, o ) ) i <- liftIO $ atomicModifyIORef' ref ( \ o -> ( o + 1, o ) )
newCurve i newCurve i
splineStart <- JSON.Decoder.atKey "splineStart" decodePtData Hermes.object $ do
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData ( lift newCrvData ) ) splineStart <- key "splineStart"
pure ( Spline { splineStart, splineCurves } ) splineCurves <- Hermes.atKey "splineCurves" ( decodeCurves @clo newCrvData )
pure ( Spline { splineStart, splineCurves } )