diff --git a/opencv-extra/Setup.hs b/opencv-extra/Setup.hs index e2416fc..96c2fff 100644 --- a/opencv-extra/Setup.hs +++ b/opencv-extra/Setup.hs @@ -1,8 +1,160 @@ -import Distribution.Simple ( defaultMainArgs ) +import Distribution.Simple ( defaultMainWithHooksArgs, simpleUserHooks ) import System.Environment ( getArgs ) + +-- Source copied from: https://hackage.haskell.org/package/cabal-pkg-config-version-hook-0.1.0.1/docs/src/Distribution.PkgConfigVersionHook.html#addHook +-- TODO: Import this via `setup-depends` instead once it's on Stackage. + +import Control.Lens ((%~), (^.)) +import Control.Monad (when) +import qualified Data.Char as C +import Data.Foldable (toList) +import Data.Function ((&)) +import qualified Data.List as L +import Distribution.Simple (UserHooks (confHook)) +import Distribution.Simple.Setup (ConfigFlags, configConfigurationsFlags) +import Distribution.Types.BuildInfo.Lens (ccOptions, cppOptions, cxxOptions) +import Distribution.Types.Flag (flagName, mkFlagAssignment, mkFlagName, unFlagName) +import Distribution.Types.GenericPackageDescription.Lens + ( GenericPackageDescription, + condBenchmarks, + condExecutables, + condForeignLibs, + condLibrary, + condSubLibraries, + condTestSuites, + genPackageFlags, + ) +import System.IO (hPutStrLn, stderr) +import System.Process (readProcess) +import qualified Text.ParserCombinators.ReadP as P +import Prelude hiding (log) + +-- | Hook into Cabal to provide pkg-config metadata. Can be applied multiple +-- times to support multiple packages. +addHook :: Settings -> UserHooks -> UserHooks +addHook settings hooks = hooks {confHook = composeConfHook settings (confHook hooks)} + +-- | How the metadata for a pkg-config package should be made available to the +-- cabal file. +data Settings = Settings + { -- | Name of the package; used for querying pkg-config. + pkgConfigName :: String, + -- | Name to use in the Haskell CPP and C/C++ preprocessor macros. + -- + -- For example, `pkgConfigName = "FOO"` will set the macros + -- + -- * @FOO_MAJOR@ + -- + -- * @FOO_MINOR@ + -- + -- * @FOO_PATCH@ + -- + -- * @FOO_IS_AT_LEAST(major, minor, patch)@ + macroName :: String, + -- | Name to use when setting flag values in the cabal file. + -- + -- Flags named with this prefix, followed by a dash, followed by a major version number, an underscore and a minor version number will be set when the detected package is at least that version. + flagPrefixName :: String + } + +-- | Derive a default 'Settings' value from just a pkg-config package name. +mkSettings :: String -> Settings +mkSettings name = + Settings + { pkgConfigName = name, + macroName = map (\c -> case c of '-' -> '_'; x -> x) name, + flagPrefixName = name + } + +-- | Extend the value of 'confHook'. It's what powers 'addHook'. +composeConfHook :: + Settings -> + ((GenericPackageDescription, a) -> ConfigFlags -> IO b) -> + (GenericPackageDescription, a) -> + Distribution.Simple.Setup.ConfigFlags -> + IO b +composeConfHook settings origHook = \(genericPackageDescription, hookedBuildInfo) confFlags -> do + (actualMajor, actualMinor, actualPatch) <- getPkgConfigPackageVersion (pkgConfigName settings) + + let defines = + [ "-D" <> macroName settings <> "_MAJOR=" <> show actualMajor, + "-D" <> macroName settings <> "_MINOR=" <> show actualMinor, + "-D" <> macroName settings <> "_PATCH=" <> show actualPatch, + "-D" <> macroName settings <> "_IS_AT_LEAST(a,b,c)=(" <> show actualMajor <> ">a||(" <> show actualMajor <> "==a&&(" <> show actualMinor <> ">b||(" <> show actualMinor <> "==b&&" <> show actualPatch <> ">=c))))" + ] + extraFlags = + [ (mkFlagName (flagPrefixName settings ++ "-" ++ show major ++ "_" ++ show minor), (actualMajor, actualMinor) >= (major, minor)) + | declaredFlag <- genericPackageDescription ^. genPackageFlags, + let rawName = unFlagName $ flagName declaredFlag, + rawVersion <- L.stripPrefix (flagPrefixName settings ++ "-") rawName & toList, + [major, minor] <- unambiguously parseFlagVersion rawVersion & toList + ] + setDefines comp x = + x + & comp . cppOptions %~ (<> defines) + & comp . ccOptions %~ (<> defines) + & comp . cxxOptions %~ (<> defines) + genericPackageDescription' = + genericPackageDescription + & setDefines (condLibrary . traverse . traverse) + & setDefines (condSubLibraries . traverse . traverse . traverse) + & setDefines (condForeignLibs . traverse . traverse . traverse) + & setDefines (condExecutables . traverse . traverse . traverse) + & setDefines (condTestSuites . traverse . traverse . traverse) + & setDefines (condBenchmarks . traverse . traverse . traverse) + + configConfigurationsFlags' = configConfigurationsFlags confFlags `mappend` mkFlagAssignment extraFlags + confFlags' = + confFlags + { configConfigurationsFlags = configConfigurationsFlags' + } + origHook (genericPackageDescription', hookedBuildInfo) confFlags' + +parseVersion :: P.ReadP [Int] +parseVersion = do + map read <$> do + P.many1 (P.satisfy C.isDigit) `P.sepBy` P.char '.' + +parseFlagVersion :: P.ReadP [Int] +parseFlagVersion = + map read <$> do + P.many1 (P.satisfy C.isDigit) `P.sepBy` P.char '_' + +unambiguously :: P.ReadP a -> String -> Maybe a +unambiguously p s = + case filter (\(_a, x) -> x == "") $ P.readP_to_S p s of + [(v, _)] -> Just v + _ -> Nothing + +getPkgConfigPackageVersion :: String -> IO (Int, Int, Int) +getPkgConfigPackageVersion pkgName = do + s <- readProcess "pkg-config" ["--modversion", pkgName] "" + case L.sortOn (\(_, remainder) -> length remainder) $ P.readP_to_S parseVersion s of + [] -> error ("Could not parse version " ++ show s ++ " returned by pkg-config for package " ++ pkgName) + (v, r) : _ -> do + when (L.dropWhile C.isSpace r /= "") $ do + log ("ignoring trailing text " ++ show r ++ " in version " ++ show s ++ " of pkg-config package " ++ pkgName) + let v' = v ++ L.repeat 0 + pure (v' L.!! 0, v' L.!! 1, v' L.!! 2) + +-- Should probably use a Cabal function? +log :: String -> IO () +log = hPutStrLn stderr + +-- End of source copied from: https://hackage.haskell.org/package/cabal-pkg-config-version-hook + +hooks = + simpleUserHooks & + addHook + (mkSettings "opencv4") + { macroName = "SETUP_HS_OPENCV4_VERSION", + flagPrefixName = "setup-hs-opencv4-version" + } + + main = do args <- getArgs let args' | "configure" `elem` args = args ++ ["--with-gcc","c++"] | otherwise = args - defaultMainArgs args' + defaultMainWithHooksArgs hooks args' diff --git a/opencv-extra/opencv-extra.cabal b/opencv-extra/opencv-extra.cabal index 13203bf..185f903 100644 --- a/opencv-extra/opencv-extra.cabal +++ b/opencv-extra/opencv-extra.cabal @@ -49,7 +49,11 @@ flag internal-documentation manual: True custom-setup - setup-depends: base, Cabal >= 1.23 + setup-depends: + base, + Cabal >= 1.23, + lens, + process library hs-source-dirs: src diff --git a/opencv-extra/src/OpenCV/Extra/ArUco.hsc b/opencv-extra/src/OpenCV/Extra/ArUco.hsc index 381dbfb..21d1c50 100644 --- a/opencv-extra/src/OpenCV/Extra/ArUco.hsc +++ b/opencv-extra/src/OpenCV/Extra/ArUco.hsc @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds, QuasiQuotes, RecordWildCards, TemplateHaskell #-} +{-# LANGUAGE CPP #-} module OpenCV.Extra.ArUco ( -- * ArUco markers @@ -68,6 +69,11 @@ C.include "opencv2/core.hpp" C.include "iostream" C.include "aruco.hpp" +-- Note [opencv-4.7-aruco-api-change]: +-- OpenCV broke its Aruco API between 4.6 and 4.7. +-- We currently support both versions using CPP `#if`s because +-- both older and newer versions are still popuplar. + C.using "namespace cv" C.using "namespace cv::aruco" C.using "namespace std" @@ -455,18 +461,42 @@ createCharucoBoard squaresX squaresY squareLength markerLength dictionary = unsafePerformIO $ withPtr dictionary $ \c'dictionary -> fromPtr $ +-- See note [opencv-4.7-aruco-api-change]. +-- +-- OpenCV < 4.7 uses `CharucoBoard::create()`, newer versions +-- use the `CharucoBoard()` constructor. +-- +-- Unfortunately `inline-c` does not support C++ `#if`s, otherwise +-- this could be done a bit simpler via e.g. +-- #if (CV_VERSION_MAJOR <= 4 && CV_VERSION_MINOR < 7) +-- instead of the logic that generates the below macro from +-- our `Setup.hs` hook. +#if SETUP_HS_OPENCV4_VERSION_IS_AT_LEAST(4,7,0) [C.block| Ptr_CharucoBoard * { return - new Ptr - ( CharucoBoard::create - ( $(int c'squaresX) - , $(int c'squaresY) - , $(double c'squareLength) - , $(double c'markerLength) - , *$(Ptr_Dictionary * c'dictionary) - ) - ); + new Ptr( + new CharucoBoard + ( Size( $(int c'squaresX) , $(int c'squaresY) ) + , $(float c'squareLength) + , $(float c'markerLength) + , **$(Ptr_Dictionary * c'dictionary) + ) + ); + }|] +#else + [C.block| Ptr_CharucoBoard * { + return + new Ptr( + CharucoBoard::create + ( $(int c'squaresX) + , $(int c'squaresY) + , $(float c'squareLength) + , $(float c'markerLength) + , *$(Ptr_Dictionary * c'dictionary) + ) + ); }|] +#endif where c'squaresX = fromIntegral squaresX c'squaresY = fromIntegral squaresY @@ -539,9 +569,20 @@ getPredefinedDictionary :: PredefinedDictionaryName -> Dictionary getPredefinedDictionary name = unsafePerformIO $ fromPtr $ +-- See note [opencv-4.7-aruco-api-change]. +-- +-- In OpenCV < 4.7, `getPredefinedDictionary()` returns a `Ptr`, +-- in newer versions it returns a `Dictionary`. +#if SETUP_HS_OPENCV4_VERSION_IS_AT_LEAST(4,7,0) + [C.block| Ptr_Dictionary * { + const Dictionary dict = getPredefinedDictionary($(int32_t c'name)); + return new Ptr(makePtr(dict)); + }|] +#else [C.block| Ptr_Dictionary * { return new Ptr(getPredefinedDictionary($(int32_t c'name))); }|] +#endif where c'name :: Int32 c'name = marshalPredefinedDictionaryName name @@ -578,11 +619,23 @@ drawCharucoBoard charucoBoard width height = unsafePerformIO $ do dst <- newEmptyMat withPtr charucoBoard $ \c'board -> withPtr dst $ \dstPtr -> +-- See note [opencv-4.7-aruco-api-change]. +-- +-- In OpenCV < 4.7, `draw()` draws the board, +-- in newer versions it's `generateImage()`. +#if SETUP_HS_OPENCV4_VERSION_IS_AT_LEAST(4,7,0) + [C.block| void { + Mat & board = * $(Mat * dstPtr); + Ptr & charucoBoard = *$(Ptr_CharucoBoard * c'board); + charucoBoard->generateImage(cv::Size($(int32_t w), $(int32_t h)), board); + }|] +#else [C.block| void { Mat & board = * $(Mat * dstPtr); Ptr & charucoBoard = *$(Ptr_CharucoBoard * c'board); charucoBoard->draw(cv::Size($(int32_t w), $(int32_t h)), board); }|] +#endif pure (unsafeCoerceMat dst) where w = toInt32 width