mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
encode/decode documents to JSON using waargonaut
This commit is contained in:
sheaf
parent
9c5f8b1198
commit
8a6b4f5391
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -10,3 +10,4 @@ img/examples
|
|||
*.md
|
||||
*.html
|
||||
hie.yaml
|
||||
*.mb
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
34
app/Main.hs
34
app/Main.hs
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
263
src/app/MetaBrush/Document/Serialise.hs
Normal file
263
src/app/MetaBrush/Document/Serialise.hs
Normal 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 } )
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 \),
|
||||
|
|
|
|||
Loading…
Reference in a new issue