Serialise.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module BrushStroking.Document.Serialise
  ( documentToJSON, documentFromJSON
  , saveDocument, loadDocument
  )
  where

-- base
import Control.Monad
  ( unless )
import Control.Monad.ST
  ( RealWorld, stToIO )
import Control.Exception
  ( try )
import qualified Data.Bifunctor as Bifunctor
  ( first )
import Data.Maybe
  ( fromMaybe, maybeToList )
import Data.STRef
  ( newSTRef )
import Data.Traversable
  ( for )
import Data.Version
  ( Version(versionBranch) )
import GHC.Exts
  ( Proxy# )

-- aeson
import Data.Aeson
  ( (.=) )
import qualified Data.Aeson as Aeson

-- aeson-pretty
import qualified Data.Aeson.Encode.Pretty as PrettyAeson

-- atomic-file-ops
import System.IO.AtomicFileOps
  ( atomicReplaceFile )

-- bytestring
import qualified Data.ByteString as Strict
  ( ByteString )
import qualified Data.ByteString as Strict.ByteString
  ( readFile )
import qualified Data.ByteString.Lazy as Lazy
  ( ByteString )

-- containers
import qualified Data.Map.Strict as Map

-- directory
import System.Directory
  ( canonicalizePath, createDirectoryIfMissing, doesFileExist )

-- filepath
import System.FilePath
  ( takeDirectory )

-- hermes-json
import qualified Data.Hermes as Hermes

-- stm
import qualified Control.Concurrent.STM as STM
  ( atomically )

-- text
import Data.Text
  ( Text )
import qualified Data.Text as Text
  ( pack, unwords, unpack )

-- transformers
import Control.Monad.IO.Class
  ( MonadIO(liftIO) )
import qualified Control.Monad.Trans.Reader as Reader

-- unordered-containers
import Data.HashMap.Strict
  ( HashMap )
import qualified Data.HashMap.Strict as HashMap

-- brush-strokes
import Math.Bezier.Spline
  ( SplineType(..), SSplineType(..), SplineTypeI(..) )
import Math.Bezier.Stroke
  ( CachedStroke(..) )
import Math.Linear
  ( ℝ(..) )

-- MetaBrush
import BrushStroking.Brush
  ( provePointFields, duplicates )
import BrushStroking.Document
import BrushStroking.Layer
  ( LayerMetadata(..) )
import BrushStroking.Serialisable
import BrushStroking.Stroke
import BrushStroking.Records
  ( Record, knownSymbols )
import BrushStroking.Unique
  ( UniqueSupply, freshUnique )
import qualified Paths_brush_stroking as Cabal
  ( version )

--------------------------------------------------------------------------------

-- | Serialise a document to JSON (in the form of a lazy bytestring).
documentToJSON :: Document -> Lazy.ByteString
documentToJSON = PrettyAeson.encodePretty' $
  PrettyAeson.Config
    { PrettyAeson.confIndent    = PrettyAeson.Spaces 4
    , PrettyAeson.confCompare   = compFn
    , PrettyAeson.confNumFormat = PrettyAeson.Generic
    , PrettyAeson.confTrailingNewline = False
    }
    where
      order :: HashMap Text Int
      order =
        HashMap.fromList $
          zip
            [ "version", "name", "zoom", "center", "strokes", "splineStart", "point", "coords", "closed" ]
            [ 0 .. ]
      compFn :: Text -> Text -> Ordering
      compFn x y
        | x == y
        = EQ
        | let mbIx1 = HashMap.lookup x order
              mbIx2 = HashMap.lookup y order
        = case ( mbIx1, mbIx2 ) of
            ( Nothing, Just {} ) -> GT
            ( Just {}, Nothing ) -> LT
            ( Just i1, Just i2 ) -> compare i1 i2
            ( Nothing, Nothing ) -> compare x y

-- | Parse a document from JSON (given by a strict bytestring).
--
-- Updates the store of brushes by adding any new brushes contained in the document.
documentFromJSON
  :: UniqueSupply
  -> Maybe FilePath
  -> Strict.ByteString
  -> IO ( Either Text Document )
documentFromJSON uniqueSupply mbFilePath docData = do
  mbDoc <-
    try @Hermes.HermesException $
      Hermes.decodeEitherIO ( decodeDocument uniqueSupply mbFilePath ) docData
  return $ Bifunctor.first Hermes.formatException mbDoc

--------------------------------------------------------------------------------

-- | Save a MetaBrush document to a file (in JSON format).
saveDocument :: FilePath -> Document -> IO ()
saveDocument path doc = do
  path' <- canonicalizePath path
  let
    dir :: FilePath
    dir = takeDirectory path'
  createDirectoryIfMissing True dir
  exists <- doesFileExist path
  unless exists do
    writeFile path ""
  atomicReplaceFile Nothing path' ( documentToJSON doc )

-- | Load a MetaBrush document.
loadDocument :: UniqueSupply -> FilePath -> IO ( Either Text Document )
loadDocument uniqueSupply fp = do
  exists <- doesFileExist fp
  if exists
  then ( documentFromJSON uniqueSupply ( Just fp ) =<< Strict.ByteString.readFile fp )
  else pure ( Left $ "No file at " <> Text.pack fp )

--------------------------------------------------------------------------------

instance Aeson.ToJSON brushParams => Aeson.ToJSON ( PointData brushParams ) where
  toJSON ( PointData { pointCoords, brushParams } ) =
    Aeson.object
      [ "coords"      .= pointCoords
      , "brushParams" .= brushParams ]

instance FromJSON brushParams => FromJSON ( PointData brushParams ) where
  decoder =
    Hermes.object $ do
      pointCoords <- key "coords"
      brushParams <- key "brushParams"
      pure ( PointData { pointCoords, brushParams } )

decodeFields :: Hermes.Decoder [ Text ]
decodeFields = do
  fields <- Hermes.list Hermes.text
  case duplicates fields of
    []    -> pure fields
    [dup] -> fail ( "Duplicate field name " <> Text.unpack dup <> " in brush record type" )
    dups  -> fail ( "Duplicate field names in brush record type:\n" <> Text.unpack ( Text.unwords dups ) )


instance Aeson.ToJSON Stroke where
  toJSON
    ( Stroke
      { strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields )
      , strokeBrushName
      }
    ) =
    let
      closed :: Bool
      closed = case ssplineType @clo of
        SClosed -> True
        SOpen   -> False
      mbEncodeBrush = case strokeBrushName of
        Nothing      -> []
        Just brushNm -> [ "brush" .= Aeson.object [ "name" .= brushNm ] ]
    in
      Aeson.object $
        [ "closed" .= closed
        , "pointFields" .= knownSymbols @pointFields
        , "spline" .= strokeSpline
        ] ++ mbEncodeBrush

newCurveData :: Integer -> Hermes.FieldsDecoder ( CurveData RealWorld )
newCurveData i = do
  emptyCache <- liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
  return $
    CurveData
      { curveIndex   = fromInteger i
      , cachedStroke = emptyCache
      }

instance FromJSON Stroke where
  decoder = Hermes.object do
    strokeClosed  <- key         "closed"
    mbBrushNm     <- Hermes.atKeyOptional "brush" $ Hermes.object $ key "name"
    pointFields   <- Hermes.atKey "pointFields" decodeFields
    -- decodeFields ensured there were no duplicate field names.
    provePointFields pointFields \ ( _ :: Proxy# pointFields ) ->
      if strokeClosed
      then do
        strokeSpline <- Hermes.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) newCurveData )
        pure $ case mbBrushNm of
          Nothing ->
            Stroke { strokeSpline, strokeBrushName = Nothing }
          Just brushNm ->
            Stroke { strokeSpline, strokeBrushName = Just brushNm }
      else do
        strokeSpline <- Hermes.atKey "spline" ( decodeSpline @Open   @( PointData ( Record pointFields ) ) newCurveData )
        pure $ case mbBrushNm of
          Nothing ->
            Stroke { strokeSpline, strokeBrushName = Nothing }
          Just brushNm ->
            Stroke { strokeSpline, strokeBrushName = Just brushNm }

instance Aeson.ToJSON Layer where
  toJSON layer =
    Aeson.object $
      [ "name" .= layerName layer
      ] ++ ( if layerVisible layer then [ ] else [ "visible" .= False ] )
        ++ ( if layerLocked  layer then [ "locked" .= True ] else [] )
        ++ case layer of
        GroupLayer { groupChildren } ->
          [ "contents" .= groupChildren ]
        StrokeLayer { layerStroke } ->
          [ "stroke" .= layerStroke ]

decodeLayer :: UniqueSupply -> Hermes.Decoder Layer
decodeLayer uniqueSupply = Hermes.object $ do
    mbLayerName     <- keyOptional "name"
    mbLayerVisible  <- keyOptional "visible"
    mbLayerLocked   <- keyOptional "locked"
    let layerVisible = fromMaybe True  mbLayerVisible
        layerLocked  = fromMaybe False mbLayerLocked
    mbLayerStroke <- keyOptional "stroke"
    case mbLayerStroke of
      Nothing -> do
        let layerName = fromMaybe "Group" mbLayerName
        groupChildren <- fromMaybe [] <$> Hermes.atKeyOptional "contents" ( Hermes.list ( decodeLayer uniqueSupply ) )
        pure ( GroupLayer { layerName, layerVisible, layerLocked, groupChildren } )
      Just layerStroke -> do
        let layerName = fromMaybe "Stroke" mbLayerName
        pure ( StrokeLayer { layerName, layerVisible, layerLocked, layerStroke } )


instance Aeson.ToJSON Guide where
  toJSON ( Guide { guidePoint, guideNormal } ) =
    Aeson.object
      [ "point" .= guidePoint, "normal" .= guideNormal ]

instance FromJSON Guide where
  decoder = Hermes.object do
    guidePoint  <- key "point"
    guideNormal <- key "normal"
    return $ Guide { guidePoint, guideNormal }

instance Aeson.ToJSON DocumentSize where
  toJSON ( DocumentSize { documentTopLeft = p1, documentBottomRight = p2 } ) =
    Aeson.toJSON [ p1, p2 ]
instance FromJSON DocumentSize where
  decoder = do
    xys <- Hermes.list decoder
    case xys of
      [ ℝ2 x1 y1, ℝ2 x2 y2 ] ->
        return $
          DocumentSize
            { documentTopLeft     = ℝ2 ( min x1 x2 ) ( min y1 y2 )
            , documentBottomRight = ℝ2 ( max x1 x2 ) ( max y1 y2 )
            }
      _ -> fail $ unlines
             [ "Cannot parse 'DocumentSize'."
             , "Expected 2 points, but got: " ++ show ( length xys ) ++ "."
             ]

decodeDocumentMetadata
  :: UniqueSupply
  -> Maybe FilePath
  -> LayerMetadata
  -> Hermes.FieldsDecoder DocumentMetadata
decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do
  mbDocName      <- keyOptional "name"
  mbCenter       <- keyOptional "center"
  zoomFactor     <- keyOptional "zoom"
  guides         <- keyOptional "guides"
  mbDocSize      <- keyOptional "size"
  documentGuides <- fmap Map.fromList . liftIO . STM.atomically $
    for ( fromMaybe [] guides ) $ \ guide -> do
      u <- Reader.runReaderT freshUnique uniqueSupply
      return ( u, guide )
  return $
    Metadata
      { documentName     = fromMaybe ( documentName defaultMeta ) mbDocName
      , documentFilePath = mbFilePath
      , viewportCenter   = fromMaybe ( viewportCenter defaultMeta ) mbCenter
      , documentZoom     = maybe ( Zoom 1 ) Zoom zoomFactor
      , documentGuides
      , layerMetadata
      , selectedPoints   = mempty
      , documentSize     = mbDocSize
      }
  where
    defaultMeta = documentMetadata $ emptyDocument "Document"

instance Aeson.ToJSON Document where
  toJSON ( Document { documentMetadata = meta, documentContent } ) =
    Aeson.object $
      [ "version" .= versionBranch Cabal.version
      , "name"    .= documentName meta
      ] ++
      [ "size"    .= sz | sz <- maybeToList ( documentSize meta ) ]
        ++
      [ "center"  .= viewportCenter meta
      , "zoom"    .= ( zoomFactor $ documentZoom meta )
      , "strokes" .= ( strokeHierarchyLayers ( layerMetadata meta ) ( strokeHierarchy documentContent ) )
      ] ++ if null guides then [] else [ "guides" .= guides ]
      where
        guides = Map.elems $ documentGuides meta

decodeDocument :: UniqueSupply -> Maybe FilePath -> Hermes.Decoder Document
decodeDocument uniqueSupply mbFilePath =
  Hermes.object do
    let
      unsavedChanges :: Bool
      unsavedChanges = False
    mbLayers1 <- Hermes.atKeyOptional "strokes" ( Hermes.list ( decodeLayer uniqueSupply ) )
    -- Preserve back-compat (a previous format used 'content.strokes' instead of 'strokes').
    mbLayers2 <- Hermes.atKeyOptional "content" ( Hermes.object $ Hermes.atKeyOptional "strokes" ( Hermes.list ( decodeLayer uniqueSupply ) ) )
    let layers = fromMaybe [] mbLayers1 <> fromMaybe [] ( fromMaybe ( Just [] ) mbLayers2 )
    ( layerMetadata, strokeHierarchy ) <- ( `Reader.runReaderT` uniqueSupply ) $ layersStrokeHierarchy layers
    let documentContent = Content { unsavedChanges, strokeHierarchy }
    documentMetadata <- decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata
    return $
      Document
        { documentMetadata
        , documentContent
        }