mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53: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
|
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
|
|
||||||
|
|
|
||||||
|
|
@ -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 --
|
||||||
|
|
|
||||||
|
|
@ -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 {..} )
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
}
|
||||||
|
|
|
||||||
|
|
@ -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 } )
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue