content: {-# language CPP #-}
  {-# language QuasiQuotes #-}
  {-# language TemplateHaskell #-}
  
  #ifndef ENABLE_INTERNAL_DOCUMENTATION
  {-# OPTIONS_HADDOCK hide #-}
  #endif
  
  module OpenCV.Internal.Core.Types.Vec.TH
    ( mkVecType
    ) where
  
  import "base" Data.List ( intercalate )
  import "base" Data.Monoid ( (<>) )
  import "base" Foreign.Marshal.Alloc ( alloca )
  import "base" Foreign.Storable ( peek )
  import "base" System.IO.Unsafe ( unsafePerformIO )
  import qualified "inline-c" Language.C.Inline.Unsafe as CU
  import "linear" Linear ( V2(..), V3(..), V4(..) )
  import "template-haskell" Language.Haskell.TH
  import "template-haskell" Language.Haskell.TH.Quote ( quoteExp )
  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.Vec
  import "this" OpenCV.Internal
  
  mkVecType
      :: String  -- ^ Vec type name, for both Haskell and C
      -> Integer -- ^ Vec dimension
      -> Name    -- ^ Depth type name in Haskell
      -> Name    -- ^ Vec C proxy type name
      -> String  -- ^ Depth type name in C
      -> Q [Dec]
  mkVecType vTypeNameStr dim depthTypeName cProxyTypeName cDepthTypeStr
      | dim < 2 || dim > 4 = fail $ "mkVecType: Unsupported dimension: " <> show dim
      | otherwise =
        fmap concat . sequence $
          [ pure <$> vecTySynD
          , fromPtrDs
          , isVecOpenCVInstanceDs
          , isVecHaskellInstanceDs
          , mkPlacementNewInstance vTypeName
          , mkFinalizer DeletePtr finalizerNameStr cVecTypeStr cProxyTypeName
          ]
    where
      vTypeName :: Name
      vTypeName = mkName vTypeNameStr
  
      cVecTypeStr :: String
      cVecTypeStr = vTypeNameStr
  
      vTypeQ :: Q Type
      vTypeQ = conT vTypeName
  
      depthTypeQ :: Q Type
      depthTypeQ = conT depthTypeName
  
      dimTypeQ :: Q Type
      dimTypeQ = litT (numTyLit dim)
  
      vecTySynD :: Q Dec
      vecTySynD =
          tySynD vTypeName
                 []
                 ([t|Vec|] `appT` dimTypeQ `appT` depthTypeQ)
  
      finalizerNameStr :: String
      finalizerNameStr = "delete" <> vTypeNameStr
  
      finalizerName :: Name
      finalizerName = mkName finalizerNameStr
  
      fromPtrDs :: Q [Dec]
      fromPtrDs =
          [d|
          instance FromPtr $(vTypeQ) where
            fromPtr = objFromPtr Vec $(varE finalizerName)
          |]
  
      isVecOpenCVInstanceDs :: Q [Dec]
      isVecOpenCVInstanceDs =
          [d|
          instance IsVec (Vec $(dimTypeQ)) $(depthTypeQ) where
            toVec   = id
            toVecIO = pure
            fromVec = id
          |]
  
      isVecHaskellInstanceDs :: Q [Dec]
      isVecHaskellInstanceDs =
          let ix = fromInteger dim - 2
          in withLinear (linearTypeQs   !! ix)
                        (linearConNames !! ix)
        where
          linearTypeQs :: [Q Type]
          linearTypeQs = map conT [''V2, ''V3, ''V4]
  
          linearConNames :: [Name]
          linearConNames = ['V2, 'V3, 'V4]
  
          withLinear :: Q Type -> Name -> Q [Dec]
          withLinear lvTypeQ lvConName =
              [d|
              instance IsVec $(lvTypeQ) $(depthTypeQ) where
                toVec   = unsafePerformIO . toVecIO
                toVecIO = $(toVecIOExpQ)
                fromVec = $(fromVecExpQ)
              |]
            where
              toVecIOExpQ :: Q Exp
              toVecIOExpQ = do
                  ns <- mapM newName elemNames
                  lamE [conP lvConName $ map varP ns]
                   $ appE [e|fromPtr|]
                   $ quoteExp CU.exp
                   $ inlineCStr ns
                where
                  inlineCStr :: [Name] -> String
                  inlineCStr ns = concat
                      [ cVecTypeStr
                      , " * { new cv::Vec<"
                      , cDepthTypeStr
                      , ", "
                      , show dim
                      , ">(" <> intercalate ", " (map elemQuote ns) <> ")"
                      , " }"
                      ]
                    where
                      elemQuote :: Name -> String
                      elemQuote n = "$(" <> cDepthTypeStr <> " " <> nameBase n <> ")"
  
              fromVecExpQ :: Q Exp
              fromVecExpQ = do
                  vec <- newName "vec"
                  vecPtr <- newName "vecPtr"
                  ptrNames <- mapM (newName . (<> "Ptr")) elemNames
                  withPtrNames vec vecPtr ptrNames
                where
                  withPtrNames :: Name -> Name -> [Name] -> Q Exp
                  withPtrNames vec vecPtr ptrNames =
                      lamE [varP vec]
                        $ appE [e|unsafePerformIO|]
                        $ withPtrVarsExpQ ptrNames
                    where
  
                      withPtrVarsExpQ :: [Name] -> Q Exp
                      withPtrVarsExpQ = foldr (\p -> appE [e|alloca|] . lamE [varP p]) withAllocatedVars
  
                      withAllocatedVars :: Q Exp
                      withAllocatedVars =
                          appE ([e|withPtr|] `appE` varE vec)
                            $ lamE [varP vecPtr]
                            $ doE
                              [ noBindS $ quoteExp CU.block inlineCStr
                              , noBindS extractExpQ
                              ]
  
                      inlineCStr :: String
                      inlineCStr = unlines $
                          concat
                            [ "void {"
                            , "const cv::Vec<"
                            , cDepthTypeStr
                            , ", " <> show dim <> "> & p = *$("
                            , cVecTypeStr
                            , " * "
                            , nameBase vecPtr
                            , ");"
                            ]
                          : map ptrLine (zip [0..] ptrNames)
                          <> ["}"]
                        where
                          ptrLine :: (Int, Name) -> String
                          ptrLine (ix, ptrName) =
                              "*$(" <> cDepthTypeStr <> " * " <> nameBase ptrName <> ") = p[" <> show ix <> "];"
  
                      -- Applies the constructor to the values that are
                      -- read from the pointers.
                      extractExpQ :: Q Exp
                      extractExpQ = foldl (\acc peekExp -> [e|(<*>)|] `appE` acc `appE` peekExp)
                                          ([e|pure|] `appE` conE lvConName)
                                          peekExpQs
                        where
                          peekExpQs :: [Q Exp]
                          peekExpQs = map (\p -> [e|peek|] `appE` varE p) ptrNames
  
              elemNames :: [String]
              elemNames = take (fromInteger dim)
                               ["x", "y", "z", "w"]
  