content: {-# language CPP #-}
  {-# language QuasiQuotes #-}
  {-# language TemplateHaskell #-}
  
  #ifndef ENABLE_INTERNAL_DOCUMENTATION
  {-# OPTIONS_HADDOCK hide #-}
  #endif
  
  module OpenCV.Internal.Core.Types.Matx.TH
    ( mkMatxType
    ) where
  
  import "base" Data.List ( intercalate )
  import "base" Data.Monoid ( (<>) )
  import qualified "inline-c" Language.C.Inline.Unsafe as CU
  import "template-haskell" Language.Haskell.TH
  import "template-haskell" Language.Haskell.TH.Quote ( quoteExp )
  import "this" OpenCV.Internal
  import "this" OpenCV.Internal.Core.Types.Matx
  import "this" OpenCV.Internal.C.FinalizerTH
  import "this" OpenCV.Internal.C.PlacementNew.TH ( mkPlacementNewInstance )
  import "this" OpenCV.Internal.C.Types
  
  mkMatxType
      :: String  -- ^ Matx type name, for both Haskell and C
      -> Integer -- ^ Row dimension
      -> Integer -- ^ Column dimension
      -> Name    -- ^ Depth type name in Haskell
      -> Name    -- ^ Matx C proxy type name
      -> String  -- ^ Depth type name in C
      -> Q [Dec]
  mkMatxType mTypeNameStr dimR dimC depthTypeName cProxyTypeName cDepthTypeStr
      | dimR < 1 || dimR > 6 || dimC < 1 || dimC > 6 =
          fail $ "mkMatxType: Unsupported dimension: " <> show dimR <> "x" <> show dimC
      | otherwise =
        fmap concat . sequence $
          [ (:[]) <$> matxTySynD
          , fromPtrDs
          , isMatxOpenCVInstanceDs
            -- The largest Matx constructor in C++ takes 16 arguments.
            -- TODO (RvD): for larger number of arguments we can use the
            -- constructor that initializes from a plain array.
          , if dimR * dimC <= 16
            then newMatxDs
            else pure []
          , mkPlacementNewInstance mTypeName
          , mkFinalizer DeletePtr finalizerNameStr cMatxTypeStr cProxyTypeName
          ]
    where
      mTypeName :: Name
      mTypeName = mkName mTypeNameStr
  
      cMatxTypeStr :: String
      cMatxTypeStr = mTypeNameStr
  
      mTypeQ :: Q Type
      mTypeQ = conT mTypeName
  
      depthTypeQ :: Q Type
      depthTypeQ = conT depthTypeName
  
      dimRTypeQ, dimCTypeQ :: Q Type
      dimRTypeQ = litT (numTyLit dimR)
      dimCTypeQ = litT (numTyLit dimC)
  
      matxTySynD :: Q Dec
      matxTySynD =
          tySynD mTypeName
                 []
                 ([t|Matx|] `appT` dimRTypeQ `appT` dimCTypeQ `appT` depthTypeQ)
  
      finalizerNameStr :: String
      finalizerNameStr = "delete" <> mTypeNameStr
  
      finalizerName :: Name
      finalizerName = mkName finalizerNameStr
  
      fromPtrDs :: Q [Dec]
      fromPtrDs =
          [d|
          instance FromPtr $(mTypeQ) where
            fromPtr = objFromPtr Matx $(varE finalizerName)
          |]
  
      isMatxOpenCVInstanceDs :: Q [Dec]
      isMatxOpenCVInstanceDs =
          [d|
          instance IsMatx (Matx $(dimRTypeQ) $(dimCTypeQ)) $(depthTypeQ) where
            toMatx   = id
            toMatxIO = pure
            fromMatx = id
          |]
  
      newMatxDs :: Q [Dec]
      newMatxDs = sequence
          [ sigD funName funTypeQ
          , withVarNames =<< mapM newName fieldNames
          ]
        where
          -- example: Float -> Float -> Float -> Float -> IO Matx22f
          funTypeQ :: Q Type
          funTypeQ = foldr (\_fieldName acc -> arrowT `appT` depthTypeQ `appT` acc)
                           ([t|IO|] `appT` mTypeQ)
                           fieldNames
  
          funName :: Name
          funName = mkName $ "new" <> mTypeNameStr
  
          fieldNames :: [String]
          fieldNames = [fieldName r c | r <- [1..dimR], c <- [1..dimC]]
            where
              fieldName :: Integer -> Integer -> String
              fieldName r c = "f" <> show r <> show c
  
          withVarNames :: [Name] -> Q Dec
          withVarNames varNames = funD funName [funClause]
            where
              funClause :: Q Clause
              funClause = clause (map varP varNames) funBody []
  
              funBody :: Q Body
              funBody = normalB $ appE [e|fromPtr|] $ quoteExp CU.exp $ concat
                          [ cMatxTypeStr
                          , " * { new cv::Matx<"
                          , cDepthTypeStr
                          , ", "
                          , show dimR
                          , ", "
                          , show dimC
                          , ">"
                          , "("
                          , intercalate ", " (map fieldQuote varNames)
                          , ")"
                          , "}"
                          ]
  
              fieldQuote :: Name -> String
              fieldQuote n = "$(" <> cDepthTypeStr <> " " <> nameBase n <> ")"
  