encode/decode documents to JSON using waargonaut

This commit is contained in:
sheaf 2020-08-31 22:28:30 +02:00
parent 9c5f8b1198
commit 8a6b4f5391
9 changed files with 320 additions and 23 deletions

1
.gitignore vendored
View file

@ -10,3 +10,4 @@ img/examples
*.md
*.html
hie.yaml
*.mb

View file

@ -82,8 +82,6 @@ library
^>= 0.20.0.0
, vector
^>= 0.12.1.2
, QuickCheck
^>= 2.14.1
executable MetaBrush
@ -109,6 +107,7 @@ executable MetaBrush
, MetaBrush.Document
, MetaBrush.Document.Draw
, MetaBrush.Document.Selection
, MetaBrush.Document.Serialise
, MetaBrush.Event
, MetaBrush.Event.KeyCodes
, MetaBrush.Render.Document
@ -132,10 +131,10 @@ executable MetaBrush
build-depends:
MetaBrush
, bytestring
^>= 0.10.10.1
, directory
>= 1.3.4.0 && < 1.4
--, fingertree
-- >= 0.1.4.2 && < 0.2
, gi-gdk
>= 3.0.22 && < 3.1
, gi-gio
@ -152,9 +151,13 @@ executable MetaBrush
^>= 0.24
, lens
^>= 4.19.2
, scientific
^>= 0.3.6.2
, stm
^>= 2.5.0.0
, tardis
^>= 0.4.1.0
, text
^>= 1.2.3.1 && < 1.2.5
^>= 1.2.3.1 && < 1.2.5
, waargonaut
^>= 0.8.0.1

View file

@ -102,31 +102,51 @@ testDocuments = IntMap.fromList
$ zip [0..]
[ Document
{ displayName = "Closed"
, filePath = Nothing
, mbFilePath = Nothing
, unsavedChanges = False
, strokes = [ Stroke ( ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) ) "Ellipse" True ( unsafeUnique 0 )
]
, bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
, viewportCenter = Point2D 50 50
, zoomFactor = 1
, documentUnique = unsafeUnique 0
, strokes = [ Stroke
{ strokeName = "Ellipse"
, strokeVisible = True
, strokeUnique = unsafeUnique 10
, strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
}
]
}
, Document
{ displayName = "Line"
, filePath = Nothing
, mbFilePath = Nothing
, unsavedChanges = True
, strokes = [ Stroke linePts "Line" True ( unsafeUnique 1 ) ]
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 )
, viewportCenter = Point2D 0 0
, zoomFactor = 1
, documentUnique = unsafeUnique 1
, strokes = [ Stroke
{ strokeName = "Line"
, strokeVisible = True
, strokeUnique = unsafeUnique 11
, strokePoints = linePts
}
]
}
, Document
{ displayName = "Short line"
, filePath = Nothing
, mbFilePath = Nothing
, unsavedChanges = False
, strokes = [ Stroke linePts2 "ShortLine" True ( unsafeUnique 2 ) ]
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 )
, viewportCenter = Point2D 0 0
, zoomFactor = 1
, documentUnique = unsafeUnique 2
, strokes = [ Stroke
{ strokeName = "ShortLine"
, strokeVisible = True
, strokeUnique = unsafeUnique 12
, strokePoints = linePts2
}
]
}
]
where

View file

@ -3,6 +3,9 @@ packages: .
constraints:
acts -finitary
allow-newer:
waargonaut:*
-- fixes gi-cairo-render to work with haskell-gi >= 0.24
source-repository-package
type: git
@ -16,3 +19,9 @@ source-repository-package
location: https://github.com/haskell-numerics/hmatrix
tag: 08138810946c7eae2254feeb33269cd962d5e0c8
subdir: packages/base
-- adds MonadTrans Decoder instance to waargonaut Decoder
source-repository-package
type: git
location: https://github.com/sheaf/waargonaut
tag: dc835fb86d2592fa2e55753fa4eb7c59d6124699

View file

@ -64,21 +64,22 @@ data AABB
data Document
= Document
{ displayName :: !Text
, filePath :: !( Maybe FilePath )
, mbFilePath :: !( Maybe FilePath )
, unsavedChanges :: !Bool
, strokes :: ![ Stroke ]
, bounds :: !AABB
, viewportCenter :: !( Point2D Double )
, zoomFactor :: !Double
, documentUnique :: Unique
, strokes :: ![ Stroke ]
}
deriving stock ( Show, Generic )
data Stroke
= Stroke
{ strokePoints :: !( Seq ( StrokePoint PointData ) )
, strokeName :: Text
{ strokeName :: Text
, strokeVisible :: !Bool
, strokeUnique :: Unique
, strokePoints :: !( Seq ( StrokePoint PointData ) )
}
deriving stock ( Show, Generic )

View file

@ -84,10 +84,11 @@ getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
newDoc' =
over ( field' @"strokes" )
( Stroke
( Seq.singleton $ PathPoint c ( PointData Normal Empty ) )
( "Stroke " <> uniqueText uniq )
True
uniq
{ strokeName = "Stroke " <> uniqueText uniq
, strokeVisible = True
, strokeUnique = uniq
, strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty )
}
: )
newDoc
pure ( newDoc', AnchorAtEnd uniq, c )

View file

@ -0,0 +1,263 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module MetaBrush.Document.Serialise
( documentToJSON, documentFromJSON )
where
-- base
import qualified Data.Bifunctor as Bifunctor
( first )
import Data.Foldable
( toList )
import Data.Functor.Contravariant
( contramap )
-- bytestring
import qualified Data.ByteString as Strict
( ByteString )
import qualified Data.ByteString.Lazy as Lazy
( ByteString )
-- containers
import Data.Sequence
( Seq )
import qualified Data.Sequence as Seq
( fromList )
-- scientific
import qualified Data.Scientific as Scientific
( fromFloatDigits, toRealFloat )
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
-- text
import Data.Text
( Text )
-- transformers
import Control.Monad.IO.Class
( MonadIO(liftIO) )
import Control.Monad.Trans.Class
( MonadTrans(lift) )
-- waargonaut
import qualified Waargonaut.Attoparsec as JSON.Decoder
( decodeAttoparsecByteString )
import qualified Waargonaut.Decode as JSON
( Decoder )
import qualified Waargonaut.Decode.Error as JSON
( DecodeError )
import qualified Waargonaut.Decode as JSON.Decoder
( atKey, bool, list, oneOf, scientific, text )
import qualified Waargonaut.Encode as JSON
( Encoder, Encoder' )
import qualified Waargonaut.Encode as JSON.Encoder
( simplePureEncodeByteString
, atKey', bool, list, mapLikeObj, scientific, text
)
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Vector2D
( Point2D(..) ) --, Vector2D(..), Mat22(..) )
import MetaBrush.Document
( Document(..)
, AABB(..)
, Stroke(..)
, PointData(..)
, BrushPointData(..)
, FocusState(..)
)
import MetaBrush.Unique
( UniqueSupply, freshUnique )
--------------------------------------------------------------------------------
documentToJSON :: Document -> Lazy.ByteString
documentToJSON = JSON.Encoder.simplePureEncodeByteString encodeDocument
documentFromJSON :: UniqueSupply -> Maybe FilePath -> Strict.ByteString -> IO ( Either JSON.DecodeError Document )
documentFromJSON uniqueSupply mfp
= fmap ( Bifunctor.first fst )
. JSON.Decoder.decodeAttoparsecByteString ( decodeDocument uniqueSupply mfp )
--------------------------------------------------------------------------------
encodeDouble :: Applicative f => JSON.Encoder f Double
encodeDouble = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
decodeDouble :: Monad m => JSON.Decoder m Double
decodeDouble = fmap Scientific.toRealFloat JSON.Decoder.scientific
encodePoint2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Point2D a )
encodePoint2D enc = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
JSON.Encoder.atKey' "x" enc x . JSON.Encoder.atKey' "y" enc y
decodePoint2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Point2D a )
decodePoint2D dec = Point2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
{-
encodeVector2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a )
encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
JSON.Encoder.atKey' "x" enc x
. JSON.Encoder.atKey' "y" enc y
decodeVector2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Vector2D a )
decodeVector2D dec = Vector2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" 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
encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d )
encodeStrokePoint enc = JSON.Encoder.mapLikeObj \case
PathPoint { coords, pointData } ->
JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords
. JSON.Encoder.atKey' "data" enc pointData
. JSON.Encoder.atKey' "type" JSON.Encoder.text "path"
ControlPoint { coords, pointData } ->
JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords
. JSON.Encoder.atKey' "data" enc pointData
. JSON.Encoder.atKey' "type" JSON.Encoder.text "control"
decodeStrokePointTypeIsPath :: Monad m => JSON.Decoder m Bool
decodeStrokePointTypeIsPath = JSON.Decoder.oneOf JSON.Decoder.text "StrokePoint Type"
[ ( "path", True ), ( "control", False ) ]
decodeStrokePoint :: Monad m => JSON.Decoder m d -> JSON.Decoder m ( StrokePoint d )
decodeStrokePoint dec = do
coords <- JSON.Decoder.atKey "coords" ( decodePoint2D decodeDouble )
pointData <- JSON.Decoder.atKey "data" dec
isPathPoint <- JSON.Decoder.atKey "type" decodeStrokePointTypeIsPath
if isPathPoint
then pure ( PathPoint { coords, pointData } )
else pure ( ControlPoint { coords, pointData } )
encodeFocusState :: Applicative f => JSON.Encoder f FocusState
encodeFocusState = contramap focusText JSON.Encoder.text
where
focusText :: FocusState -> Text
focusText Normal = "normal"
focusText Hover = "hover"
focusText Selected = "selected"
decodeFocusState :: Monad m => JSON.Decoder m FocusState
decodeFocusState = JSON.Decoder.oneOf JSON.Decoder.text "FocusState"
[ ( "normal" , Normal )
, ( "hover" , Hover )
, ( "selected", Selected )
]
encodeBrushPointData :: Applicative f => JSON.Encoder f BrushPointData
encodeBrushPointData = JSON.Encoder.mapLikeObj \ ( BrushPointData { brushPointState } ) ->
JSON.Encoder.atKey' "focus" encodeFocusState brushPointState
decodeBrushPointData :: Monad m => JSON.Decoder m BrushPointData
decodeBrushPointData = do
brushPointState <- JSON.Decoder.atKey "focus" decodeFocusState
pure ( BrushPointData { brushPointState } )
encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a )
encodeSequence enc = contramap toList ( JSON.Encoder.list enc )
decodeSequence :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Seq a )
decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec
encodePointData :: Applicative f => JSON.Encoder f PointData
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) ->
JSON.Encoder.atKey' "focus" encodeFocusState pointState
. JSON.Encoder.atKey' "brush" ( encodeSequence ( encodeStrokePoint encodeBrushPointData ) ) brushShape
decodePointData :: Monad m => JSON.Decoder m PointData
decodePointData = do
pointState <- JSON.Decoder.atKey "focus" decodeFocusState
brushShape <- JSON.Decoder.atKey "brush" ( decodeSequence ( decodeStrokePoint decodeBrushPointData ) )
pure ( PointData { pointState, brushShape } )
encodeStroke :: Applicative f => JSON.Encoder f Stroke
encodeStroke = JSON.Encoder.mapLikeObj \ ( Stroke { strokeName, strokeVisible, strokePoints } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName
. JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible
. JSON.Encoder.atKey' "points" ( encodeSequence ( encodeStrokePoint encodePointData ) ) strokePoints
decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
decodeStroke uniqueSupply = do
strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text
strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
strokeUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
strokePoints <- JSON.Decoder.atKey "points" ( decodeSequence ( decodeStrokePoint decodePointData ) )
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokePoints } )
encodeDocument :: Applicative f => JSON.Encoder f Document
encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, bounds, viewportCenter, zoomFactor, strokes } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
. JSON.Encoder.atKey' "bounds" encodeAABB bounds
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
decodeDocument uniqueSupply mbFilePath = do
displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text
let
unsavedChanges :: Bool
unsavedChanges = False
bounds <- JSON.Decoder.atKey "bounds" decodeAABB
viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
pure ( Document { displayName, mbFilePath, unsavedChanges, bounds, viewportCenter, zoomFactor, documentUnique, strokes } )

View file

@ -160,7 +160,8 @@ renderDocument
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint finalPoint ( PointData Normal Empty ) )
]
= ( Stroke previewPts undefined True undefined ) : strokes doc
= ( Stroke { strokePoints = previewPts, strokeVisible = True, strokeUnique = undefined, strokeName = undefined } )
: strokes doc
| otherwise
= strokes doc

View file

@ -65,8 +65,6 @@ import Math.Roots
import Math.Vector2D
( Mat22(..), Point2D(..), Vector2D(..) )
import Debug.Trace
--------------------------------------------------------------------------------
-- | Fits a cubic Bézier spline to the given curve \( t \mapsto C(t), 0 \leqslant t \leqslant 1 \),