content: {-# language CPP #-}
  {-# language QuasiQuotes #-}
  {-# language TemplateHaskell #-}
  
  #ifndef ENABLE_INTERNAL_DOCUMENTATION
  {-# OPTIONS_HADDOCK hide #-}
  #endif
  
  module OpenCV.Internal.Core.Types.Rect.TH
    ( mkRectType
    ) where
  
  import "base" Data.Monoid ( (<>) )
  import "base" Foreign.Marshal.Utils ( toBool )
  import "base" System.IO.Unsafe ( unsafePerformIO )
  import qualified "inline-c" Language.C.Inline.Unsafe as CU
  import "linear" Linear.Vector ( (^+^) )
  import "linear" Linear.V2 ( V2(..) )
  import "template-haskell" Language.Haskell.TH
  import "template-haskell" Language.Haskell.TH.Quote ( quoteExp )
  import "this" OpenCV.Core.Types.Point
  import "this" OpenCV.Core.Types.Size
  import "this" OpenCV.Internal
  import "this" OpenCV.Internal.C.FinalizerTH
  import "this" OpenCV.Internal.C.PlacementNew.TH ( mkPlacementNewInstance )
  import "this" OpenCV.Internal.C.Types
  import "this" OpenCV.Internal.Core.Types.Rect
  
  --------------------------------------------------------------------------------
  
  mkRectType
      :: String -- ^ Rectangle type name, for both Haskell and C
      -> Name   -- ^ Depth type name in Haskell
      -> Name   -- ^ Rectangle C proxy type name
      -> String -- ^ Depth type name in C
      -> String -- ^ Point type name in C
      -> String -- ^ Size type name in C
      -> Q [Dec]
  mkRectType rTypeNameStr depthTypeName cProxyTypeName cDepthTypeStr cPointTypeStr cSizeTypeStr =
      fmap concat . sequence $
        [ (:[]) <$> rectTySynD
        , fromPtrDs
        , isRectOpenCVInstanceDs
        , isRectHaskellInstanceDs
        , mkPlacementNewInstance rTypeName
        , mkFinalizer DeletePtr finalizerNameStr cRectTypeStr cProxyTypeName
        ]
    where
      rTypeName :: Name
      rTypeName = mkName rTypeNameStr
  
      cRectTypeStr :: String
      cRectTypeStr = rTypeNameStr
  
      rTypeQ :: Q Type
      rTypeQ = conT rTypeName
  
      depthTypeQ :: Q Type
      depthTypeQ = conT depthTypeName
  
      rectTySynD :: Q Dec
      rectTySynD =
          tySynD rTypeName [] ([t|Rect|] `appT` depthTypeQ)
  
      finalizerNameStr :: String
      finalizerNameStr = "delete" <> rTypeNameStr
  
      finalizerName :: Name
      finalizerName = mkName finalizerNameStr
  
      fromPtrDs :: Q [Dec]
      fromPtrDs =
          [d|
          instance FromPtr $(rTypeQ) where
            fromPtr = objFromPtr Rect $(varE finalizerName)
          |]
  
      isRectOpenCVInstanceDs :: Q [Dec]
      isRectOpenCVInstanceDs =
          [d|
          instance IsRect Rect $(depthTypeQ) where
            toRect   = id
            fromRect = id
  
            rectTopLeft     rect = unsafePerformIO $ fromPtr $ withPtr rect $ $(rectTopLeftExpQ)
            rectBottomRight rect = unsafePerformIO $ fromPtr $ withPtr rect $ $(rectBottomRightExpQ)
            rectSize        rect = unsafePerformIO $ fromPtr $ withPtr rect $ $(rectSizeExpQ)
            rectArea        rect = unsafePerformIO $ withPtr rect $ $(rectAreaExpQ)
            rectContains         = $(rectContainsExpQ)
          |]
        where
          rectTopLeftExpQ :: Q Exp
          rectTopLeftExpQ = do
            rectPtr <- newName "rectPtr"
            lamE [varP rectPtr] $ quoteExp CU.exp $
              cPointTypeStr <> " * { new " <> cPointTypeStr <> "($(" <> cRectTypeStr <> " * rectPtr)->tl()) }"
  
          rectBottomRightExpQ :: Q Exp
          rectBottomRightExpQ = do
            rectPtr <- newName "rectPtr"
            lamE [varP rectPtr] $ quoteExp CU.exp $
              cPointTypeStr <> " * { new " <> cPointTypeStr <> "($(" <> cRectTypeStr <> " * rectPtr)->br()) }"
  
          rectSizeExpQ :: Q Exp
          rectSizeExpQ = do
            rectPtr <- newName "rectPtr"
            lamE [varP rectPtr] $ quoteExp CU.exp $
              cSizeTypeStr <> " * { new " <> cSizeTypeStr <> "($(" <> cRectTypeStr <> " * rectPtr)->size()) }"
  
          rectAreaExpQ :: Q Exp
          rectAreaExpQ = do
            rectPtr <- newName "rectPtr"
            lamE [varP rectPtr] $ quoteExp CU.exp $
              cDepthTypeStr <> " { $(" <> cRectTypeStr <> " * rectPtr)->area() }"
  
          rectContainsExpQ :: Q Exp
          rectContainsExpQ = do
            point <- newName "point"
            rect  <- newName "rect"
            pointPtr <- newName "pointPtr"
            rectPtr  <- newName "rectPtr"
  
            lamE [varP point, varP rect]
              $ appE [e|toBool|]
              $ appE [e|unsafePerformIO|]
              $ appE ([e|withPtr|] `appE` ([e|toPoint|] `appE` varE point))
              $ lamE [varP pointPtr]
              $ appE ([e|withPtr|] `appE` (varE rect))
              $ lamE [varP rectPtr]
              $ quoteExp CU.exp
              $ "int { $(" <> cRectTypeStr <> " * rectPtr)->contains(*$(" <> cPointTypeStr <> " * pointPtr)) }"
  
      isRectHaskellInstanceDs :: Q [Dec]
      isRectHaskellInstanceDs =
          [d|
          instance IsRect HRect $(depthTypeQ) where
            toRect hr = unsafePerformIO $ toRectIO hr
            fromRect rect = HRect
                            { hRectTopLeft = fromPoint $ rectTopLeft rect
                            , hRectSize    = fromSize  $ rectSize    rect
                            }
  
            toRectIO = $(toRectIOExpQ)
  
            rectTopLeft     hr = hRectTopLeft hr
            rectBottomRight hr = hRectTopLeft hr ^+^ hRectSize hr
            rectSize        hr = hRectSize hr
  
            rectArea hr = let V2 w h = hRectSize hr
                          in w * h
  
            rectContains (V2 px py) (HRect (V2 rx ry) (V2 rw rh)) =
                   px >= rx && px < rx + rw
                && py >= ry && py < ry + rh
          |]
        where
          toRectIOExpQ :: Q Exp
          toRectIOExpQ = do
            x <- newName "x"
            y <- newName "y"
            w <- newName "w"
            h <- newName "h"
            lamE [conP 'HRect [conP 'V2 [varP x, varP y], conP 'V2 [varP w, varP h]]] $
              appE [e|fromPtr|] $
                quoteExp CU.exp $ concat
                  [ cRectTypeStr <> " * { "
                  , "new cv::Rect_<" <> cDepthTypeStr <> ">("
                  , "$(" <> cDepthTypeStr <> " x), "
                  , "$(" <> cDepthTypeStr <> " y), "
                  , "$(" <> cDepthTypeStr <> " w), "
                  , "$(" <> cDepthTypeStr <> " h)"
                  , ")}"
                  ]
  