{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE 
    DeriveDataTypeable
  , DeriveFunctor
  , FlexibleInstances
  , GeneralizedNewtypeDeriving 
  #-}

{-|
Module      : Diagrams.Backend.HsQML.DiagramObj.Type 
Description : Definition of DiagramObj.
Copyright   : (c) Marcin Mrotek, 2015
License     : BSD-3
Maintainer  : marcin.jan.mrotek@gmail.com
Stability   : experimental

The 'DiagramObj' type, together with a corresponding 'DefaultClass' instance that defines the necessary methods and signals for use by QML.
-} 


module Diagrams.Backend.HsQML.DiagramObj.Type where 

import Diagrams.Backend.HsQML.DiagramObj.Signals

import Control.Monad.IO.Class
import Data.Typeable

import Graphics.QML
import Graphics.QML.Objects.ParamNames

{-|
The type to which the parts of a diagram are rendered. 
The end result of rendering is always a DiagramObj ().
The monoid instance sequences actions on the same argument, with noop as identity.
As DiagramObj is a wrapper over a function to IO, 'Functor', 'Applicative', 'Monad', and 'MonadIO' instances are defined in an expected way.
-}
newtype DiagramObj a = DiagramObj { 
-- |Function called on every repaint of the QML.
-- The 'ObjRef' is necessary to fire signals into QML.
    reload :: ObjRef (DiagramObj ()) -> IO a 
   }
  deriving (Functor, Typeable)

instance Monoid a => Monoid (DiagramObj a) where
   mempty = DiagramObj $ \_ -> return mempty
   (DiagramObj r1) `mappend` (DiagramObj r2) = 
     DiagramObj $ \this -> do
        a <- r1 this
        b <- r2 this
        return $ a `mappend` b

instance Applicative DiagramObj where
   pure a = DiagramObj $ \_ -> return a
   (DiagramObj f') <*> (DiagramObj x') =
     DiagramObj $ \this -> do
        f <- f' this
        x <- x' this
        return $ f x

instance Monad DiagramObj where
   return a = DiagramObj $ \_ -> return a
   (DiagramObj a') >>= f' = 
      DiagramObj $ \this -> do
        a <- a' this
        let DiagramObj f = f' a
        f this

instance MonadIO DiagramObj where
   liftIO m = DiagramObj $ \_ -> m

instance DefaultClass (DiagramObj ()) where
  classMembers = 
    [ defMethod' "reload" $ \this -> reload (fromObjRef this) this
    , defSignal "save"            save
    , defSignal "restore"         restore
    , defSignal "stroke"          stroke
    , defSignal "fill"            fill
    , defSignal "beginPath"       beginPath
    , defSignal "closePath"       closePath
    , defSignal "setLineGradient" setLineGradient
    , defSignal "setFillGradient" setFillGradient
    , defSignal "oddEvenFill" oddEvenFill
    , defSignal "windingFill" windingFill
    , defSignalNamedParams  "text" renderText
    $ fstName "text" `plusName` "x" `plusName` "y"
    , defSignalNamedParams  "moveTo"        moveTo
    $ fstName "x" `plusName` "y"
    , defSignalNamedParams  "lineTo"        lineTo
    $ fstName "x" `plusName` "y"
    , defSignalNamedParams  "bezierCurveTo" bezierCurveTo
    $ fstName  "cp1x" `plusName` "cp1y" 
    `plusName` "cp2x" `plusName` "cp2y"
    `plusName`    "x" `plusName`    "y"
    , defSignalNamedParams "connectLinearGradient" connectLinearGradient
    $ fstName "gradient"
    `plusName` "x0" `plusName` "yo"
    `plusName` "x1" `plusName` "y1"
    , defSignalNamedParams "connectRadialGradient" connectRadialGradient
    $ fstName "gradient"
    `plusName` "x0" `plusName` "yo" `plusName` "r0"
    `plusName` "x1" `plusName` "y1" `plusName` "r1"
    , defSignalNamedParams "setStrokeColour" setStrokeColour
    $ fstName "r" `plusName` "g" `plusName` "b" `plusName` "a"
    , defSignalNamedParams "setFillColour" setFillColour
    $ fstName "r" `plusName` "g" `plusName` "b" `plusName` "a"
    , defSignalNamedParams "setFont" setFont
    $ fstName "font" 
    , defSignalNamedParams "setLineWidth" setLineWidth
    $ fstName "setLineWidth"
    ]