metabrush/src/metabrushes/MetaBrush/Brush.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE QuantifiedConstraints#-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

module MetaBrush.Brush
  ( Brush(..), SomeBrush(..)
  , BrushFunction
  , SomeFieldSType(..), SomeBrushFields(..)
  , reflectBrushFieldsNoDups
  )
  where

-- base
import Control.Arrow
  ( second )
import GHC.Exts
  ( Proxy#, Any )
import Unsafe.Coerce
  ( unsafeCoerce )

-- deepseq
import Control.DeepSeq
  ( NFData(..), deepseq )

-- hashable
import Data.Hashable
  ( Hashable(..) )

-- text
import Data.Text
  ( Text )
import qualified Data.Text as Text
  ( unpack )

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

-- MetaBrush
import Math.Bezier.Spline
  ( SplineType(Closed), SplinePts)
import MetaBrush.Serialisable
  ( Serialisable )
import MetaBrush.DSL.Types
  ( STypeI, STypesI(sTypesI)
  , SomeSType(..), proveSomeSTypes
  )
import MetaBrush.DSL.Interpolation
  ( Interpolatable(..) )
import MetaBrush.Records
  ( Record(MkR), Rec, AllFields
  , WithParams(..)
  , Dict(..)
  , proveRecordDicts
  )
import qualified MetaBrush.Records as Rec
  ( map )

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

type BrushFunction brushFields = WithParams brushFields (SplinePts Closed)

data Brush brushFields where
  BrushData
    :: forall brushFields
    .  ( STypesI brushFields )
    =>
      { brushName     :: !Text
      , brushCode     :: !Text
      , brushFunction :: BrushFunction brushFields
      }
    -> Brush brushFields

data SomeBrush where
  SomeBrush
    :: STypesI brushFields
    => { someBrush :: !( Brush brushFields ) }
    -> SomeBrush

instance Show ( Brush brushFields ) where
  show ( BrushData { brushName, brushCode } ) =
    "BrushData\n\
    \  { brushName = "  <> Text.unpack brushName <> "\n\
    \  , brushCode =\n" <> Text.unpack brushCode <> "\n\
    \  }"
instance NFData ( Brush brushFields ) where
  rnf ( BrushData { brushName, brushCode } )
    = deepseq brushCode
    $ rnf brushName
instance Eq ( Brush brushFields ) where
  BrushData name1 code1 _ == BrushData name2 code2 _ = name1 == name2 && code1 == code2
instance Ord ( Brush brushFields ) where
  compare ( BrushData name1 code1 _ ) ( BrushData name2 code2 _ ) = compare ( name1, code1 ) ( name2, code2 )
instance Hashable ( Brush brushFields ) where
  hashWithSalt salt ( BrushData { brushName, brushCode } ) =
    hashWithSalt ( hashWithSalt salt brushName ) brushCode

--------------------------------------------------------------------------------
-- Instance dictionary passing machinery.

-- | Existential type over an allowed record field type used in brushes, such as Double and Point2D Double.
data SomeFieldSType where
  SomeFieldSType
    :: ( STypeI a, Show a, NFData a, Interpolatable a, Serialisable a )
    => SomeFieldSType

data FieldSType a where
  FieldSType
    :: ( STypeI a, Show a, NFData a, Interpolatable a, Serialisable a )
    => FieldSType a

-- | Existential type for allowed fields of a brush record.
data SomeBrushFields where
  SomeBrushFields
    :: forall kvs rec
    . ( STypesI kvs
      , rec ~ Rec kvs
      , Show rec, NFData rec
      , Serialisable rec
      , AllFields Interpolatable kvs
      )
    => SomeBrushFields

instance Show SomeBrushFields where
  show ( SomeBrushFields @kvs ) = show ( sTypesI @kvs )

-- | Reflects a list of brush fields to the type level.
--
-- Assumes the input list has no duplicate field names,
-- but they don't have to be sorted.
reflectBrushFieldsNoDups :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields
reflectBrushFieldsNoDups elts =
  let
    mkSomeSType :: SomeFieldSType -> SomeSType
    mkSomeSType (SomeFieldSType @a) = SomeSType @a
    mkField :: SomeFieldSType -> FieldSType Any
    mkField (SomeFieldSType @a) = unsafeCoerce $ FieldSType @a
  in
  proveSomeSTypes (map (second mkSomeSType) elts) \ ( _ :: Proxy# kvs ) ->
    let
      dictsRec :: Record FieldSType kvs
      dictsRec = MkR (HashMap.fromList $ map (second mkField) elts)
      showDicts :: Record (Dict Show) kvs
      showDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Show @a ) dictsRec
      nfDataDicts :: Record (Dict NFData) kvs
      nfDataDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @NFData @a ) dictsRec
      serialisableDicts :: Record (Dict Serialisable) kvs
      serialisableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Serialisable @a ) dictsRec
      interpolatableDicts :: Record (Dict Interpolatable) kvs
      interpolatableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Interpolatable @a ) dictsRec
    in
      proveRecordDicts @Show           showDicts $
      proveRecordDicts @NFData         nfDataDicts $
      proveRecordDicts @Serialisable   serialisableDicts $
      proveRecordDicts @Interpolatable interpolatableDicts $
        SomeBrushFields @kvs