encode/decode documents to JSON using waargonaut

.gitignore

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

MetaBrush.cabal

@@ -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

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

cabal.project

@@ -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

src/app/MetaBrush/Document.hs

@@ -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 )
 

src/app/MetaBrush/Document/Draw.hs

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

src/app/MetaBrush/Document/Serialise.hs

@@ -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 } )

src/app/MetaBrush/Render/Document.hs

@@ -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
     

src/lib/Math/Bezier/Cubic/Fit.hs

@@ -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 \),