Serialisable.hs

{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module BrushStroking.Serialisable
  ( Serialisable

  -- * FromJSON (using hermes-json)
  , FromJSON(..)
  , key, keyOptional

  , decodeSequence
  , decodeCurve
  , decodeCurves
  , decodeSpline
  )
  where

-- base
import Data.Functor
  ( (<&>) )
import Data.IORef
  ( newIORef, atomicModifyIORef' )
import Data.Maybe
  ( fromMaybe )
import Unsafe.Coerce
  ( unsafeCoerce )

-- aeson
import Data.Aeson
  ( ToJSON(..), (.=) )
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson

-- containers
import Data.Sequence
  ( Seq )
import qualified Data.Sequence as Seq
  ( empty, fromList )

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

-- text
import Data.Text
  ( Text )

-- transformers
import Control.Monad.IO.Class
  ( MonadIO(liftIO) )

-- meta-brushes
import Math.Bezier.Spline
  ( Spline(..), SplineType(..), SSplineType(..), SplineTypeI(..)
  , Curves(..), Curve(..), NextPoint(..)
  )
import Math.Linear
  ( ℝ(..), T(..)
  , Fin(..), Representable(tabulate, index)
  )
import BrushStroking.Records

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

class    ( Aeson.ToJSON a, FromJSON a ) => Serialisable a where
instance ( Aeson.ToJSON a, FromJSON a ) => Serialisable a where

class FromJSON a where
  decoder :: Hermes.Decoder a

instance FromJSON Bool where
  decoder = Hermes.bool
instance FromJSON Double where
  decoder = Hermes.double
instance FromJSON Text where
  decoder = Hermes.text
instance FromJSON a => FromJSON [a] where
  decoder = Hermes.list decoder

key :: FromJSON a => Text -> Hermes.FieldsDecoder a
key k = Hermes.atKey k 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 ) ) )
      => Aeson.ToJSON ( Record ks ) where
  toJSON r = Aeson.object $
    zip [1..] ( knownSymbols @ks ) <&> \ ( i, fld ) ->
      ( Aeson.fromText fld .= index r ( Fin i ) )

instance ( KnownSymbols ks, Representable Double ( ℝ ( Length ks ) ) )
      => FromJSON ( Record ks ) where
  decoder =
    Hermes.object $
      decodeFields <$>
        traverse key ( knownSymbols @ks )
    where
      decodeFields :: [ Double ] -> Record ks
      decodeFields coords =
        MkR $ tabulate \ ( Fin i ) ->
          coords !! ( fromIntegral i - 1 )

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

instance ( SplineTypeI clo, Aeson.ToJSON ptData ) => Aeson.ToJSON ( Curve clo crvData ptData ) where
  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 :: Hermes.Decoder a -> Hermes.Decoder ( Seq a )
decodeSequence dec = Seq.fromList <$> Hermes.list dec

decodeCurve
  :: forall clo ptData crvData
  .  ( SplineTypeI clo, FromJSON ptData )
  => Hermes.FieldsDecoder crvData
  -> Hermes.Decoder ( Curve clo crvData ptData )
decodeCurve decodeCurveData = do
  Hermes.object do
    crvData <- decodeCurveData
    case ssplineType @clo of
      SOpen   -> do
        p1    <- key "p1"
        mb_p2 <- keyOptional "p2"
        case mb_p2 of
          Nothing ->
            pure $ LineTo ( NextPoint p1 ) crvData
          Just p2 -> do
            mb_p3 <- keyOptional "p3"
            case mb_p3 of
              Nothing -> pure $ Bezier2To    p1 ( NextPoint p2 ) crvData
              Just p3 -> pure $ Bezier3To p1 p2 ( NextPoint p3 ) crvData
      SClosed -> do
        mb_p1 <- keyOptional "p1"
        case mb_p1 of
          Nothing ->
            pure $ LineTo BackToStart crvData
          Just p1 -> do
            mb_p2 <- keyOptional "p2"
            case mb_p2 of
              Nothing -> pure $ Bezier2To    p1 BackToStart crvData
              Just p2 -> pure $ Bezier3To p1 p2 BackToStart crvData

decodeCurves
  :: forall clo ptData crvData
  .  ( SplineTypeI clo, FromJSON ptData )
  => Hermes.FieldsDecoder crvData
  -> Hermes.Decoder ( Curves clo crvData ptData )
decodeCurves decodeCrvData = do
  case ssplineType @clo of
    SOpen   -> do
      OpenCurves <$> decodeSequence ( decodeCurve @Open decodeCrvData )
    SClosed -> Hermes.object do
      mbLastCurve <- Hermes.atKeyOptional "lastClosedCurve" ( decodeCurve @Closed decodeCrvData )
      case mbLastCurve of
        Nothing -> pure NoCurves
        Just lastCurve -> do
          prevCurves <- fromMaybe Seq.empty <$>
                        Hermes.atKeyOptional "prevOpenCurves"  ( decodeSequence $ decodeCurve @Open   decodeCrvData )
          pure ( ClosedCurves prevCurves lastCurve )

decodeSpline
  :: forall clo ptData crvData
  .  ( SplineTypeI clo, FromJSON ptData )
  => ( Integer -> Hermes.FieldsDecoder crvData )
  -> Hermes.Decoder ( Spline clo crvData ptData )
decodeSpline newCurve = do
  ref <- liftIO $ newIORef 0
  let newCrvData :: Hermes.FieldsDecoder crvData
      newCrvData = do
        i <- liftIO $ atomicModifyIORef' ref ( \ o -> ( o + 1, o ) )
        newCurve i
  Hermes.object $ do
    splineStart  <- key "splineStart"
    splineCurves <- Hermes.atKey "splineCurves" ( decodeCurves @clo newCrvData )
    pure ( Spline { splineStart, splineCurves } )