mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 06:43:37 +00:00
Migrate waargonaut -> {aeson, aeson-pretty, hermes-json}
This commit is contained in:
sheaf
parent
60287fbf7e
commit
7b1dcefd46
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
|
|
|
|||
|
|
@ -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 {..} )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 } )
|
||||
|
|
|
|||
Loading…
Reference in a new issue