packages feed

opencv-extra (empty) → 0.0.0.0

raw patch · 131 files changed

+4114/−0 lines, 131 filesdep +Globdep +JuicyPixelsdep +basebuild-type:Customsetup-changedbinary-added

Dependencies added: Glob, JuicyPixels, base, bindings-DSL, bytestring, containers, data-default, directory, haskell-src-exts, inline-c, inline-c-cpp, linear, opencv, opencv-extra, primitive, template-haskell, text, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,32 @@+Copyright 2015–2017 Lumi Guide Fietsdetectie B.V.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The name Lumi Guide Fietsdetectie B.V. and the names of+      contributors may NOT be used to endorse or promote products+      derived from this software without specific prior written+      permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,8 @@+import Distribution.Simple ( defaultMainArgs )+import System.Environment ( getArgs )++main = do+    args <- getArgs+    let args' | "configure" `elem` args = args ++ ["--with-gcc","g++", "--with-ld","g++"]+              | otherwise               = args+    defaultMainArgs args'
+ doc/ExampleExtractor.hs view
@@ -0,0 +1,350 @@+{-# language QuasiQuotes #-}+{-# language TemplateHaskell #-}++module ExampleExtractor+  ( Animation++  , renderImage+  , renderAnimation++  , extractExampleImages+  ) where++import "base" Control.Arrow ( (***), (&&&) )+import "base" Control.Monad+import "base" Data.Bifunctor+import "base" Data.Either+import "base" Data.Maybe+import "base" Data.Monoid+import "base" Data.Word+import qualified "containers" Data.Map.Strict as M+import "directory" System.Directory ( canonicalizePath )+import qualified "haskell-src-exts" Language.Haskell.Exts.Extension as Hse+import qualified "haskell-src-exts" Language.Haskell.Exts.Parser as Hse+import qualified "haskell-src-exts" Language.Haskell.Exts.Syntax as Hse+import qualified "haskell-src-exts" Language.Haskell.Exts.SrcLoc as Hse+import qualified "Glob" System.FilePath.Glob as G+import "JuicyPixels" Codec.Picture.ColorQuant as JP+import "JuicyPixels" Codec.Picture.Gif        as JP+import "JuicyPixels" Codec.Picture.Types      as JP+import qualified "opencv" OpenCV as CV+import qualified "opencv" OpenCV.Juicy as CVJ+import qualified "text" Data.Text as T+import qualified "text" Data.Text.IO as T+import qualified "bytestring" Data.ByteString as B+import qualified "bytestring" Data.ByteString.Lazy as BL+import "template-haskell" Language.Haskell.TH+import "template-haskell" Language.Haskell.TH.Syntax+import "this" Language.Haskell.Meta.Syntax.Translate ( toDecs )++--------------------------------------------------------------------------------++-- An animation is a list of images. Each image has a duration+-- specified in hundreths of a second.+type Animation shape channels depth = [(Int, CV.Mat shape channels depth)]++--------------------------------------------------------------------------------++renderImage+    :: FilePath+    -> CV.Mat ('CV.S [height, width]) channels depth+    -> IO ()+renderImage fp img = do+    let bs = CV.exceptError $ CV.imencode (CV.OutputPng CV.defaultPngParams) img+    putStr $ "Writing image " <> dest <> " ..."+    B.writeFile dest bs+    putStrLn " OK"+  where+    dest = mkDestPath fp++renderAnimation+    :: FilePath+    -> Animation ('CV.S [height, width]) ('CV.S 3) ('CV.S Word8)+    -> IO ()+renderAnimation fp imgs = do+    putStr $ "Writing animation " <> dest <> " ..."+    case gif of+      Left errMsg -> putStrLn $ " " <> errMsg+      Right bs -> BL.writeFile dest bs+    putStrLn " OK"+  where+    gif :: Either String BL.ByteString+    gif = JP.encodeGifImages JP.LoopingForever palImgs++    palImgs :: [(JP.Palette, JP.GifDelay, JP.Image JP.Pixel8)]+    palImgs =+        map (\(delay, img) ->+              let (img8, pal) = JP.palettize JP.defaultPaletteOptions img+              in (pal, delay, img8)+            )+            jpImgs++    jpImgs :: [(JP.GifDelay, JP.Image JP.PixelRGB8)]+    jpImgs = map (second CVJ.toImage) imgs++    dest = mkDestPath fp++mkDestPath :: FilePath -> FilePath+mkDestPath fp = "doc/generated/" <> fp++--------------------------------------------------------------------------------++data SrcLoc+   = SrcLoc+     { locFile :: !FilePath+     , locLine :: !Int+     }++-- | Haskell source code containing 0, 1 or more examples.+data ExampleSrc+   = ExampleSrc+     { exsLoc :: !SrcLoc+     , exsSrc :: !T.Text+     }++data ParsedExampleSrc+   = ParsedExampleSrc+     { pexsLoc   :: !SrcLoc+     , pexsDecls :: ![Dec]+     }++-- | A single line of Haskell source code.+data SrcLine+   = SrcLine+     { srcLoc  :: !SrcLoc+     , srcLine :: !T.Text+     }++data SymbolType+   = SymImage+   | SymImageAction+     deriving (Show, Eq)++data ExampleProps+   = ExampleProps+     { exPropIO        :: !Bool+     , exPropAnimation :: !Bool+     } deriving Show++data RenderTarget+   = RenderTarget+     { rtDestination :: !FilePath+       -- ^ Relative path where the symbol must be rendered as an image file.+     , rtSymbolName :: !Name+       -- ^ Name of a top level symbol (function or CAF) that is either an image+       -- or an IO action that yields an image.+     , rtSymbolProps :: !ExampleProps+     } deriving Show++--------------------------------------------------------------------------------++extractExampleImages :: FilePath -> Q [Dec]+extractExampleImages srcDir = do+    haskellPaths <- runIO $ findHaskellPaths srcDir+    mapM_ (addDependentFile <=< runIO . canonicalizePath) haskellPaths++    ((exampleSrcs, renderTargets) :: ([ExampleSrc], [RenderTarget])) <- runIO $ do+      xs <- mapM findExamples haskellPaths+      pure $ (concat *** concat) $ unzip xs++    let parseErrors       :: [String]+        parsedExampleSrcs :: [ParsedExampleSrc]+        (parseErrors, parsedExampleSrcs) = partitionEithers $ map parseExampleSrc exampleSrcs++        examplesTH :: [Dec]+        examplesTH = concatMap (\pexs -> parsedExampleLinePragma pexs : pexsDecls pexs)+                               parsedExampleSrcs++        exampleTypes :: M.Map Name Type+        exampleTypes = M.fromList $ mapMaybe asSigD examplesTH++        renderTargets' :: [RenderTarget]+        renderTargets' =+            mapMaybe+              (\rt -> do+                 exampleType <- M.lookup (rtSymbolName rt) exampleTypes+                 pure rt {rtSymbolProps = classifyExample exampleType}+              )+              renderTargets++    unless (null parseErrors) $+      error $ show parseErrors++    mdecs <- mkRenderExampleImages renderTargets'+    pure $ examplesTH <> mdecs++parsedExampleLinePragma :: ParsedExampleSrc -> Dec+parsedExampleLinePragma pexs =+    PragmaD $ LineP (locLine loc) (locFile loc)+  where+    loc = pexsLoc pexs++parseExampleSrc :: ExampleSrc -> Either String ParsedExampleSrc+parseExampleSrc exs =+    case parseDecsHse (locFile $ exsLoc exs) $ T.unpack $ haddockToHaskell $ exsSrc exs of+      Left errMsg -> Left $ (locFile $ exsLoc exs) <> ": " <> errMsg+      Right decls -> Right+                     ParsedExampleSrc+                     { pexsLoc   = exsLoc exs+                     , pexsDecls = toDecs decls+                     }+++asSigD :: Dec -> Maybe (Name, Type)+asSigD (SigD n t) = Just (n, t)+asSigD _ = Nothing++-- Really hacky way of determining the properties of an example based+-- on its type.+classifyExample :: Type -> ExampleProps+classifyExample (ForallT _ _ t) = classifyExample t+classifyExample (AppT (ConT n) t2) | nameBase n == nameBase ''IO = checkIOAnimation t2+classifyExample (AppT t1 _)     = classifyExample t1+classifyExample (VarT _)        = ExampleProps False False+classifyExample (ConT n) | nameBase n == nameBase ''Animation = ExampleProps False True+classifyExample (PromotedT _)   = ExampleProps False False+classifyExample _               = ExampleProps False False++checkIOAnimation :: Type -> ExampleProps+checkIOAnimation (ForallT _ _ t) = checkIOAnimation t+checkIOAnimation (AppT t1 _)     = checkIOAnimation t1+checkIOAnimation (VarT _)        = ExampleProps True False+checkIOAnimation (ConT n) | nameBase n == nameBase ''Animation = ExampleProps True True+checkIOAnimation (PromotedT _)   = ExampleProps True False+checkIOAnimation _               = ExampleProps True False++parseDecsHse :: String -> String -> Either String [Hse.Decl Hse.SrcSpanInfo]+parseDecsHse fileName str =+    case Hse.parseModuleWithMode (parseMode fileName) str of+      Hse.ParseFailed _srcLoc err -> Left err+      Hse.ParseOk (Hse.Module _ _ _ _  decls) -> Right decls+      Hse.ParseOk _ -> Left "Invalid module"++parseMode :: String -> Hse.ParseMode+parseMode fileName =+    Hse.ParseMode+    { Hse.parseFilename         = fileName+    , Hse.baseLanguage          = Hse.Haskell2010+    , Hse.extensions            = map Hse.EnableExtension exts+    , Hse.ignoreLanguagePragmas = False+    , Hse.ignoreLinePragmas     = False+    , Hse.fixities              = Nothing+    , Hse.ignoreFunctionArity   = False+    }+  where+    exts :: [Hse.KnownExtension]+    exts =+      [ Hse.BangPatterns+      , Hse.DataKinds+      , Hse.FlexibleContexts+      , Hse.LambdaCase+      , Hse.OverloadedStrings+      , Hse.PackageImports+      , Hse.PolyKinds+      , Hse.ScopedTypeVariables+      , Hse.TupleSections+      , Hse.TypeFamilies+      , Hse.TypeOperators+      , Hse.PostfixOperators+      , Hse.QuasiQuotes+      , Hse.UnicodeSyntax+      , Hse.MagicHash+      , Hse.PatternSignatures+      , Hse.MultiParamTypeClasses+      , Hse.RankNTypes+      ]++-- | Generate code for every render target+--+-- Executing the generated code will actually render the target.+mkRenderExampleImages :: [RenderTarget] -> Q [Dec]+mkRenderExampleImages renderTargets = [d|+    renderExampleImages :: IO ()+    renderExampleImages = $(pure doRender)+    |]+  where+    doRender :: Exp+    doRender =+        DoE $ do+          rt <- renderTargets+          let sym = VarE $ rtSymbolName rt+              fp  = LitE $ StringL $ "examples/" <> rtDestination rt+              props = rtSymbolProps rt+              render | exPropAnimation props = 'renderAnimation+                     | otherwise             = 'renderImage+          pure $ NoBindS $+            if exPropIO props+            then VarE '(>>=) `AppE` sym `AppE` (VarE render `AppE` fp)+            else VarE render `AppE` fp `AppE` sym++findHaskellPaths :: FilePath -> IO [FilePath]+findHaskellPaths srcDir = do+  (paths, _) <- G.globDir [G.compile "**/*.hs", G.compile "**/*.hsc"] srcDir+  pure $ concat paths++haddockToHaskell :: T.Text -> T.Text+haddockToHaskell =+    T.replace "\\\\" "\\"+  . T.replace "\\`" "`"+  . T.replace "\\<" "<"+  . T.replace "\\/" "/"++findExamples :: FilePath -> IO ([ExampleSrc], [RenderTarget])+findExamples fp = ((parseExamples &&& parseGeneratedImages) . textToSource fp) <$> T.readFile fp++textToSource :: FilePath -> T.Text -> [SrcLine]+textToSource fp txt = zipWith lineToSource [1..] (T.lines txt)+  where+    lineToSource :: Int -> T.Text -> SrcLine+    lineToSource n line =+        SrcLine+        { srcLoc  = SrcLoc {locFile = fp, locLine = n}+        , srcLine = line+        }++parseExamples :: [SrcLine] -> [ExampleSrc]+parseExamples = findStart+  where+    findStart :: [SrcLine] -> [ExampleSrc]+    findStart      []  = []+    findStart   (_:[]) = []+    findStart (_:_:[]) = []+    findStart (a:b:c:ls)+              | srcLine a == "Example:"+              , srcLine b == ""+              , srcLine c == "@"+                     = findEnd [] ls+    findStart (_:ls) = findStart ls++    findEnd :: [SrcLine] -> [SrcLine] -> [ExampleSrc]+    findEnd _acc [] = []+    findEnd acc (l:ls)+        | srcLine l == "@" =+            case reverse acc of+              []    -> findStart ls+              revAcc@(firstLine:_) ->+                  let exs = ExampleSrc+                            { exsLoc = srcLoc firstLine+                            , exsSrc = T.unlines (map srcLine revAcc)+                            }+                  in exs : findStart ls+        | otherwise = findEnd (l:acc) ls++parseGeneratedImages :: [SrcLine] -> [RenderTarget]+parseGeneratedImages = concatMap $ parseLine . srcLine+  where+    parseLine :: T.Text -> [RenderTarget]+    parseLine line = maybeToList $ do+      let fromPrefix = snd $ T.breakOn prefix line+      rest <- T.stripPrefix prefix fromPrefix+      case take 2 $ T.words rest of+        [fp, funcName] ->+            pure RenderTarget+                 { rtDestination = T.unpack $ fp+                 , rtSymbolName = mkName $ T.unpack $ fromMaybe funcName (T.stripSuffix ">>" funcName)+                   -- Later on we will determine the actual properties.+                 , rtSymbolProps = ExampleProps False False+                 }+        _ -> Nothing++    prefix = "<<doc/generated/examples/"
+ doc/Language/Haskell/Meta/Syntax/Translate.hs view
@@ -0,0 +1,761 @@+{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}++{- |+  Module      :  Language.Haskell.Meta.Syntax.Translate+  Copyright   :  (c) Matt Morrow 2008+  License     :  BSD3+  Maintainer  :  Matt Morrow <mjm2002@gmail.com>+  Stability   :  experimental+  Portability :  portable (template-haskell)+-}++module Language.Haskell.Meta.Syntax.Translate (+    module Language.Haskell.Meta.Syntax.Translate+) where++import Data.Char (ord, isUpper)+import Data.Typeable+import Data.List (foldl', nub, (\\))+import Language.Haskell.TH.Syntax+import qualified Language.Haskell.Exts.SrcLoc as Hs+#if MIN_VERSION_haskell_src_exts(1,18,0)+import qualified Language.Haskell.Exts.Syntax as Hs+#else+import qualified Language.Haskell.Exts.Annotated.Syntax as Hs+#endif++-----------------------------------------------------------------------------+++class ToName a where toName :: a -> Name+class ToNames a where toNames :: a -> [Name]+class ToLit  a where toLit  :: a -> Lit+class ToType a where toType :: a -> Type+class ToPat  a where toPat  :: a -> Pat+class ToExp  a where toExp  :: a -> Exp+class ToDecs a where toDecs :: a -> [Dec]+class ToDec  a where toDec  :: a -> Dec+class ToStmt a where toStmt :: a -> Stmt+class ToLoc  a where toLoc  :: a -> Loc+class ToCxt  a where toCxt  :: a -> Cxt+class ToPred a where toPred :: a -> Pred+class ToTyVars a where toTyVars :: a -> [TyVarBndr]+#if MIN_VERSION_haskell_src_exts(1,18,0)+class ToMaybeKind a where toMaybeKind :: a -> Maybe Kind+#if MIN_VERSION_template_haskell(2,11,0)+class ToInjectivityAnn a where toInjectivityAnn :: a -> InjectivityAnn+#endif+#endif++-- for error messages+moduleName = "Language.Haskell.Meta.Syntax.Translate"++-- When to use each of these isn't always clear: prefer 'todo' if unsure.+noTH :: (Functor f, Show (f ())) => String -> f e -> a+noTH fun thing = error . concat $ [moduleName, ".", fun,+  ": template-haskell has no representation for: ", show (fmap (const ()) thing)]++noTHyet :: (Functor f, Show (f ())) => String -> String -> f e -> a+noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun,+  ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")",+  " has no representation for: ", show (fmap (const ()) thing)]++todo :: (Functor f, Show (f ())) => String -> f e -> a+todo fun thing = error . concat $ [moduleName, ".", fun,+  ": not implemented: ", show (fmap (const ()) thing)]++nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a+nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun,+  ": nonsensical: ", inparticular, ": ", show (fmap (const ()) thing)]++-----------------------------------------------------------------------------+++instance ToExp Lit where+  toExp = LitE+instance (ToExp a) => ToExp [a] where+  toExp = ListE . fmap toExp+instance (ToExp a, ToExp b) => ToExp (a,b) where+  toExp (a,b) = TupE [toExp a, toExp b]+instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where+  toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]+instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where+  toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]+++instance ToPat Lit where+  toPat = LitP+instance (ToPat a) => ToPat [a] where+  toPat = ListP . fmap toPat+instance (ToPat a, ToPat b) => ToPat (a,b) where+  toPat (a,b) = TupP [toPat a, toPat b]+instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where+  toPat (a,b,c) = TupP [toPat a, toPat b, toPat c]+instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where+  toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d]+++instance ToLit Char where+  toLit = CharL+instance ToLit String where+  toLit = StringL+instance ToLit Integer where+  toLit = IntegerL+instance ToLit Int where+  toLit = IntegerL . toInteger+instance ToLit Float where+  toLit = RationalL . toRational+instance ToLit Double where+  toLit = RationalL . toRational+++-----------------------------------------------------------------------------+++-- * ToName {String,HsName,Module,HsSpecialCon,HsQName}+++instance ToName String where+  toName = mkName++instance ToName (Hs.Name l) where+  toName (Hs.Ident _ s) = toName s+  toName (Hs.Symbol _ s) = toName s++instance ToName (Hs.SpecialCon l) where+  toName (Hs.UnitCon _) = '()+  toName (Hs.ListCon _) = '[]+  toName (Hs.FunCon _)  = ''(->)+  toName (Hs.TupleCon _ _ n)+    | n<2 = '()+    | otherwise =+      let x = maybe [] (++".") (nameModule '(,))+      in mkName . concat $ x : ["(",replicate (n-1) ',',")"]+  toName (Hs.Cons _)    = '(:)+++instance ToName (Hs.QName l) where+--  toName (Hs.Qual (Hs.Module []) n) = toName n+  toName (Hs.Qual _ (Hs.ModuleName _ []) n) = toName n+  toName (Hs.Qual _ (Hs.ModuleName _ m) n) =+    let m' = show . toName $ m+        n' = show . toName $ n+    in toName . concat $ [m',".",n']+  toName (Hs.UnQual _ n) = toName n+  toName (Hs.Special _ s) = toName s+++instance ToName (Hs.Op l) where+  toName (Hs.VarOp _ n) = toName n+  toName (Hs.ConOp _ n) = toName n+++-----------------------------------------------------------------------------++-- * ToLit HsLiteral+++instance ToLit (Hs.Literal l) where+  toLit (Hs.Char _ a _) = CharL a+  toLit (Hs.String _ a _) = StringL a+  toLit (Hs.Int _ a _) = IntegerL a+  toLit (Hs.Frac _ a _) = RationalL a+  toLit l@Hs.PrimChar{} = noTH "toLit" l+  toLit (Hs.PrimString _ a _) = StringPrimL (map toWord8 a)+   where+    toWord8 = fromIntegral . ord+  toLit (Hs.PrimInt _ a _) = IntPrimL a+  toLit (Hs.PrimFloat _ a _) = FloatPrimL a+  toLit (Hs.PrimDouble _ a _) = DoublePrimL a+  toLit (Hs.PrimWord _ a _) = WordPrimL a+++-----------------------------------------------------------------------------++-- * ToPat HsPat+++instance ToPat (Hs.Pat l) where+  toPat (Hs.PVar _ n)+    = VarP (toName n)+  toPat (Hs.PLit _ (Hs.Signless _) l)+    = LitP (toLit l)+  toPat (Hs.PLit _ (Hs.Negative _) l) = LitP $ case toLit l of+    IntegerL z -> IntegerL (negate z)+    RationalL q -> RationalL (negate q)+    IntPrimL z' -> IntPrimL (negate z')+    FloatPrimL r' -> FloatPrimL (negate r')+    DoublePrimL r'' -> DoublePrimL (negate r'')+    _ -> nonsense "toPat" "negating wrong kind of literal" l+  toPat (Hs.PInfixApp _ p n q) = UInfixP (toPat p) (toName n) (toPat q)+  toPat (Hs.PApp _ n ps) = ConP (toName n) (fmap toPat ps)+  toPat (Hs.PTuple _ Hs.Boxed ps) = TupP (fmap toPat ps)+  toPat (Hs.PTuple _ Hs.Unboxed ps) = UnboxedTupP (fmap toPat ps)+  toPat (Hs.PList _ ps) = ListP (fmap toPat ps)+  toPat (Hs.PParen _ p) = ParensP (toPat p)+  toPat (Hs.PRec _ n pfs) = let toFieldPat (Hs.PFieldPat _ n p) = (toName n, toPat p)+                            in RecP (toName n) (fmap toFieldPat pfs)+  toPat (Hs.PAsPat _ n p) = AsP (toName n) (toPat p)+  toPat (Hs.PWildCard _) = WildP+  toPat (Hs.PIrrPat _ p) = TildeP (toPat p)+  toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)+  toPat (Hs.PViewPat _ e p) = ViewP (toExp e) (toPat p)+  -- regular pattern+  toPat p@Hs.PRPat{} = noTH "toPat" p+  -- XML stuff+  toPat p@Hs.PXTag{} = noTH "toPat" p+  toPat p@Hs.PXETag{} = noTH "toPat" p+  toPat p@Hs.PXPcdata{} = noTH "toPat" p+  toPat p@Hs.PXPatTag{} = noTH "toPat" p+  toPat (Hs.PBangPat _ p) = BangP (toPat p)+  toPat p = todo "toPat" p++-----------------------------------------------------------------------------++-- * ToExp HsExp++instance ToExp (Hs.QOp l) where+  toExp (Hs.QVarOp _ n) = VarE (toName n)+  toExp (Hs.QConOp _ n) = ConE (toName n)++toFieldExp :: Hs.FieldUpdate l -> FieldExp+toFieldExp (Hs.FieldUpdate _ n e) = (toName n, toExp e)+++++instance ToExp (Hs.Exp l) where+  toExp (Hs.Var _ n)                 = VarE (toName n)+  toExp e@Hs.IPVar{}               = noTH "toExp" e+  toExp (Hs.Con _ n)                 = ConE (toName n)+  toExp (Hs.Lit _ l)                 = LitE (toLit l)+  toExp (Hs.InfixApp _ e o f)        = UInfixE (toExp e) (toExp o) (toExp f)+  toExp (Hs.App _ e f)               = AppE (toExp e) (toExp f)+  toExp (Hs.NegApp _ e)              = AppE (VarE 'negate) (toExp e)+  toExp (Hs.Lambda _ ps e)         = LamE (fmap toPat ps) (toExp e)+  toExp (Hs.Let _ bs e)              = LetE (toDecs bs) (toExp e)+  toExp (Hs.If _ a b c)              = CondE (toExp a) (toExp b) (toExp c)+  toExp (Hs.MultiIf _ ifs)           = MultiIfE (map toGuard ifs)+  toExp (Hs.Case _ e alts)           = CaseE (toExp e) (map toMatch alts)+  toExp (Hs.Do _ ss)                 = DoE (map toStmt ss)+  toExp e@(Hs.MDo _ _)               = noTH "toExp" e+  toExp (Hs.Tuple _ Hs.Boxed xs)     = TupE (fmap toExp xs)+  toExp (Hs.Tuple _ Hs.Unboxed xs)   = UnboxedTupE (fmap toExp xs)+  toExp e@Hs.TupleSection{}        = noTH "toExp" e+  toExp (Hs.List _ xs)               = ListE (fmap toExp xs)+  toExp (Hs.Paren _ e)               = ParensE (toExp e)+  toExp (Hs.LeftSection _ e o)       = InfixE (Just . toExp $ e) (toExp o) Nothing+  toExp (Hs.RightSection _ o f)      = InfixE Nothing (toExp o) (Just . toExp $ f)+  toExp (Hs.RecConstr _ n xs)        = RecConE (toName n) (fmap toFieldExp xs)+  toExp (Hs.RecUpdate _ e xs)        = RecUpdE (toExp e) (fmap toFieldExp xs)+  toExp (Hs.EnumFrom _ e)            = ArithSeqE $ FromR (toExp e)+  toExp (Hs.EnumFromTo _ e f)        = ArithSeqE $ FromToR (toExp e) (toExp f)+  toExp (Hs.EnumFromThen _ e f)      = ArithSeqE $ FromThenR (toExp e) (toExp f)+  toExp (Hs.EnumFromThenTo _ e f g)  = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)+  toExp (Hs.ListComp _ e ss)         = CompE $ map convert ss ++ [NoBindS (toExp e)]+   where+    convert (Hs.QualStmt _ st) = toStmt st+    convert s = noTH "toExp ListComp" s+  toExp (Hs.ExpTypeSig _ e t)      = SigE (toExp e) (toType t)+  toExp e = todo "toExp" e+++toMatch :: Hs.Alt l -> Match+toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds)++toBody :: Hs.Rhs l -> Body+toBody (Hs.UnGuardedRhs _ e) = NormalB $ toExp e+toBody (Hs.GuardedRhss _ rhss) = GuardedB $ map toGuard rhss++toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e)+  where+    g = case map toStmt stmts of+      [NoBindS x] -> NormalG x+      xs -> PatG xs++instance ToDecs a => ToDecs (Maybe a) where+    toDecs Nothing = []+    toDecs (Just a) = toDecs a++instance ToDecs (Hs.Binds l) where+  toDecs (Hs.BDecls _ ds)   = toDecs ds+  toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a++instance ToDecs (Hs.ClassDecl l) where+  toDecs (Hs.ClsDecl _ d) = toDecs d+  toDecs x = todo "classDecl" x++-----------------------------------------------------------------------------++-- * ToLoc SrcLoc++instance ToLoc Hs.SrcLoc where+  toLoc (Hs.SrcLoc fn l c) =+    Loc fn [] [] (l,c) (-1,-1)++-----------------------------------------------------------------------------++-- * ToType HsType++instance ToName (Hs.TyVarBind l) where+  toName (Hs.KindedVar _ n _) = toName n+  toName (Hs.UnkindedVar _ n) = toName n++instance ToName Name where+  toName = id++instance ToName TyVarBndr where+  toName (PlainTV n) = n+  toName (KindedTV n _) = n++instance ToType (Hs.Kind l) where+  toType (Hs.KindStar _) = StarT+  toType (Hs.KindFn _ k1 k2) = toType k1 .->. toType k2+  toType (Hs.KindParen _ kp) = toType kp+  toType (Hs.KindVar _ n)+      | isCon (nameBase th_n) = ConT th_n+      | otherwise             = VarT th_n+    where+      th_n = toName n++      isCon :: String -> Bool+      isCon (c:_) = isUpper c || c == ':'+      isCon _ = nonsense "toType" "empty kind variable name" n+  toType (Hs.KindApp _ k1 k2) = toType k1 `AppT` toType k2+  toType (Hs.KindTuple _ ks) = foldr (\k pt -> pt `AppT` toType k) (TupleT $ length ks) ks+  toType (Hs.KindList _ k) = ListT `AppT` toType k++toKind :: Hs.Kind l -> Kind+toKind = toType++toTyVar :: Hs.TyVarBind l -> TyVarBndr+toTyVar (Hs.KindedVar _ n k) = KindedTV (toName n) (toKind k)+toTyVar (Hs.UnkindedVar _ n) = PlainTV (toName n)++instance ToType (Hs.Type l) where+  toType (Hs.TyForall _ tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t)+  toType (Hs.TyFun _ a b) = toType a .->. toType b+  toType (Hs.TyList _ t) = ListT `AppT` toType t+  toType (Hs.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts)+   where+    tuple = case b of+      Hs.Boxed -> TupleT+      Hs.Unboxed -> UnboxedTupleT+  toType (Hs.TyApp _ a b) = AppT (toType a) (toType b)+  toType (Hs.TyVar _ n) = VarT (toName n)+  toType (Hs.TyCon _ qn) = ConT (toName qn)+  toType (Hs.TyParen _ t) = toType t+  -- XXX: need to wrap the name in parens!+  toType (Hs.TyInfix _ a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b)+  toType (Hs.TyKind _ t k) = SigT (toType t) (toKind k)+  toType (Hs.TyPromoted _ p) =+      case p of+        Hs.PromotedInteger _ i _ -> LitT $ NumTyLit i+        Hs.PromotedString _ _ s -> LitT $ StrTyLit s+        Hs.PromotedCon _ _q n -> PromotedT (toName n)+        Hs.PromotedList _ _q ts -> foldr (\t pl -> PromotedConsT `AppT` toType t `AppT` pl) PromotedNilT ts+        Hs.PromotedTuple _ ts -> foldr (\t pt -> pt `AppT` toType t) (PromotedTupleT $ length ts) ts+        Hs.PromotedUnit _ -> PromotedT ''()+  toType (Hs.TyEquals _ t1 t2) = EqualityT `AppT` toType t1 `AppT` toType t2+  toType t@(Hs.TySplice _ _) = noTH "toType" t+  toType t@Hs.TyBang{} =+    nonsense "toType" "type cannot have strictness annotations in this context" t+  toType t@(Hs.TyWildCard _ _) = noTH "toType" t+  toType t = todo "toType" t++toStrictType :: Hs.Type l -> StrictType+#if MIN_VERSION_haskell_src_exts(1,18,0)+#if MIN_VERSION_template_haskell(2,11,0)+toStrictType (Hs.TyBang _ s u t) = (Bang (toUnpack u) (toStrict s), toType t)+    where+      toStrict (Hs.LazyTy _) = SourceLazy+      toStrict (Hs.BangedTy _) = SourceStrict+      toStrict (Hs.NoStrictAnnot _) = NoSourceStrictness+      toUnpack (Hs.Unpack _) = SourceUnpack+      toUnpack (Hs.NoUnpack _) = SourceNoUnpack+      toUnpack (Hs.NoUnpackPragma _) = NoSourceUnpackedness+toStrictType x = (Bang NoSourceUnpackedness NoSourceStrictness, toType x)+#else+-- TyBang l (BangType l) (Unpackedness l) (Type l)+-- data BangType l = BangedTy l	| LazyTy l | NoStrictAnnot l+-- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l+toStrictType (Hs.TyBang _ b u t) = (toStrict b u, toType t)+    where+      toStrict :: Hs.BangType l -> Hs.Unpackedness l -> Strict+      toStrict (Hs.BangedTy _) _ = IsStrict+      toStrict _ (Hs.Unpack _) = Unpacked+      toStrict _ _ = NotStrict+toStrictType x = (NotStrict, toType x)+#endif+#else+#if MIN_VERSION_template_haskell(2,11,0)+toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = toStrictType2 SourceUnpack t+toStrictType t = toStrictType2 NoSourceUnpackedness t++toStrictType2 u t@(Hs.TyBang _ _ Hs.TyBang{}) =+  nonsense "toStrictType" "double strictness annotation" t+toStrictType2 u (Hs.TyBang _ (Hs.BangedTy _) t) = (Bang u SourceStrict, toType t)+toStrictType2 u (Hs.TyBang _ (Hs.UnpackedTy _) t) =+  nonsense "toStrictType" "double unpackedness annotation" t+toStrictType2 u t = (Bang u NoSourceStrictness, toType t)+#else /* !MIN_VERSION_template_haskell(2,11,0) */+toStrictType t@(Hs.TyBang _ _ Hs.TyBang{}) =+  nonsense "toStrictType" "double strictness annotation" t+toStrictType (Hs.TyBang _ (Hs.BangedTy _) t) = (IsStrict, toType t)+toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = (Unpacked, toType t)+toStrictType t = (NotStrict, toType t)+#endif /* !MIN_VERSION_template_haskell(2,11,0) */+#endif+++(.->.) :: Type -> Type -> Type+a .->. b = AppT (AppT ArrowT a) b++instance ToPred (Hs.Asst l) where+#if MIN_VERSION_template_haskell(2,10,0)+    toPred (Hs.ClassA _ n ts) = foldl' AppT (ConT (toName n)) (fmap toType ts)+    toPred (Hs.InfixA _ t1 n t2) = foldl' AppT (ConT (toName n)) (fmap toType [t1,t2])+    toPred (Hs.EqualP _ t1 t2) = foldl' AppT EqualityT (fmap toType [t1,t2])+    toPred (Hs.ParenA _ asst) = toPred asst+    toPred a@Hs.AppA{} = todo "toCxt" a+    toPred a@Hs.WildCardA{} = todo "toCxt" a+#else+    toPred (Hs.ClassA _ n ts) = ClassP (toName n) (fmap toType ts)+    toPred (Hs.InfixA _ t1 n t2) = ClassP (toName n) (fmap toType [t1, t2])+    toPred (Hs.EqualP _ t1 t2) = EqualP (toType t1) (toType t2)+#endif+    toPred a@Hs.IParam{} = noTH "toCxt" a+    toPred p = todo "toPred" p++#if MIN_VERSION_template_haskell(2,11,0)+instance ToCxt (Hs.Deriving l) where+  toCxt (Hs.Deriving _ rule) = toCxt rule+instance ToCxt [Hs.InstRule l] where+  toCxt = concatMap toCxt+#endif++instance ToCxt a => ToCxt (Maybe a) where+    toCxt Nothing = []+    toCxt (Just a) = toCxt a++foldAppT :: Type -> [Type] -> Type+foldAppT t ts = foldl' AppT t ts++-----------------------------------------------------------------------------++-- * ToStmt HsStmt++instance ToStmt (Hs.Stmt l) where+  toStmt (Hs.Generator _ p e)  = BindS (toPat p) (toExp e)+  toStmt (Hs.Qualifier _ e)      = NoBindS (toExp e)+  toStmt a@(Hs.LetStmt _ bnds)   = LetS (toDecs bnds)+  toStmt s@Hs.RecStmt{}        = noTH "toStmt" s+++-----------------------------------------------------------------------------++-- * ToDec HsDecl++instance ToDec (Hs.Decl l) where+  toDec (Hs.TypeDecl _ h t)+    = TySynD (toName h) (toTyVars h) (toType t)++  toDec a@(Hs.DataDecl  _ dOrN cxt h qcds qns)+    = case dOrN of+        Hs.DataType _ -> DataD (toCxt cxt)+                             (toName h)+                             (toTyVars h)+#if MIN_VERSION_template_haskell(2,11,0)+                             Nothing+#endif+                             (fmap qualConDeclToCon qcds)+#if MIN_VERSION_template_haskell(2,11,0)+                             -- Convert a Deriving into a list of types, one for each derived class+                             -- Assumes that the types do not have any contexts+                             (maybe [] (\(Hs.Deriving _ q) -> map toType q) qns)+#else+                             (toNames qns)+#endif+        Hs.NewType _  -> let qcd = case qcds of+                                     [x] -> x+                                     _   -> nonsense "toDec" ("newtype with " +++                                                              "wrong number of constructors") a+                        in NewtypeD (toCxt cxt)+                                    (toName h)+                                    (toTyVars h)+#if MIN_VERSION_template_haskell(2,11,0)+                                    Nothing+#endif+                                    (qualConDeclToCon qcd)+#if MIN_VERSION_template_haskell(2,11,0)+                                    (maybe [] (\(Hs.Deriving _ q) -> map toType q) qns)+#else+                                    (toNames qns)+#endif++  -- This type-signature conversion is just wrong.+  -- Type variables need to be dealt with. /Jonas+  toDec a@(Hs.TypeSig _ ns t)+    -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!+    = let xs = fmap (flip SigD (toType t) . toName) ns+      in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"++  toDec (Hs.InlineConlikeSig _ act qn) = PragmaD $+    InlineP (toName qn) Inline ConLike (transAct act)+  toDec (Hs.InlineSig _ b act qn) = PragmaD $+    InlineP (toName qn) inline FunLike (transAct act)+   where+    inline | b = Inline | otherwise = NoInline++#if MIN_VERSION_template_haskell(2,11,0)+#if MIN_VERSION_haskell_src_exts(1,18,0)+  toDec (Hs.TypeFamDecl _ h sig inj)+    = OpenTypeFamilyD $ TypeFamilyHead (toName h)+                                       (toTyVars h)+                                       (maybe NoSig KindSig . toMaybeKind $ sig)+                                       (fmap toInjectivityAnn inj)+  toDec (Hs.DataFamDecl _ _ h sig)+    = DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig)+#else+  toDec (Hs.TypeFamDecl _ h k)+    = OpenTypeFamilyD $ TypeFamilyHead (toName h)+                                       (toTyVars h)+                                       (maybe NoSig (KindSig . toKind) k)+                                       Nothing+  -- TODO: do something with context?+  toDec (Hs.DataFamDecl _ _ h k)+    = DataFamilyD (toName h) (toTyVars h) (fmap toKind k)+#endif++#else+#if MIN_VERSION_haskell_src_exts(1,18,0)+  toDec (Hs.TypeFamDecl _ h sig inj)+    = FamilyD TypeFam (toName h) (toTyVars h) (toMaybeKind sig)+  toDec (Hs.DataFamDecl _ _ h sig)+    = FamilyD DataFam (toName h) (toTyVars h) (toMaybeKind sig)+#else+  toDec (Hs.TypeFamDecl _ h k)+    = FamilyD TypeFam (toName h) (toTyVars h) (fmap toKind k)++  -- TODO: do something with context?+  toDec (Hs.DataFamDecl _ _ h k)+    = FamilyD DataFam (toName h) (toTyVars h) (fmap toKind k)+#endif+#endif /* MIN_VERSION_template_haskell(2,11,0) */++  toDec a@(Hs.FunBind _ mtchs)                           = hsMatchesToFunD mtchs+  toDec (Hs.PatBind _ p rhs bnds)                      = ValD (toPat p)+                                                              (hsRhsToBody rhs)+                                                              (toDecs bnds)++  toDec i@(Hs.InstDecl _ (Just overlap) _ _) =+    noTH "toDec" (fmap (const ()) overlap, i)++  -- the 'vars' bit seems to be for: instance forall a. C (T a) where ...+  -- TH's own parser seems to flat-out ignore them, and honestly I can't see+  -- that it's obviously wrong to do so.+#if MIN_VERSION_template_haskell(2,11,0)+  toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD+    Nothing+    (toCxt irule)+    (toType irule)+    (toDecs ids)+#else+  toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD+    (toCxt irule)+    (toType irule)+    (toDecs ids)+#endif++  toDec (Hs.ClassDecl _ cxt h fds decls) = ClassD+    (toCxt cxt)+    (toName h)+    (toTyVars h)+    (fmap toFunDep fds)+    (toDecs decls)+   where+    toFunDep (Hs.FunDep _ ls rs) = FunDep (fmap toName ls) (fmap toName rs)++  toDec x = todo "toDec" x++#if MIN_VERSION_haskell_src_exts(1,18,0)+instance ToMaybeKind (Hs.ResultSig l) where+    toMaybeKind (Hs.KindSig _ k) = Just $ toKind k+    toMaybeKind (Hs.TyVarSig _ _) = Nothing++instance ToMaybeKind a => ToMaybeKind (Maybe a) where+    toMaybeKind Nothing = Nothing+    toMaybeKind (Just a) = toMaybeKind a++#if MIN_VERSION_template_haskell(2,11,0)+instance ToInjectivityAnn (Hs.InjectivityInfo l) where+  toInjectivityAnn (Hs.InjectivityInfo _ n ns) = InjectivityAnn (toName n) (fmap toName ns)+#endif+#endif++transAct :: Maybe (Hs.Activation l) -> Phases+transAct Nothing = AllPhases+transAct (Just (Hs.ActiveFrom _ n)) = FromPhase n+transAct (Just (Hs.ActiveUntil _ n)) = BeforePhase n++instance ToName (Hs.DeclHead l) where+  toName (Hs.DHead _ n) = toName n+  toName (Hs.DHInfix _ _ n) = toName n+  toName (Hs.DHParen _ h) = toName h+  toName (Hs.DHApp _ h _) = toName h++instance ToTyVars (Hs.DeclHead l) where+  toTyVars (Hs.DHead _ _) = []+  toTyVars (Hs.DHParen _ h) = toTyVars h+  toTyVars (Hs.DHInfix _ tvb _) = [toTyVar tvb]+  toTyVars (Hs.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb]++instance ToNames a => ToNames (Maybe a) where+  toNames Nothing = []+  toNames (Just a) = toNames a++instance ToNames (Hs.Deriving l) where+  toNames (Hs.Deriving _ irules) = concatMap toNames irules+instance ToNames (Hs.InstRule l) where+  toNames (Hs.IParen _ irule) = toNames irule+  toNames (Hs.IRule _ _mtvbs _mcxt mihd) = toNames mihd+instance ToNames (Hs.InstHead l) where+  toNames (Hs.IHCon _ n) = [toName n]+  toNames (Hs.IHInfix _ _ n) = [toName n]+  toNames (Hs.IHParen _ h) = toNames h+  toNames (Hs.IHApp _ h _) = toNames h++instance ToCxt (Hs.InstRule l) where+  toCxt (Hs.IRule _ _ cxt _) = toCxt cxt+  toCxt (Hs.IParen _ irule) = toCxt irule++instance ToCxt (Hs.Context l) where+  toCxt x = case x of+              Hs.CxEmpty _ -> []+              Hs.CxSingle _ x' -> [toPred x']+              Hs.CxTuple _ xs -> fmap toPred xs++instance ToType (Hs.InstRule l) where+    toType (Hs.IRule _ _ _ h) = toType h+    toType (Hs.IParen _ irule) = toType irule++instance ToType (Hs.InstHead l) where+    toType (Hs.IHCon _ qn) = toType qn+    toType (Hs.IHInfix _ typ qn) = AppT (toType typ) (toType qn)+    toType (Hs.IHParen _ hd) = toType hd+    toType (Hs.IHApp _ hd typ) = AppT (toType hd) (toType typ)++qualConDeclToCon :: Hs.QualConDecl l -> Con+qualConDeclToCon (Hs.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl+qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (toTyVars ns)+                                                    (toCxt cxt)+                                                    (conDeclToCon cdecl)++instance ToTyVars a => ToTyVars (Maybe a) where+  toTyVars Nothing = []+  toTyVars (Just a) = toTyVars a++instance ToTyVars a => ToTyVars [a] where+  toTyVars = concatMap toTyVars++instance ToTyVars (Hs.TyVarBind l) where+  toTyVars tvb = [toTyVar tvb]++instance ToType (Hs.QName l) where+    toType = ConT . toName++conDeclToCon :: Hs.ConDecl l -> Con+conDeclToCon (Hs.ConDecl _ n tys)+  = NormalC (toName n) (map toStrictType tys)+conDeclToCon (Hs.RecDecl _ n fieldDecls)+  = RecC (toName n) (concatMap convField fieldDecls)+  where+    convField :: Hs.FieldDecl l -> [VarStrictType]+    convField (Hs.FieldDecl _ ns t) =+      let (strict, ty) = toStrictType t+      in map (\n' -> (toName n', strict, ty)) ns+++hsMatchesToFunD :: [Hs.Match l] -> Dec+hsMatchesToFunD [] = FunD (mkName []) []   -- errorish+hsMatchesToFunD xs@(Hs.Match _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs)+++hsMatchToClause :: Hs.Match l -> Clause+hsMatchToClause (Hs.Match _ _ ps rhs bnds) = Clause+                                                (fmap toPat ps)+                                                (hsRhsToBody rhs)+                                                (toDecs bnds)++++hsRhsToBody :: Hs.Rhs l -> Body+hsRhsToBody (Hs.UnGuardedRhs _ e) = NormalB (toExp e)+hsRhsToBody (Hs.GuardedRhss _ hsgrhs) = let fromGuardedB (GuardedB a) = a+                                      in GuardedB . concat+                                          . fmap (fromGuardedB . hsGuardedRhsToBody)+                                              $ hsgrhs++++hsGuardedRhsToBody :: Hs.GuardedRhs l -> Body+hsGuardedRhsToBody (Hs.GuardedRhs _ [] e)  = NormalB (toExp e)+hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]+hsGuardedRhsToBody (Hs.GuardedRhs _ ss e)  = let ss' = fmap hsStmtToGuard ss+                                                 (pgs,ngs) = unzip [(p,n)+                                                               | (PatG p) <- ss'+                                                               , n@(NormalG _) <- ss']+                                                 e' = toExp e+                                                 patg = PatG (concat pgs)+                                            in GuardedB $ (patg,e') : zip ngs (repeat e')++++hsStmtToGuard :: Hs.Stmt l -> Guard+hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]+hsStmtToGuard (Hs.Qualifier _ e)     = NormalG (toExp e)+hsStmtToGuard (Hs.LetStmt _ bs)      = PatG [LetS (toDecs bs)]+++-----------------------------------------------------------------------------++-- * ToDecs InstDecl+instance ToDecs (Hs.InstDecl l) where+  toDecs (Hs.InsDecl _ decl) = toDecs decl+  toDecs d              = todo "toDec" d++-- * ToDecs HsDecl HsBinds++instance ToDecs (Hs.Decl l) where+  toDecs a@(Hs.TypeSig _ ns t)+    = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns+       in xs++  toDecs (Hs.InfixDecl l assoc Nothing ops) =+      toDecs (Hs.InfixDecl l assoc (Just 9) ops)+  toDecs (Hs.InfixDecl _ assoc (Just fixity) ops) =+    map (\op -> InfixD (Fixity fixity dir) (toName op)) ops+   where+    dir = case assoc of+      Hs.AssocNone _ -> InfixN+      Hs.AssocLeft _ -> InfixL+      Hs.AssocRight _ -> InfixR++  toDecs a = [toDec a]++collectVars e = case e of+  VarT n -> [PlainTV n]+  AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2+  ForallT ns _ t -> collectVars t \\ ns+  _          -> []++fixForall t@(ForallT _ _ _) = t+fixForall t = case vs of+  [] -> t+  _  -> ForallT vs [] t+  where vs = collectVars t++instance ToDecs a => ToDecs [a] where+  toDecs a = concatMap toDecs a++-----------------------------------------------------------------------------
+ doc/generated/FontHersheyComplex.png view

binary file changed (absent → 8710 bytes)

+ doc/generated/FontHersheyComplexSmall.png view

binary file changed (absent → 5691 bytes)

+ doc/generated/FontHersheyComplexSmall_slanted.png view

binary file changed (absent → 6119 bytes)

+ doc/generated/FontHersheyComplex_slanted.png view

binary file changed (absent → 9656 bytes)

+ doc/generated/FontHersheyDuplex.png view

binary file changed (absent → 7683 bytes)

+ doc/generated/FontHersheyDuplex_slanted.png view

binary file changed (absent → 7683 bytes)

+ doc/generated/FontHersheyPlain.png view

binary file changed (absent → 3248 bytes)

+ doc/generated/FontHersheyPlain_slanted.png view

binary file changed (absent → 3255 bytes)

+ doc/generated/FontHersheyScriptComplex.png view

binary file changed (absent → 7639 bytes)

+ doc/generated/FontHersheyScriptComplex_slanted.png view

binary file changed (absent → 7639 bytes)

+ doc/generated/FontHersheyScriptSimplex.png view

binary file changed (absent → 7607 bytes)

+ doc/generated/FontHersheyScriptSimplex_slanted.png view

binary file changed (absent → 7607 bytes)

+ doc/generated/FontHersheySimplex.png view

binary file changed (absent → 6557 bytes)

+ doc/generated/FontHersheySimplex_slanted.png view

binary file changed (absent → 6557 bytes)

+ doc/generated/FontHersheyTriplex.png view

binary file changed (absent → 9664 bytes)

+ doc/generated/FontHersheyTriplex_slanted.png view

binary file changed (absent → 10460 bytes)

+ doc/generated/LineType_4.png view

binary file changed (absent → 332 bytes)

+ doc/generated/LineType_8.png view

binary file changed (absent → 341 bytes)

+ doc/generated/LineType_AA.png view

binary file changed (absent → 415 bytes)

+ doc/generated/bikes_512x341.png view

binary file changed (absent → 355695 bytes)

+ doc/generated/birds_512x341.png view

binary file changed (absent → 266639 bytes)

+ doc/generated/examples/arrowedLineImg.png view

binary file changed (absent → 6294 bytes)

+ doc/generated/examples/bfMatcherImg.png view

binary file changed (absent → 509680 bytes)

+ doc/generated/examples/bitwiseAndImg.png view

binary file changed (absent → 8706 bytes)

+ doc/generated/examples/bitwiseNotImg.png view

binary file changed (absent → 7813 bytes)

+ doc/generated/examples/bitwiseOrImg.png view

binary file changed (absent → 10059 bytes)

+ doc/generated/examples/bitwiseXorImg.png view

binary file changed (absent → 11291 bytes)

+ doc/generated/examples/boxBlurImg.png view

binary file changed (absent → 440308 bytes)

+ doc/generated/examples/cannyImg.png view

binary file changed (absent → 1717 bytes)

+ doc/generated/examples/cascadeClassifierArnold.png view

binary file changed (absent → 661798 bytes)

+ doc/generated/examples/circleImg.png view

binary file changed (absent → 11850 bytes)

+ doc/generated/examples/colorMapAutumImg.png view

binary file changed (absent → 234 bytes)

+ doc/generated/examples/colorMapBoneImg.png view

binary file changed (absent → 350 bytes)

+ doc/generated/examples/colorMapCoolImg.png view

binary file changed (absent → 231 bytes)

+ doc/generated/examples/colorMapHotImg.png view

binary file changed (absent → 317 bytes)

+ doc/generated/examples/colorMapHsvImg.png view

binary file changed (absent → 270 bytes)

+ doc/generated/examples/colorMapJetImg.png view

binary file changed (absent → 259 bytes)

+ doc/generated/examples/colorMapOceanImg.png view

binary file changed (absent → 274 bytes)

+ doc/generated/examples/colorMapParulaImg.png view

binary file changed (absent → 445 bytes)

+ doc/generated/examples/colorMapPinkImg.png view

binary file changed (absent → 415 bytes)

+ doc/generated/examples/colorMapRainbowImg.png view

binary file changed (absent → 324 bytes)

+ doc/generated/examples/colorMapSpringImg.png view

binary file changed (absent → 230 bytes)

+ doc/generated/examples/colorMapSummerImg.png view

binary file changed (absent → 239 bytes)

+ doc/generated/examples/colorMapWinterImg.png view

binary file changed (absent → 248 bytes)

+ doc/generated/examples/cvtColorImg.png view

binary file changed (absent → 433263 bytes)

+ doc/generated/examples/dctDenoisingImg.png view

binary file changed (absent → 879420 bytes)

+ doc/generated/examples/decolorImg.png view

binary file changed (absent → 940483 bytes)

+ doc/generated/examples/denoise_TVL1Img.png view

binary file changed (absent → 1009258 bytes)

+ doc/generated/examples/dilateImg.png view

binary file changed (absent → 3105 bytes)

+ doc/generated/examples/drawChArUcoBoardImg.png view

binary file changed (absent → 5132 bytes)

+ doc/generated/examples/ellipseImg.png view

binary file changed (absent → 11458 bytes)

+ doc/generated/examples/erodeImg.png view

binary file changed (absent → 3107 bytes)

+ doc/generated/examples/fastNlMeansDenoisingColoredImg.png view

binary file changed (absent → 913667 bytes)

+ doc/generated/examples/fastNlMeansDenoisingColoredMultiImg.png view

binary file changed (absent → 913667 bytes)

+ doc/generated/examples/fbMatcherImg.png view

binary file changed (absent → 513475 bytes)

+ doc/generated/examples/fillConvexPolyImg.png view

binary file changed (absent → 6152 bytes)

+ doc/generated/examples/fillPolyImg.png view

binary file changed (absent → 4750 bytes)

+ doc/generated/examples/filter2DImg.png view

binary file changed (absent → 651140 bytes)

+ doc/generated/examples/floodFillImg.png view

binary file changed (absent → 704232 bytes)

+ doc/generated/examples/flowerContours.png view

binary file changed (absent → 232432 bytes)

+ doc/generated/examples/fromImageImg.png view

binary file changed (absent → 523220 bytes)

+ doc/generated/examples/goodFeaturesToTrackTraces.png view

binary file changed (absent → 268834 bytes)

+ doc/generated/examples/grabCutBird.png view

binary file changed (absent → 92520 bytes)

+ doc/generated/examples/grayscaleImg.png view

binary file changed (absent → 134 bytes)

+ doc/generated/examples/grayworldWBImg.png view

file too large to diff

+ doc/generated/examples/houghCircleTraces.png view

binary file changed (absent → 701557 bytes)

+ doc/generated/examples/houghLinesPTraces.png view

binary file changed (absent → 64520 bytes)

+ doc/generated/examples/inpaintImg.png view

binary file changed (absent → 783985 bytes)

+ doc/generated/examples/laplacianImg.png view

binary file changed (absent → 84466 bytes)

+ doc/generated/examples/lineImg.png view

binary file changed (absent → 3948 bytes)

+ doc/generated/examples/markerImg.png view

binary file changed (absent → 575 bytes)

+ doc/generated/examples/matAbsDiffImg.png view

binary file changed (absent → 354361 bytes)

+ doc/generated/examples/matAddImg.png view

binary file changed (absent → 287078 bytes)

+ doc/generated/examples/matAddWeightedImg.png view

binary file changed (absent → 289585 bytes)

+ doc/generated/examples/matFlipImg.png view

binary file changed (absent → 296107 bytes)

+ doc/generated/examples/matFromFuncImg.png view

binary file changed (absent → 67119 bytes)

+ doc/generated/examples/matSplitImg.png view

binary file changed (absent → 390890 bytes)

+ doc/generated/examples/matSubRectImg.png view

binary file changed (absent → 477260 bytes)

+ doc/generated/examples/matSubtractImg.png view

binary file changed (absent → 196826 bytes)

+ doc/generated/examples/matSumImg.png view

binary file changed (absent → 3313 bytes)

+ doc/generated/examples/matTransposeImg.png view

binary file changed (absent → 298870 bytes)

+ doc/generated/examples/medianBlurImg.png view

binary file changed (absent → 455977 bytes)

+ doc/generated/examples/morphCrossImg.png view

binary file changed (absent → 173 bytes)

+ doc/generated/examples/morphEllipseImg.png view

binary file changed (absent → 647 bytes)

+ doc/generated/examples/morphRectImg.png view

binary file changed (absent → 151 bytes)

+ doc/generated/examples/orbDetectAndComputeImg.png view

binary file changed (absent → 279069 bytes)

+ doc/generated/examples/polylinesImg.png view

binary file changed (absent → 6384 bytes)

+ doc/generated/examples/putTextImg.png view

binary file changed (absent → 32827 bytes)

+ doc/generated/examples/rectangleImg.png view

binary file changed (absent → 2294 bytes)

+ doc/generated/examples/remapImg.png view

binary file changed (absent → 220259 bytes)

+ doc/generated/examples/resizeInterAreaImg.png view

binary file changed (absent → 779235 bytes)

+ doc/generated/examples/surfDetectAndComputeImg.png view

binary file changed (absent → 381700 bytes)

+ doc/generated/examples/threshBinaryBirds.png view

binary file changed (absent → 13500 bytes)

+ doc/generated/examples/threshBinaryInvBirds.png view

binary file changed (absent → 13504 bytes)

+ doc/generated/examples/threshToZeroBirds.png view

binary file changed (absent → 84693 bytes)

+ doc/generated/examples/threshToZeroInvBirds.png view

binary file changed (absent → 83193 bytes)

+ doc/generated/examples/threshTruncateBirds.png view

binary file changed (absent → 78049 bytes)

+ doc/generated/examples/toImageImg.png view

binary file changed (absent → 524412 bytes)

+ doc/generated/examples/undistortImg.png view

binary file changed (absent → 215796 bytes)

+ doc/generated/examples/vennCircleAImg.png view

binary file changed (absent → 2588 bytes)

+ doc/generated/examples/vennCircleBImg.png view

binary file changed (absent → 2473 bytes)

+ doc/generated/examples/warpAffineImg.png view

binary file changed (absent → 156486 bytes)

+ doc/generated/examples/warpAffineInvImg.png view

binary file changed (absent → 234899 bytes)

+ doc/generated/flower_512x341.png view

binary file changed (absent → 277498 bytes)

+ doc/generated/sailboat_512x341.png view

binary file changed (absent → 295814 bytes)

+ doc/images.hs view
@@ -0,0 +1,270 @@+{-# language TemplateHaskell #-}+{-# language OverloadedStrings #-}+{-# language FlexibleContexts #-}+{-# language CPP #-}++module Main where++import "base" Data.Functor ( void )+import "base" Data.Foldable ( forM_ )+import "base" Data.Int+import "base" Data.Monoid ( (<>) )+import "base" Data.Proxy+import "base" Data.Traversable+import "base" Data.Word+import "base" Foreign.C.Types ( CFloat )+import "base" GHC.TypeLits+import "base" System.IO.Unsafe ( unsafePerformIO )+import "data-default" Data.Default+import qualified "bytestring" Data.ByteString as B+import qualified "JuicyPixels" Codec.Picture+import qualified "linear" Linear.Metric as Linear ( norm )+import "linear" Linear ( M33 )+import "linear" Linear.Vector ( (^+^), (^-^) )+import "linear" Linear.V2 ( V2(..) )+import "linear" Linear.V3 ( V3(..) )+import "linear" Linear.V4 ( V4(..) )+import "opencv" OpenCV+import qualified "opencv" OpenCV.Juicy+import "opencv" OpenCV.Unsafe+#ifdef HAVE_OPENCV_EXTRA+import "opencv-extra" OpenCV.Extra+#endif+import "primitive" Control.Monad.Primitive ( PrimMonad, PrimState )+import qualified "text" Data.Text as T+import qualified "vector" Data.Vector as V+import "transformers" Control.Monad.Trans.Class ( lift )++import "this" ExampleExtractor++--------------------------------------------------------------------------------++transparent, white, black, blue, green, red :: Scalar+transparent = toScalar (V4 255 255 255   0 :: V4 Double)+white       = toScalar (V4 255 255 255 255 :: V4 Double)+black       = toScalar (V4   0   0   0 255 :: V4 Double)+blue        = toScalar (V4 255   0   0 255 :: V4 Double)+green       = toScalar (V4   0 255   0 255 :: V4 Double)+red         = toScalar (V4   0   0 255 255 :: V4 Double)++type Birds_768x512    = Mat (ShapeT [512, 768]) ('S 3) ('S Word8)+type Flower_768x512   = Mat (ShapeT [512, 768]) ('S 3) ('S Word8)+type Sailboat_768x512 = Mat (ShapeT [512, 768]) ('S 3) ('S Word8)+type Bikes_768x512    = Mat (ShapeT [512, 768]) ('S 3) ('S Word8)+type Birds_512x341    = Mat (ShapeT [341, 512]) ('S 3) ('S Word8)+type Flower_512x341   = Mat (ShapeT [341, 512]) ('S 3) ('S Word8)+type Sailboat_512x341 = Mat (ShapeT [341, 512]) ('S 3) ('S Word8)+type Bikes_512x341    = Mat (ShapeT [341, 512]) ('S 3) ('S Word8)+type Frog             = Mat (ShapeT [390, 500]) ('S 3) ('S Word8)+type Lambda           = Mat (ShapeT [256, 256]) ('S 1) ('S Word8)+type Circles_1000x625 = Mat (ShapeT [625, 1000]) ('S 3) ('S Word8)+type Building_868x600 = Mat (ShapeT [600, 868]) ('S 3) ('S Word8)+type DamageMask       = Mat (ShapeT [341, 512]) ('S 1) ('S Word8)+type Lenna_512x512    = Mat (ShapeT [512, 512]) ('S 3) ('S Word8)+type Arnold           = Mat (ShapeT [3504, 2336]) ('S 3) ('S Word8)+type Arnold_small     = Mat (ShapeT [ 900,  600]) ('S 3) ('S Word8)++birds_768x512 :: Birds_768x512+birds_768x512 = exceptError $ coerceMat $ unsafePerformIO $+                  imdecode ImreadUnchanged <$> B.readFile "data/kodim23.png"++flower_768x512 :: Flower_768x512+flower_768x512 =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadUnchanged <$> B.readFile "data/kodim07.png"++sailboat_768x512 :: Sailboat_768x512+sailboat_768x512 =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadUnchanged <$> B.readFile "data/kodim06.png"++bikes_768x512 :: Sailboat_768x512+bikes_768x512 =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadUnchanged <$> B.readFile "data/kodim05.png"++damageMask :: DamageMask+damageMask =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadUnchanged <$> B.readFile "data/damage_mask.png"++smallerKodakImg+    :: Mat (ShapeT [512, 768]) ('S 3) ('S Word8)+    -> Mat (ShapeT [341, 512]) ('S 3) ('S Word8)+smallerKodakImg img =+    exceptError $ coerceMat =<<+      resize (ResizeAbs $ toSize (V2 512 341 :: V2 Int32))+             InterArea+             img++birds_512x341 :: Birds_512x341+birds_512x341 = smallerKodakImg birds_768x512++flower_512x341 :: Flower_512x341+flower_512x341 = smallerKodakImg flower_768x512++sailboat_512x341 :: Flower_512x341+sailboat_512x341 = smallerKodakImg sailboat_768x512++bikes_512x341 :: Flower_512x341+bikes_512x341 = smallerKodakImg bikes_768x512++frog :: Frog+frog =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadUnchanged <$> B.readFile "data/kikker.jpg"++lambda :: Lambda+lambda =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadGrayscale <$> B.readFile "data/lambda.png"++circles_1000x625 :: Circles_1000x625+circles_1000x625 =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadUnchanged <$> B.readFile "data/circles.png"++building_868x600 :: Building_868x600+building_868x600 =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadUnchanged <$> B.readFile "data/building.jpg"++lenna_512x512 :: Lenna_512x512+lenna_512x512 =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadUnchanged <$> B.readFile "data/Lenna.png"++arnold :: Arnold+arnold =+    exceptError $ coerceMat $ unsafePerformIO $+      imdecode ImreadUnchanged <$> B.readFile "data/arnold-schwarzenegger.jpg"++arnold_small :: Arnold_small+arnold_small =+    exceptError $ coerceMat =<<+      resize (ResizeAbs $ toSize (V2 600 900 :: V2 Int32))+             InterArea+             arnold++--------------------------------------------------------------------------------++type CarOverhead = Animation (ShapeT [240, 320]) ('S 3) ('S Word8)++carOverhead :: CarOverhead+carOverhead = unsafePerformIO $ loadAnimation 4 "data/car-overhead-3.mp4"++--------------------------------------------------------------------------------++loadAnimation+    :: (ToNatDS (Proxy h), ToNatDS (Proxy w))+    => Int+    -> FilePath+    -> IO (Animation ('S [h, w]) ('S 3) ('S Word8))+loadAnimation delay fp = do+    cap <- newVideoCapture+    exceptErrorIO $ videoCaptureOpen cap (VideoFileSource fp Nothing)+    frames <- grabFrames cap []+    exceptErrorIO $ videoCaptureRelease cap+    pure $ map (delay, ) frames+  where+    grabFrames cap frames = do+        ok <- videoCaptureGrab cap+        if ok+        then do+          mbFrameRaw <- videoCaptureRetrieve cap+          case mbFrameRaw of+            Nothing -> pure $ reverse frames+            Just frameRaw -> do+              frame <- exceptErrorIO $ pureExcept $ coerceMat frameRaw+              grabFrames cap (frame : frames)+        else pure $ reverse frames++--------------------------------------------------------------------------------++-- We use some padding around the small image in which we draw the+-- lines. This is because antialiasing doesn't seem to work near the+-- edges of an image.+lineTypeImg+    :: forall (h :: Nat) (w :: Nat) (p :: Nat)+     . ( h ~ 5+       , w ~ (h * 3)+       , p ~ 20+       )+    => LineType+    -> Mat ('S ['D, 'D]) ('S 4) ('S Word8)+lineTypeImg lineType = exceptError $ do+    img <- withMatM (h + 2 * p ::: w + 2 * p ::: Z)+                    (Proxy :: Proxy 4)+                    (Proxy :: Proxy Word8)+                    transparent $ \imgM -> do+             lift $ line imgM (pure p + V2 0 h) (pure p + V2 w 0) black 1 lineType 0+    resize (ResizeRel $ pure zoom) InterNearest+           =<< matSubRect img (toRect $ HRect (pure p) (V2 w h))+  where+    w, h, p :: Int32+    w = fromInteger $ natVal (Proxy :: Proxy w)+    h = fromInteger $ natVal (Proxy :: Proxy h)+    p = fromInteger $ natVal (Proxy :: Proxy p)+    zoom = 8++fontImg+    :: Font+    -> Mat ('S ['D, 'D]) ('S 4) ('S Word8)+fontImg font = exceptError $+    withMatM (th * 3 ::: tw ::: Z)+             (Proxy :: Proxy 4)+             (Proxy :: Proxy Word8)+             transparent $ \imgM -> do+      putText+        imgM+        txt+        (V2 0 (th * 2 - baseLine) :: V2 Int32)+        font+        black+        thickness+        LineType_AA False+  where+    txt = "The quick brown fox jumps over the lazy dog"+    (size2i, baseLine) = getTextSize txt font thickness+    tw, th :: Int32+    V2 tw th = fromSize size2i+    thickness = 1++vennCircleA+    :: (PrimMonad m, ToScalar color)+    => Mut (Mat ('S [height, width]) channels depth) (PrimState m)+    -> color+    -> Int32+    -> m ()+vennCircleA imgM color thickness =+    circle imgM (V2 100 100 :: V2 Int32) 90 color thickness LineType_AA 0++vennCircleB+    :: (PrimMonad m, ToScalar color)+    => Mut (Mat ('S [height, width]) channels depth) (PrimState m)+    -> color+    -> Int32+    -> m ()+vennCircleB imgM color thickness =+    circle imgM (V2 220 100 :: V2 Int32) 90 color thickness LineType_AA 0++--------------------------------------------------------------------------------++extractExampleImages "src"++--------------------------------------------------------------------------------++main :: IO ()+main = do+    renderExampleImages+    renderImage "birds_512x341.png"    birds_512x341+    renderImage "flower_512x341.png"   flower_512x341+    renderImage "sailboat_512x341.png" sailboat_512x341+    renderImage "bikes_512x341.png"    bikes_512x341+    forM_ [minBound .. maxBound] $ \lineType ->+      renderImage (show lineType <> ".png") (lineTypeImg lineType)+    forM_ [minBound .. maxBound] $ \fontFace -> do+      renderImage (show fontFace <> ".png")         (fontImg $ Font fontFace NotSlanted 1)+      renderImage (show fontFace <> "_slanted.png") (fontImg $ Font fontFace Slanted    1)++--------------------------------------------------------------------------------
+ include/aruco.hpp view
@@ -0,0 +1,19 @@+#ifndef __HASKELL_OPENCV_ARUCO_H__+#define __HASKELL_OPENCV_ARUCO_H__++#include <opencv2/aruco.hpp>+#include <opencv2/aruco/charuco.hpp>++namespace cv {+  typedef Matx<float, 5, 1> Matx51f;+  typedef Matx<double, 5, 1> Matx51d;+}++typedef std::vector< std::vector<cv::Point2f> > VectorVectorPoint2f;+typedef std::vector< int > VectorInt;+typedef std::vector< cv::Mat > VectorMat;+typedef cv::Ptr< cv::aruco::Dictionary > Ptr_Dictionary;+typedef cv::Ptr< cv::aruco::CharucoBoard > Ptr_CharucoBoard;+typedef cv::Ptr< cv::aruco::Board > Board;++#endif /* __HASKELL_OPENCV_ARUCO_H__ */
+ include/bgsegm.hpp view
@@ -0,0 +1,7 @@+#ifndef __HASKELL_OPENCV_BGSEGM_H__+#define __HASKELL_OPENCV_BGSEGM_H__++typedef cv::Ptr<cv::bgsegm::BackgroundSubtractorGMG> Ptr_BackgroundSubtractorGMG;+typedef cv::Ptr<cv::bgsegm::BackgroundSubtractorMOG> Ptr_BackgroundSubtractorMOG;++#endif /* __HASKELL_OPENCV_BGSEGM_H__ */
+ include/tracking.hpp view
@@ -0,0 +1,9 @@+#ifndef __HASKELL_OPENCV_TRACKING_H__+#define __HASKELL_OPENCV_TRACKING_H__++typedef cv::Ptr<cv::Tracker> Ptr_Tracker;+typedef cv::Ptr<cv::TrackerFeature> Ptr_TrackerFeature;+typedef cv::Ptr<cv::MultiTracker> Ptr_MultiTracker;+typedef cv::Ptr<cv::MultiTracker_Alt> Ptr_MultiTrackerAlt;++#endif /* __HASKELL_OPENCV_TRACKING_H__ */
+ include/white-ballance.hpp view
@@ -0,0 +1,8 @@+#ifndef __HASKELL_OPENCV_WHITE_BALLANCE_H__+#define __HASKELL_OPENCV_WHITE_BALLANCE_H__++typedef cv::Ptr<cv::xphoto::GrayworldWB> Ptr_GrayworldWB;+typedef cv::Ptr<cv::xphoto::LearningBasedWB> Ptr_LearningBasedWB;+typedef cv::Ptr<cv::xphoto::SimpleWB> Ptr_SimpleWB;++#endif /* __HASKELL_OPENCV_WHITE_BALLANCE_H__ */
+ include/xfeatures/surf.hpp view
@@ -0,0 +1,21 @@+#ifndef __THEA_XFEATURES_SURF_H__+#define __THEA_XFEATURES_SURF_H__++#include "opencv2/xfeatures2d.hpp"++/*+This file defines some SURF related names that are used in++  src/OpenCV/XFeatures2d.hsc.++The reason we need these names is that we can't directly reference their+definitions because that would result in invalid syntax in either hsc2hs and+inline-c.+*/++// TODO #define HARRIS_SCORE cv::ORB::HARRIS_SCORE+// TODO #define FAST_SCORE   cv::ORB::FAST_SCORE++typedef cv::Ptr<cv::xfeatures2d::SURF> Ptr_SURF;++#endif /* __THEA_XFEATURES_SURF_H__ */
+ opencv-extra.cabal view
@@ -0,0 +1,131 @@+name:          opencv-extra+version:       0.0.0.0+homepage:      https://github.com/LumiGuide/haskell-opencv+bug-reports:   https://github.com/LumiGuide/haskell-opencv/issues+license:       BSD3+license-file:  LICENSE+author:        Roel van Dijk <roel@lambdacube.nl>, Bas van Dijk <v.dijk.bas@gmail.com>+maintainer:    Roel van Dijk <roel@lambdacube.nl>, Bas van Dijk <v.dijk.bas@gmail.com>+build-type:    Custom+cabal-version: >=1.23+category:      AI, Graphics+synopsis:      Haskell binding to OpenCV-3.x extra modules++extra-doc-files:+    doc/generated/*.png+    doc/generated/examples/*.png++flag internal-documentation+    description: Enables documentation generation for internal modules.+    default: False+    manual: True++custom-setup+    setup-depends: base, Cabal++library+    hs-source-dirs: src+    include-dirs: include+    install-includes:+        aruco.hpp+        bgsegm.hpp+        tracking.hpp+        white-ballance.hpp+        xfeatures/surf.hpp++    c-sources:+        src/OpenCV/Extra/ArUco.cpp+        src/OpenCV/Extra/Bgsegm.cpp+        src/OpenCV/Extra/Tracking.cpp+        src/OpenCV/Extra/XPhoto.cpp+        src/OpenCV/Extra/XPhoto/WhiteBalancer.cpp+        src/OpenCV/Extra/XFeatures2d.cpp++    cc-options: -Wall -std=c++11+    ghc-options: -Wall -fwarn-incomplete-patterns -funbox-strict-fields -O2+    if flag(internal-documentation)+        cpp-options: -DENABLE_INTERNAL_DOCUMENTATION++    build-depends:+        base              >= 4.8     && <5+      , bindings-DSL      >= 1.0.23+      , bytestring        >= 0.10.6+      , containers        >= 0.5.6.2+      , inline-c          >= 0.5.5.5+      , inline-c-cpp      >= 0.1+      , linear            >= 1.20.4+      , opencv            >= 0.0.0.0+      , primitive         >= 0.6.1+      , template-haskell  >= 2.10+      , transformers      >= 0.4.2+      , vector            >= 0.11++    exposed-modules:+        OpenCV.Extra+        OpenCV.Extra.ArUco+        OpenCV.Extra.Bgsegm+        OpenCV.Extra.XFeatures2d+        OpenCV.Extra.Tracking+        OpenCV.Extra.XPhoto+        OpenCV.Extra.XPhoto.WhiteBalancer++        OpenCV.Extra.Internal.C.Inline+        OpenCV.Extra.Internal.C.Types++    default-extensions:+        BangPatterns+        DataKinds+        FlexibleContexts+        FlexibleInstances+        LambdaCase+        OverloadedStrings+        PackageImports+        PolyKinds+        ScopedTypeVariables+        TupleSections+        TypeFamilies+        TypeOperators++    default-language:   Haskell2010+    pkgconfig-depends:  opencv+    extra-libraries:    stdc++++test-suite doc-images-opencv-extra+    type: exitcode-stdio-1.0+    hs-source-dirs: doc+    main-is: images.hs+    other-modules:+        ExampleExtractor+        Language.Haskell.Meta.Syntax.Translate+    default-language: Haskell2010+    ghc-options: -Wall -fwarn-incomplete-patterns -threaded -funbox-strict-fields -O2 -rtsopts+    cpp-options: -DHAVE_OPENCV_EXTRA+    build-depends:+        base              >= 4.8 && < 5+      , bytestring        >= 0.10.6+      , containers        >= 0.5.6.2+      , data-default      >= 0.7.1.1+      , directory         >= 1.2.2+      , Glob              >= 0.7.5+      , haskell-src-exts  >= 1.18.2+      , JuicyPixels       >= 3.2.8.1+      , linear            >= 1.20.4+      , opencv+      , opencv-extra+      , primitive         >= 0.6.1+      , template-haskell  >= 2.10+      , text              >= 1.2.2.1+      , transformers      >= 0.4.2+      , vector            >= 0.11++    default-extensions:+        BangPatterns+        DataKinds+        LambdaCase+        OverloadedStrings+        PackageImports+        PolyKinds+        ScopedTypeVariables+        TupleSections+        TypeFamilies+        TypeOperators
+ src/OpenCV/Extra.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fno-warn-dodgy-exports #-}++module OpenCV.Extra+  ( module Extra+  ) where++import OpenCV.Extra.ArUco       as Extra+import OpenCV.Extra.Bgsegm      as Extra+import OpenCV.Extra.Tracking    as Extra+import OpenCV.Extra.XFeatures2d as Extra+import OpenCV.Extra.XPhoto      as Extra+import OpenCV.Extra.XPhoto.WhiteBalancer  as Extra
+ src/OpenCV/Extra/ArUco.cpp view
@@ -0,0 +1,253 @@++#include "opencv2/aruco.hpp"++#include "opencv2/aruco/charuco.hpp"++#include "opencv2/core.hpp"++#include "iostream"++#include "aruco.hpp"++using namespace cv;++using namespace cv::aruco;++using namespace std;++extern "C" {+bool inline_c_OpenCV_Extra_ArUco_0_bd5552a5292d57848d9aa88652d764e8c9c42af4(VectorVectorPoint2f * carucoCorners_27_inline_c_0, VectorInt * carucoIds_27_inline_c_1, Mat * imagePtr_inline_c_2, Ptr_CharucoBoard * ccharucoBoard_27_inline_c_3, Mat ** charucoIdsPtr_inline_c_4, Mat ** charucoCornersPtr_inline_c_5) {++        auto & corners = *carucoCorners_27_inline_c_0;+        auto & ids = *carucoIds_27_inline_c_1;+        auto & frame = *imagePtr_inline_c_2;++        auto charucoCorners = new Mat();+        auto charucoIds = new Mat();++        interpolateCornersCharuco(corners,+                                  ids,+                                  frame,+                                  *ccharucoBoard_27_inline_c_3,+                                  *charucoCorners,+                                  *charucoIds);++        *charucoIdsPtr_inline_c_4 = charucoIds;+        *charucoCornersPtr_inline_c_5 = charucoCorners;++        return !charucoIds->empty();+      +}++}++extern "C" {+bool inline_c_OpenCV_Extra_ArUco_1_615bf459fee0dd377cb9469a903293b632daa6ef(Mat * ccornersPtr_27_inline_c_0, Mat * cidsPtr_27_inline_c_1, Ptr_CharucoBoard * ccharucoBoard_27_inline_c_2, Matx33d * ccameraMatrix_27_inline_c_3, Matx51d * cdistCoeffs_27_inline_c_4, Vec3d * rvecPtr_inline_c_5, Vec3d * tvecPtr_inline_c_6) {++          return estimatePoseCharucoBoard(*ccornersPtr_27_inline_c_0,+                                          *cidsPtr_27_inline_c_1,+                                          *ccharucoBoard_27_inline_c_2,+                                          *ccameraMatrix_27_inline_c_3,+                                          *cdistCoeffs_27_inline_c_4,+                                          *rvecPtr_inline_c_5,+                                          *tvecPtr_inline_c_6);+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_ArUco_2_97babe245258febd5fd31065cc0da01bf14d0b96(Mat * imagePtr_inline_c_0, Matx33d * ccameraMatrix_27_inline_c_1, Matx51d * cdistCoeffs_27_inline_c_2, Vec3d * rvecPtr_inline_c_3, Vec3d * tvecPtr_inline_c_4) {++        drawAxis(*imagePtr_inline_c_0,+                 *ccameraMatrix_27_inline_c_1,+                 *cdistCoeffs_27_inline_c_2,+                 *rvecPtr_inline_c_3,+                 *tvecPtr_inline_c_4,+                 1);+      +}++}++extern "C" {+Exception * inline_c_OpenCV_Extra_ArUco_3_189a51fbfeacf22e1e41218ae5f7f2c90ddd95ff(long callCorners_27_inline_c_0, VectorVectorPoint2f ** callCorners_27_inline_c_1, long callIds_27_inline_c_2, VectorInt ** callIds_27_inline_c_3, int cwidth_27_inline_c_4, int cheight_27_inline_c_5, Ptr_CharucoBoard * cboard_27_inline_c_6, Matx33d * cameraMatrixPtr_inline_c_7, Matx51d * distCoeffsPtr_inline_c_8, long callCharucoCorners_27_inline_c_9, Mat ** callCharucoCorners_27_inline_c_10, long callCharucoIds_27_inline_c_11, Mat ** callCharucoIds_27_inline_c_12, Matx33d * cameraMatrixPtr_inline_c_13, Matx51d * distCoeffsPtr_inline_c_14) {++  try+  {   +          vector< vector<Point2f> > allCorners;+          for(auto i = 0; i < callCorners_27_inline_c_0; i++) {+            auto & corners =+              *callCorners_27_inline_c_1[i];++            allCorners.insert(allCorners.end(), corners.begin(), corners.end());+          }++          vector<int> allIds;+          vector<int> counter;+          for(auto i = 0; i < callIds_27_inline_c_2; i++) {+            auto & ids = *callIds_27_inline_c_3[i];+            allIds.insert(allIds.end(), ids.begin(), ids.end());+            counter.push_back(ids.size());+          }++          Size frameSize(cwidth_27_inline_c_4, cheight_27_inline_c_5);++          Ptr<CharucoBoard> charucoBoard = *cboard_27_inline_c_6;+          Ptr<cv::aruco::Board> board = charucoBoard.staticCast<cv::aruco::Board>();++          calibrateCameraAruco(allCorners,+                              allIds,+                              counter,+                              board,+                              frameSize,+                              *cameraMatrixPtr_inline_c_7,+                              *distCoeffsPtr_inline_c_8);++          vector<Mat> allCharucoCorners;+          for(auto i = 0; i < callCharucoCorners_27_inline_c_9; i++) {+            auto & corners = *callCharucoCorners_27_inline_c_10[i];+            allCharucoCorners.push_back(corners);+          }++          vector<Mat> allCharucoIds;+          for(auto i = 0; i < callCharucoIds_27_inline_c_11; i++) {+            auto & ids = *callCharucoIds_27_inline_c_12[i];+            allCharucoIds.push_back(ids);+          }++          Mat perViewErrors;++          calibrateCameraCharuco(allCharucoCorners,+                                allCharucoIds,+                                charucoBoard,+                                frameSize,+                                *cameraMatrixPtr_inline_c_13,+                                *distCoeffsPtr_inline_c_14,+                                noArray(),+                                noArray(),+                                noArray(),+                                noArray(),+                                perViewErrors);+        +    return NULL;+  }+  catch (const cv::Exception & e)+  {+    return new cv::Exception(e);+  }++}++}++extern "C" {+bool inline_c_OpenCV_Extra_ArUco_4_e65bd42c3a4ec69183769f1d3abbc8dc9ac21c29(Mat * imagePtr_inline_c_0, Ptr_Dictionary * cdictionary_27_inline_c_1, VectorVectorPoint2f ** cornersOutPtr_inline_c_2, VectorInt ** idsOutPtr_inline_c_3) {++        auto * corners = new vector< vector<Point2f> >();+        auto * ids = new vector<int>();++        detectMarkers(*imagePtr_inline_c_0,+                      *cdictionary_27_inline_c_1,+                      *corners,+                      *ids);++        *cornersOutPtr_inline_c_2 = corners;+        *idsOutPtr_inline_c_3 = ids;+        return ids->size() > 0;+      +}++}++extern "C" {+void inline_c_OpenCV_Extra_ArUco_5_e103b2a6072343f5d389cb9096058d5b33defc59(Mat * imagePtr_inline_c_0, VectorVectorPoint2f * ccornersPtr_27_inline_c_1, VectorInt * cidsPtr_27_inline_c_2) {++    drawDetectedMarkers(*imagePtr_inline_c_0,+                        *ccornersPtr_27_inline_c_1,+                        *cidsPtr_27_inline_c_2);+  +}++}++extern "C" {+void inline_c_OpenCV_Extra_ArUco_6_37feba18e64b5c7115da15bd570386759895c7a2(Mat * imagePtr_inline_c_0, Mat * ccornersPtr_27_inline_c_1, Mat * cidsPtr_27_inline_c_2) {++    drawDetectedCornersCharuco(*imagePtr_inline_c_0,+                               *ccornersPtr_27_inline_c_1,+                               *cidsPtr_27_inline_c_2);+  +}++}++extern "C" {+Ptr_CharucoBoard * inline_c_OpenCV_Extra_ArUco_7_30fe6411bb487a62b7005f44d34773c8ce51511a(int csquaresX_27_inline_c_0, int csquaresY_27_inline_c_1, double csquareLength_27_inline_c_2, double cmarkerLength_27_inline_c_3, Ptr_Dictionary * cdictionary_27_inline_c_4) {++    return+      new Ptr<CharucoBoard>(CharucoBoard::create(csquaresX_27_inline_c_0,+                                                  csquaresY_27_inline_c_1,+                                                  csquareLength_27_inline_c_2,+                                                  cmarkerLength_27_inline_c_3,+                                                  *cdictionary_27_inline_c_4));+  +}++}++extern "C" {+int inline_c_OpenCV_Extra_ArUco_8_7ede7ba79559132935c117a79d32f29421fb5af7() {+return ( DICT_7X7_1000 );+}++}++extern "C" {+Ptr_Dictionary * inline_c_OpenCV_Extra_ArUco_9_e043f809501b147d4172ef13477613254e4c1009(int cname_27_inline_c_0) {++    return+      new Ptr<Dictionary>(getPredefinedDictionary(cname_27_inline_c_0));+  +}++}++extern "C" {+void inline_c_OpenCV_Extra_ArUco_10_1660ae62bf4004a4267ef43424eaa8c162afdea4(Mat * dstPtr_inline_c_0, Ptr_CharucoBoard * cboard_27_inline_c_1, int32_t w_inline_c_2, int32_t h_inline_c_3) {++          Mat & board = * dstPtr_inline_c_0;+          Ptr<CharucoBoard> & charucoBoard = *cboard_27_inline_c_1;+          charucoBoard->draw(cv::Size(w_inline_c_2, h_inline_c_3), board);+        +}++}++extern "C" {+void inline_c_OpenCV_Extra_ArUco_11_26c5e19bfe16c79e7bf651cb378e30fd432cd99b(VectorVectorPoint2f * ptr_inline_c_0) {+ delete ptr_inline_c_0; +}++}++extern "C" {+void inline_c_OpenCV_Extra_ArUco_12_86f8b8c429a70629e07c27698801886a0484dfef(VectorInt * ptr_inline_c_0) {+ delete ptr_inline_c_0; +}++}++extern "C" {+void inline_c_OpenCV_Extra_ArUco_13_a3285f65e0699baa139781baf5bb261b6fa6aa9d(Ptr_CharucoBoard * ptr_inline_c_0) {+ delete ptr_inline_c_0; +}++}++extern "C" {+void inline_c_OpenCV_Extra_ArUco_14_35320368ab79414e41da235a390ce49c04ab0a5c(Ptr_Dictionary * ptr_inline_c_0) {+ delete ptr_inline_c_0; +}++}
+ src/OpenCV/Extra/ArUco.hs view
@@ -0,0 +1,539 @@+{-# LANGUAGE DataKinds, QuasiQuotes, RecordWildCards, TemplateHaskell #-}++module OpenCV.Extra.ArUco+  ( -- * ArUco markers+    -- ** Dictionaries+    Dictionary+  , PredefinedDictionaryName(..)+  , getPredefinedDictionary++    -- ** Detecting markers+  , detectMarkers+  , ArUcoMarkers++    -- ** Visualising ArUco markers+  , drawDetectedMarkers++    -- * ChArUco markers+  , ChArUcoBoard+  , createChArUcoBoard+  , drawChArUcoBoard++    -- ** Detecting markers+  , interpolateChArUcoMarkers+  , estimatePoseChArUcoBoard++    -- ** Camera calibration+  , calibrateCameraFromFrames++    -- ** Debugging and visualiation utilities+  , drawDetectedCornersCharuco+  , drawEstimatedPose+  ) where++import "opencv" OpenCV.Internal.Exception+import "base" Control.Monad (guard)+import "primitive" Control.Monad.Primitive+import "base" Data.Monoid ((<>))+import "base" Data.Word ( Word8 )+import qualified "vector" Data.Vector.Storable as SV+import "base" Foreign.C+import "base" Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import "base" Foreign.Marshal.Alloc+import "base" Foreign.Ptr+import "base" Foreign.Storable (peek)+import qualified "inline-c" Language.C.Inline as C+import qualified "inline-c-cpp" Language.C.Inline.Cpp as C+import qualified "inline-c" Language.C.Inline.Unsafe as CU+import "linear" Linear+import "opencv" OpenCV+import "opencv" OpenCV.Core.Types.Vec (Vec3d)+import "this" OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx )+import "this" OpenCV.Extra.Internal.C.Types+import "opencv" OpenCV.Internal+import "opencv" OpenCV.Internal.C.Types+import "opencv" OpenCV.Internal.Core.Types.Mat+import "base" System.IO.Unsafe++--------------------------------------------------------------------------------+C.context openCvExtraCtx++C.include "opencv2/aruco.hpp"+C.include "opencv2/aruco/charuco.hpp"+C.include "opencv2/core.hpp"+C.include "iostream"+C.include "aruco.hpp"++C.using "namespace cv"+C.using "namespace cv::aruco"+C.using "namespace std"++{-| A @Dictionary@ describes the possible QR codes used for ArUco markers. Use+'getPredefinedDictionary' to lookup known dictionaries.+-}+newtype Dictionary = Dictionary+  { unDictionary :: ForeignPtr C'Ptr'Dictionary+  }+++type instance C Dictionary = C'Ptr'Dictionary+++instance FromPtr Dictionary where+  fromPtr =+    objFromPtr Dictionary $ \ptr ->+      [CU.block| void { delete $(Ptr_Dictionary * ptr); }|]+++instance WithPtr Dictionary where+  withPtr = withForeignPtr . unDictionary++++{-| A ChArUco board is used to perform camera calibration from ArUco markers+overlaid on a chess board of known size. Use 'createChArUcoBoard' to create+values of this type.+-}+newtype ChArUcoBoard = ChArUcoBoard+  { unChArUcoBoard :: ForeignPtr C'Ptr'CharucoBoard+  }+++type instance C ChArUcoBoard = C'Ptr'CharucoBoard+++instance FromPtr ChArUcoBoard where+  fromPtr =+    objFromPtr ChArUcoBoard $ \ptr ->+      [CU.block| void { delete $(Ptr_CharucoBoard * ptr); }|]+++instance WithPtr ChArUcoBoard where+  withPtr = withForeignPtr . unChArUcoBoard+++newtype Vector'Int = Vector'Int+  { unVectorInt :: ForeignPtr C'Vector'Int+  }+++type instance C Vector'Int = C'Vector'Int+++instance FromPtr Vector'Int where+  fromPtr =+    objFromPtr Vector'Int $ \ptr ->+      [CU.block| void { delete $(VectorInt * ptr); }|]+++instance WithPtr Vector'Int where+  withPtr = withForeignPtr . unVectorInt+++newtype Vector'Vector'Point2f = Vector'Vector'Point2f+  { unVectorVectorPoint2f :: ForeignPtr C'Vector'Vector'Point2f+  }+++type instance C Vector'Vector'Point2f = C'Vector'Vector'Point2f+++instance FromPtr Vector'Vector'Point2f where+  fromPtr =+    objFromPtr Vector'Vector'Point2f $ \ptr ->+      [CU.block| void { delete $(VectorVectorPoint2f * ptr); }|]+++instance WithPtr Vector'Vector'Point2f where+  withPtr = withForeignPtr . unVectorVectorPoint2f+++{-| An encoding of the result of 'interpolateChArUcoMarkers'.+-}+data ChArUcoMarkers = ChArUcoMarkers+    { charucoIds :: Mat 'D 'D 'D+    , charucoCorners :: Mat 'D 'D 'D+    }+++{-| Given an image and the detected ArUco markers in that image, attempt to+perform ChAruco calibration.+-}+interpolateChArUcoMarkers+  :: ChArUcoBoard+     -- ^ The ChArUco board to interpolate markers for.+  -> Mat ('S '[ h, w]) channels depth+     -- ^ A view of a ChArUco board.+  -> ArUcoMarkers+     -- ^ The ArUco markers detected in the same image.+  -> Maybe ChArUcoMarkers+interpolateChArUcoMarkers charucoBoard image ArUcoMarkers {..} =+  unsafePerformIO $+  alloca $ \charucoCornersPtr ->+  alloca $ \charucoIdsPtr ->+  withPtr arucoCorners $ \c'arucoCorners ->+  withPtr arucoIds $ \c'arucoIds ->+  withPtr image $ \imagePtr ->+  withPtr charucoBoard $ \c'charucoBoard -> do+    success <-+      [C.block| bool {+        auto & corners = *$(VectorVectorPoint2f * c'arucoCorners);+        auto & ids = *$(VectorInt * c'arucoIds);+        auto & frame = *$(Mat * imagePtr);++        auto charucoCorners = new Mat();+        auto charucoIds = new Mat();++        interpolateCornersCharuco(corners,+                                  ids,+                                  frame,+                                  *$(Ptr_CharucoBoard * c'charucoBoard),+                                  *charucoCorners,+                                  *charucoIds);++        *$(Mat * * charucoIdsPtr) = charucoIds;+        *$(Mat * * charucoCornersPtr) = charucoCorners;++        return !charucoIds->empty();+      }|]+    ids <- fromPtr (peek charucoIdsPtr)+    corners <- fromPtr (peek charucoCornersPtr)+    return (ChArUcoMarkers ids corners <$ guard (success /= 0))+++{- | Given an image, the ChArUco markers in that image, and the camera+calibration, estimate the pose of the board.+-}+estimatePoseChArUcoBoard+  :: ChArUcoBoard+     -- ^ The ChArUco board parameters.+  -> ChArUcoMarkers+     -- ^ Detected ChArUco markers.+  -> (Matx33d, Matx51d)+     -- ^ A pair of the camera intrinsic parameters and a 5 dimensional vector+     -- of distortion coefficients.+  -> Maybe (Vec3d, Vec3d)+estimatePoseChArUcoBoard charucoBoard ChArUcoMarkers {..} (cameraMatrix, distCoeffs) =+  unsafePerformIO $ do+    rvec <- toVecIO (V3 0.0 0.0 0.0)+    tvec <- toVecIO (V3 0.0 0.0 0.0)+    withPtr cameraMatrix $ \c'cameraMatrix ->+      withPtr distCoeffs $ \c'distCoeffs ->+      withPtr charucoIds $ \c'idsPtr ->+      withPtr charucoBoard $ \c'charucoBoard ->+      withPtr rvec $ \rvecPtr ->+      withPtr tvec $ \tvecPtr ->+      withPtr charucoCorners $ \c'cornersPtr -> do+        success <- [C.block| bool {+          return estimatePoseCharucoBoard(*$(Mat * c'cornersPtr),+                                          *$(Mat * c'idsPtr),+                                          *$(Ptr_CharucoBoard * c'charucoBoard),+                                          *$(Matx33d * c'cameraMatrix),+                                          *$(Matx51d * c'distCoeffs),+                                          *$(Vec3d * rvecPtr),+                                          *$(Vec3d * tvecPtr));+          }|]+        return (( fromVec rvec , fromVec tvec) <$ guard (success /= 0))+++{- | Given an estimated pose for a board, draw the axis over an image.+-}++drawEstimatedPose+  :: PrimMonad m+  => Matx33d+     -- ^ The matrix of intrinsic parameters of a camera.+  -> Matx51d+     -- ^ A 5-dimensional vector of distortion coefficients.+  -> (Vec3d, Vec3d)+     -- ^ The transposition and rotation matrices from local to camera space,+     -- respectively.+  -> Mut (Mat ('S '[ h, w]) channels depth) (PrimState m)+     -- ^ An image to draw the axis onto.+  -> m ()+drawEstimatedPose cameraMatrix distCoeffs (rvec, tvec) image =+  unsafePrimToPrim $ do+    withPtr image $ \imagePtr ->+      withPtr cameraMatrix $ \c'cameraMatrix ->+      withPtr distCoeffs $ \c'distCoeffs ->+      withPtr rvec $ \rvecPtr ->+      withPtr tvec $ \tvecPtr ->+      [C.block| void {+        drawAxis(*$(Mat * imagePtr),+                 *$(Matx33d * c'cameraMatrix),+                 *$(Matx51d * c'distCoeffs),+                 *$(Vec3d * rvecPtr),+                 *$(Vec3d * tvecPtr),+                 1);+      }|]+++{- | Given a list of ChArUco calibration results, combine all results into+camera calibration.+-}+calibrateCameraFromFrames+    :: ChArUcoBoard+    -> Int+    -> Int+    -> [(ArUcoMarkers, ChArUcoMarkers)]+    -> CvExcept (Matx33d, Matx51d)+calibrateCameraFromFrames board width height frames =+  unsafeWrapException $ do+    cameraMatrix <- newMatx33d 0 0 0 0 0 0 0 0 0+    distCoeffs <- newMatx51d 0 0 0 0 0+    handleCvException (pure (cameraMatrix, distCoeffs)) $+      withPtr cameraMatrix $ \cameraMatrixPtr ->+      withPtr distCoeffs $ \distCoeffsPtr ->+      withPtr board $ \c'board ->+      withPtrs (map (arucoIds . fst) frames) $ \c'allIds ->+      withPtrs (map (arucoCorners . fst) frames) $ \c'allCorners ->+      withPtrs (fmap (charucoCorners . snd) frames) $ \c'allCharucoCorners ->+      withPtrs (fmap (charucoIds . snd) frames) $ \c'allCharucoIds -> do++        [cvExcept|+          vector< vector<Point2f> > allCorners;+          for(auto i = 0; i < $vec-len:c'allCorners; i++) {+            auto & corners =+              *$vec-ptr:(VectorVectorPoint2f * * c'allCorners)[i];++            allCorners.insert(allCorners.end(), corners.begin(), corners.end());+          }++          vector<int> allIds;+          vector<int> counter;+          for(auto i = 0; i < $vec-len:c'allIds; i++) {+            auto & ids = *$vec-ptr:(VectorInt * * c'allIds)[i];+            allIds.insert(allIds.end(), ids.begin(), ids.end());+            counter.push_back(ids.size());+          }++          Size frameSize($(int c'width), $(int c'height));++          Ptr<CharucoBoard> charucoBoard = *$(Ptr_CharucoBoard * c'board);+          Ptr<cv::aruco::Board> board = charucoBoard.staticCast<cv::aruco::Board>();++          calibrateCameraAruco(allCorners,+                              allIds,+                              counter,+                              board,+                              frameSize,+                              *$(Matx33d * cameraMatrixPtr),+                              *$(Matx51d * distCoeffsPtr));++          vector<Mat> allCharucoCorners;+          for(auto i = 0; i < $vec-len:c'allCharucoCorners; i++) {+            auto & corners = *$vec-ptr:(Mat * * c'allCharucoCorners)[i];+            allCharucoCorners.push_back(corners);+          }++          vector<Mat> allCharucoIds;+          for(auto i = 0; i < $vec-len:c'allCharucoIds; i++) {+            auto & ids = *$vec-ptr:(Mat * * c'allCharucoIds)[i];+            allCharucoIds.push_back(ids);+          }++          Mat perViewErrors;++          calibrateCameraCharuco(allCharucoCorners,+                                allCharucoIds,+                                charucoBoard,+                                frameSize,+                                *$(Matx33d * cameraMatrixPtr),+                                *$(Matx51d * distCoeffsPtr),+                                noArray(),+                                noArray(),+                                noArray(),+                                noArray(),+                                perViewErrors);+        |]+  where+    c'width = fromIntegral width+    c'height = fromIntegral height+++{- | The result of calling 'detectMarkers' on an image.+-}+data ArUcoMarkers = ArUcoMarkers+    { arucoCorners :: Vector'Vector'Point2f+    , arucoIds :: Vector'Int+    }+++{- | Perform ArUco marker detection.+-}+detectMarkers+  :: Dictionary+     -- ^ A dictionary describing ArUco markers.+  -> Mat ('S '[ h, w]) channels depth+     -- ^ The matrix to detect markers from.+  -> Maybe ArUcoMarkers+detectMarkers dictionary image =+  unsafePerformIO $+  withPtr image $ \imagePtr ->+  withPtr dictionary $ \c'dictionary ->+  alloca $ \cornersOutPtr ->+  alloca $ \idsOutPtr -> do+    success <- fmap (/= 0) $+      [C.block| bool {+        auto * corners = new vector< vector<Point2f> >();+        auto * ids = new vector<int>();++        detectMarkers(*$(Mat * imagePtr),+                      *$(Ptr_Dictionary * c'dictionary),+                      *corners,+                      *ids);++        *$(VectorVectorPoint2f * * cornersOutPtr) = corners;+        *$(VectorInt * * idsOutPtr) = ids;+        return ids->size() > 0;+      }|]+    corners <- fromPtr (peek cornersOutPtr)+    ids <- fromPtr (peek idsOutPtr)+    return (ArUcoMarkers corners ids <$ guard success)+++{- | Given a frame, overlay the result of ArUco marker detection.+-}+drawDetectedMarkers+  :: PrimMonad m+  => Mut (Mat ('S [h, w]) channels depth) (PrimState m)+    -- ^ The image to draw detected markers onto. Usually the same image you+    -- detected markers from.+  -> ArUcoMarkers+    -- ^ The ArUco markers to draw.+  -> m ()+drawDetectedMarkers image ArUcoMarkers{..} =+  unsafePrimToPrim $+  withPtr image $ \imagePtr ->+  withPtr arucoCorners $ \c'cornersPtr ->+  withPtr arucoIds $ \c'idsPtr ->+  [C.block| void {+    drawDetectedMarkers(*$(Mat * imagePtr),+                        *$(VectorVectorPoint2f * c'cornersPtr),+                        *$(VectorInt * c'idsPtr));+  }|]+++{- | Given a frame, overlay the result of ChArUco marker detection.+-}+drawDetectedCornersCharuco+  :: PrimMonad m+  => Mut (Mat ('S '[ h, w]) channels depth) (PrimState m)+    -- ^ The image to draw detected corners.+  -> ChArUcoMarkers+    -- ^ The ChArUco markers corners to draw.+  -> m ()+drawDetectedCornersCharuco image ChArUcoMarkers{..} =+  unsafePrimToPrim $+  withPtr image $ \imagePtr ->+  withPtr charucoIds $ \c'idsPtr ->+  withPtr charucoCorners $ \c'cornersPtr ->+  [C.block| void {+    drawDetectedCornersCharuco(*$(Mat * imagePtr),+                               *$(Mat * c'cornersPtr),+                               *$(Mat * c'idsPtr));+  }|]+++{-| Create a new ChArUco board configuration.+-}+createChArUcoBoard+  :: Int+    -- ^ The amount of squares along the X-axis.+  -> Int+    -- ^ The amount of squares along the Y-axis.+  -> Double+    -- ^ The length of a side of a chess-board square.+  -> Double+    -- ^ The length of a marker's side within a chess-board square.+  -> Dictionary+    -- ^ The dictionary of ArUco markers.+  -> ChArUcoBoard+createChArUcoBoard squaresX squaresY squareLength markerLength dictionary =+  unsafePerformIO $+  withPtr dictionary $ \c'dictionary ->+  fromPtr $+  [C.block| Ptr_CharucoBoard * {+    return+      new Ptr<CharucoBoard>(CharucoBoard::create($(int c'squaresX),+                                                  $(int c'squaresY),+                                                  $(double c'squareLength),+                                                  $(double c'markerLength),+                                                  *$(Ptr_Dictionary * c'dictionary)));+  }|]+  where c'squaresX = fromIntegral squaresX+        c'squaresY = fromIntegral squaresY+        c'squareLength = realToFrac squareLength+        c'markerLength = realToFrac markerLength+++{-| The set of predefined ArUco dictionaries known to OpenCV.+-}+data PredefinedDictionaryName = DICT_7X7_1000+++{-| Turn a predefined dictionary name into a ArUco dictionary.+-}+getPredefinedDictionary :: PredefinedDictionaryName -> Dictionary+getPredefinedDictionary name =+  unsafePerformIO $+  fromPtr $+  [C.block| Ptr_Dictionary * {+    return+      new Ptr<Dictionary>(getPredefinedDictionary($(int c'name)));+  }|]+  where+    c'name =+        case name of+            DICT_7X7_1000 -> [C.pure| int { DICT_7X7_1000 } |]+++{-| Draw a ChArUco board, ready to be printed and used for calibration/marke+detection.++Example:++@+drawChArUcoBoardImg+    :: forall (w :: Nat) (h :: Nat)+     . (w ~ 500, h ~ 500)+    => Mat ('S '[ 'S h, 'S w]) ('S 1) ('S Word8)+drawChArUcoBoardImg =+    drawChArUcoBoard charucoBoard (Proxy :: Proxy w) (Proxy :: Proxy h)+  where+    charucoBoard :: ChArUcoBoard+    charucoBoard = createChArUcoBoard 10 10 20 5 dictionary++    dictionary :: Dictionary+    dictionary = getPredefinedDictionary DICT_7X7_1000+@++<<doc/generated/examples/drawChArUcoBoardImg.png drawChArUcoBoardImg>>+-}+drawChArUcoBoard+    :: (ToInt32 w, ToInt32 h)+    => ChArUcoBoard+    -> w -- ^ width+    -> h -- ^ height+    -> Mat ('S '[DSNat h, DSNat w]) ('S 1) ('S Word8)+drawChArUcoBoard charucoBoard width height = unsafePerformIO $ do+    dst <- newEmptyMat+    withPtr charucoBoard $ \c'board ->+      withPtr dst $ \dstPtr ->+        [C.block| void {+          Mat & board = * $(Mat * dstPtr);+          Ptr<CharucoBoard> & charucoBoard = *$(Ptr_CharucoBoard * c'board);+          charucoBoard->draw(cv::Size($(int32_t w), $(int32_t h)), board);+        }|]+    pure (unsafeCoerceMat dst)+  where+    w = toInt32 width+    h = toInt32 height++--------------------------------------------------------------------------------+withPtrs+    :: WithPtr a+    => [a] -> (SV.Vector (Ptr (C a)) -> IO b) -> IO b+withPtrs [] io = io mempty+withPtrs (x:xs) io =+    withPtr x $ \ptr -> withPtrs xs $ \sv -> io (SV.singleton ptr <> sv)
+ src/OpenCV/Extra/Bgsegm.cpp view
@@ -0,0 +1,152 @@++#include "opencv2/core.hpp"++#include "opencv2/video.hpp"++#include "opencv2/bgsegm.hpp"++#include "bgsegm.hpp"++using namespace cv;++extern "C" {+Ptr_BackgroundSubtractorGMG * inline_c_OpenCV_Extra_Bgsegm_0_4cad742a94b1e290a850aaa42019ad34d95bdaea(int32_t cinitializationFrames_27_inline_c_0, double cdecisionThreshold_27_inline_c_1) {++      cv::Ptr<cv::bgsegm::BackgroundSubtractorGMG> gmgPtr =+        cv::bgsegm::createBackgroundSubtractorGMG+        ( cinitializationFrames_27_inline_c_0+        , cdecisionThreshold_27_inline_c_1+        );+      return new cv::Ptr<cv::bgsegm::BackgroundSubtractorGMG>(gmgPtr);+    +}++}++extern "C" {+Ptr_BackgroundSubtractorMOG * inline_c_OpenCV_Extra_Bgsegm_1_546b1da302dc708e3c4ddc702cd20cd72c8559b7(int32_t chistory_27_inline_c_0, int32_t cnumGausianMix_27_inline_c_1, double cbackgroundRatio_27_inline_c_2, double cnoise_27_inline_c_3) {++      cv::Ptr<cv::bgsegm::BackgroundSubtractorMOG> mog2Ptr =+        cv::bgsegm::createBackgroundSubtractorMOG+        ( chistory_27_inline_c_0+        , cnumGausianMix_27_inline_c_1+        , cbackgroundRatio_27_inline_c_2+        , cnoise_27_inline_c_3+        );+      return new cv::Ptr<cv::bgsegm::BackgroundSubtractorMOG>(mog2Ptr);+    +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_2_48cb6527f13d74249e3e1955e1f02f2011cee17a(Ptr_BackgroundSubtractorMOG * mogPtr_inline_c_0, Mat * imgPtr_inline_c_1, Mat * fgMaskPtr_inline_c_2, double clearningRate_27_inline_c_3) {++              cv::bgsegm::BackgroundSubtractorMOG * mog = *mogPtr_inline_c_0;+              mog->apply+              ( *imgPtr_inline_c_1+              , *fgMaskPtr_inline_c_2+              , clearningRate_27_inline_c_3+              );+            +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_3_cbba6f9c69ed88c9000d7dd2775444c61982293b(Ptr_BackgroundSubtractorMOG * mogPtr_inline_c_0, Mat * imgPtr_inline_c_1) {++              cv::bgsegm::BackgroundSubtractorMOG * mog = *mogPtr_inline_c_0;+              mog->getBackgroundImage(*imgPtr_inline_c_1);+            +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_4_10eb3318bc5306fecb2320251a25b410f89c160c(Ptr_BackgroundSubtractorGMG * gmgPtr_inline_c_0, Mat * imgPtr_inline_c_1, Mat * fgMaskPtr_inline_c_2, double clearningRate_27_inline_c_3) {++              cv::bgsegm::BackgroundSubtractorGMG * gmg = *gmgPtr_inline_c_0;+              gmg->apply+              ( *imgPtr_inline_c_1+              , *fgMaskPtr_inline_c_2+              , clearningRate_27_inline_c_3+              );+            +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_5_c960b2287d0171e2659a7072d345ffaee412eede(Ptr_BackgroundSubtractorGMG * gmgPtr_inline_c_0, Mat * imgPtr_inline_c_1) {++              cv::bgsegm::BackgroundSubtractorGMG * gmg = *gmgPtr_inline_c_0;+              gmg->getBackgroundImage(*imgPtr_inline_c_1);+            +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_6_dc2609be8bceffb0014796e658ebe95c73d04536(Ptr_BackgroundSubtractorMOG * mog2Ptr_inline_c_0) {++              cv::bgsegm::BackgroundSubtractorMOG * mog2 = *mog2Ptr_inline_c_0;+              mog2->clear();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_7_c26d79c05f7057ecd9dee235ac9dca2d2d89a9ca(Ptr_BackgroundSubtractorMOG * mog2Ptr_inline_c_0, bool * emptyPtr_inline_c_1) {++              cv::bgsegm::BackgroundSubtractorMOG * mog2 = *mog2Ptr_inline_c_0;+              *emptyPtr_inline_c_1 = mog2->empty();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_8_030580224eb15175e4895cb174cbdf0348b871e6(Ptr_BackgroundSubtractorGMG * knnPtr_inline_c_0) {++              cv::bgsegm::BackgroundSubtractorGMG * knn = *knnPtr_inline_c_0;+              knn->clear();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_9_6f8b16403e735ccf26882c73dc3e6bdcd6dfac7b(Ptr_BackgroundSubtractorGMG * gmgPtr_inline_c_0, bool * emptyPtr_inline_c_1) {++              cv::bgsegm::BackgroundSubtractorGMG * gmg = *gmgPtr_inline_c_0;+              *emptyPtr_inline_c_1 = gmg->empty();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_10_f2dd1537a7c6649e59499980d21e3efce8309c8a(Ptr_BackgroundSubtractorMOG * ptr_inline_c_0) {++                  cv::Ptr<cv::bgsegm::BackgroundSubtractorMOG> * mog2_ptr_ptr =+                    ptr_inline_c_0;+                  mog2_ptr_ptr->release();+                  delete mog2_ptr_ptr;+                +}++}++extern "C" {+void inline_c_OpenCV_Extra_Bgsegm_11_453105bb3402b7542dceb42b6f82b21e8c2340b9(Ptr_BackgroundSubtractorGMG * ptr_inline_c_0) {++                  cv::Ptr<cv::bgsegm::BackgroundSubtractorGMG> * knn_ptr_ptr =+                    ptr_inline_c_0;+                  knn_ptr_ptr->release();+                  delete knn_ptr_ptr;+                +}++}
+ src/OpenCV/Extra/Bgsegm.hs view
@@ -0,0 +1,229 @@+{-# language TemplateHaskell #-}+{-# language QuasiQuotes #-}++{- |+Two additional background subtraction algorithms. These algorithms do+not support `getBackgroundImage` (and probably never will).+-}+module OpenCV.Extra.Bgsegm+    ( -- * Background subtractors+      BackgroundSubtractorGMG+    , BackgroundSubtractorMOG++    , newBackgroundSubtractorGMG+    , newBackgroundSubtractorMOG+    ) where++import "base" Control.Exception ( mask_ )+import "base" Data.Int+import "base" Data.Maybe+import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )+import "base" Foreign.Marshal.Alloc ( alloca )+import "base" Foreign.Marshal.Utils ( toBool )+import "base" Foreign.Storable ( peek )+import qualified "inline-c" Language.C.Inline as C+import qualified "inline-c" Language.C.Inline.Unsafe as CU+import qualified "inline-c-cpp" Language.C.Inline.Cpp as C+import "opencv" OpenCV.Core.Types+import "opencv" OpenCV.Internal+import "opencv" OpenCV.Internal.Core.Types.Mat+import "opencv" OpenCV.Internal.C.Types+import "opencv" OpenCV.Video.MotionAnalysis ( BackgroundSubtractor(..) )+import "primitive" Control.Monad.Primitive+import "this" OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx )+import "this" OpenCV.Extra.Internal.C.Types++--------------------------------------------------------------------------------++C.context openCvExtraCtx++C.include "opencv2/core.hpp"+C.include "opencv2/video.hpp"+C.include "opencv2/bgsegm.hpp"+C.include "bgsegm.hpp"++C.using "namespace cv"++--------------------------------------------------------------------------------++newtype BackgroundSubtractorGMG s+      = BackgroundSubtractorGMG+        { unBackgroundSubtractorGMG :: ForeignPtr C'Ptr_BackgroundSubtractorGMG }++newtype BackgroundSubtractorMOG s+      = BackgroundSubtractorMOG+        { unBackgroundSubtractorMOG :: ForeignPtr C'Ptr_BackgroundSubtractorMOG }++type instance C (BackgroundSubtractorGMG  s) = C'Ptr_BackgroundSubtractorGMG+type instance C (BackgroundSubtractorMOG s) = C'Ptr_BackgroundSubtractorMOG++instance WithPtr (BackgroundSubtractorGMG s) where+    withPtr = withForeignPtr . unBackgroundSubtractorGMG++instance WithPtr (BackgroundSubtractorMOG s) where+    withPtr = withForeignPtr . unBackgroundSubtractorMOG++instance FromPtr (BackgroundSubtractorGMG s) where+    fromPtr = objFromPtr BackgroundSubtractorGMG $ \ptr ->+                [CU.block| void {+                  cv::Ptr<cv::bgsegm::BackgroundSubtractorGMG> * knn_ptr_ptr =+                    $(Ptr_BackgroundSubtractorGMG * ptr);+                  knn_ptr_ptr->release();+                  delete knn_ptr_ptr;+                }|]++instance FromPtr (BackgroundSubtractorMOG s) where+    fromPtr = objFromPtr BackgroundSubtractorMOG $ \ptr ->+                [CU.block| void {+                  cv::Ptr<cv::bgsegm::BackgroundSubtractorMOG> * mog2_ptr_ptr =+                    $(Ptr_BackgroundSubtractorMOG * ptr);+                  mog2_ptr_ptr->release();+                  delete mog2_ptr_ptr;+                }|]++--------------------------------------------------------------------------------++newBackgroundSubtractorGMG+    :: (PrimMonad m)+    => Maybe Int32+       -- ^ Number of frames used to initialize the background models.+    -> Maybe Double+       -- ^ Threshold value, above which it is marked foreground, else background.+    -> m (BackgroundSubtractorGMG (PrimState m))+newBackgroundSubtractorGMG mbInitializationFrames mbDecisionThreshold =+  unsafePrimToPrim $ fromPtr+    [CU.block|Ptr_BackgroundSubtractorGMG * {+      cv::Ptr<cv::bgsegm::BackgroundSubtractorGMG> gmgPtr =+        cv::bgsegm::createBackgroundSubtractorGMG+        ( $(int32_t c'initializationFrames)+        , $(double  c'decisionThreshold   )+        );+      return new cv::Ptr<cv::bgsegm::BackgroundSubtractorGMG>(gmgPtr);+    }|]+  where+    c'initializationFrames = fromMaybe 120 mbInitializationFrames+    c'decisionThreshold    = maybe 0.8 realToFrac mbDecisionThreshold++newBackgroundSubtractorMOG+    :: (PrimMonad m)+    => Maybe Int32+       -- ^ Length of the history.+    -> Maybe Int32+       -- ^ Number of Gaussian mixtures.+    -> Maybe Double+       -- ^ Background ratio.+    -> Maybe Double+       -- ^ Noise strength (standard deviation of the brightness or each+       --  color channel). 0 means some automatic value.+    -> m (BackgroundSubtractorMOG (PrimState m))+newBackgroundSubtractorMOG mbHistory mbNumGausianMix mbBackgroundRatio mbNoise+  = unsafePrimToPrim $ fromPtr+    [CU.block|Ptr_BackgroundSubtractorMOG * {+      cv::Ptr<cv::bgsegm::BackgroundSubtractorMOG> mog2Ptr =+        cv::bgsegm::createBackgroundSubtractorMOG+        ( $(int32_t c'history       )+        , $(int32_t c'numGausianMix )+        , $(double  c'backgroundRatio )+        , $(double  c'noise )+        );+      return new cv::Ptr<cv::bgsegm::BackgroundSubtractorMOG>(mog2Ptr);+    }|]+  where+    c'history          = fromMaybe 200 mbHistory+    c'numGausianMix    = fromMaybe 5   mbNumGausianMix+    c'backgroundRatio  = maybe 0.7 realToFrac mbBackgroundRatio+    c'noise            = maybe 0   realToFrac mbNoise++--------------------------------------------------------------------------------++instance Algorithm BackgroundSubtractorGMG where+    algorithmClearState knn = unsafePrimToPrim $+        withPtr knn $ \knnPtr ->+          [C.block|void {+              cv::bgsegm::BackgroundSubtractorGMG * knn = *$(Ptr_BackgroundSubtractorGMG * knnPtr);+              knn->clear();+          }|]++    algorithmIsEmpty gmg = unsafePrimToPrim $+        withPtr gmg $ \gmgPtr ->+        alloca $ \emptyPtr -> do+          [C.block|void {+              cv::bgsegm::BackgroundSubtractorGMG * gmg = *$(Ptr_BackgroundSubtractorGMG * gmgPtr);+              *$(bool * emptyPtr) = gmg->empty();+          }|]+          toBool <$> peek emptyPtr++instance Algorithm BackgroundSubtractorMOG where+    algorithmClearState mog2 = unsafePrimToPrim $+        withPtr mog2 $ \mog2Ptr ->+          [C.block|void {+              cv::bgsegm::BackgroundSubtractorMOG * mog2 = *$(Ptr_BackgroundSubtractorMOG * mog2Ptr);+              mog2->clear();+          }|]++    algorithmIsEmpty mog2 = unsafePrimToPrim $+        withPtr mog2 $ \mog2Ptr ->+        alloca $ \emptyPtr -> do+          [C.block|void {+              cv::bgsegm::BackgroundSubtractorMOG * mog2 = *$(Ptr_BackgroundSubtractorMOG * mog2Ptr);+              *$(bool * emptyPtr) = mog2->empty();+          }|]+          toBool <$> peek emptyPtr++instance BackgroundSubtractor BackgroundSubtractorGMG where+    bgSubApply gmg learningRate img = unsafePrimToPrim $ do+        fgMask <- newEmptyMat+        withPtr gmg $ \gmgPtr ->+          withPtr img $ \imgPtr ->+          withPtr fgMask $ \fgMaskPtr -> mask_ $ do+            [C.block| void {+              cv::bgsegm::BackgroundSubtractorGMG * gmg = *$(Ptr_BackgroundSubtractorGMG * gmgPtr);+              gmg->apply+              ( *$(Mat * imgPtr)+              , *$(Mat * fgMaskPtr)+              , $(double c'learningRate)+              );+            }|]+        pure $ unsafeCoerceMat fgMask+      where+        c'learningRate = realToFrac learningRate++    -- not supported by the backend+    getBackgroundImage gmg = unsafePrimToPrim $ do+        img <- newEmptyMat+        withPtr gmg $ \gmgPtr ->+          withPtr img $ \imgPtr -> mask_ $ do+            [C.block| void {+              cv::bgsegm::BackgroundSubtractorGMG * gmg = *$(Ptr_BackgroundSubtractorGMG * gmgPtr);+              gmg->getBackgroundImage(*$(Mat * imgPtr));+            }|]+            pure $ unsafeCoerceMat img++instance BackgroundSubtractor BackgroundSubtractorMOG where+    bgSubApply mog learningRate img = unsafePrimToPrim $ do+        fgMask <- newEmptyMat+        withPtr mog $ \mogPtr ->+          withPtr img $ \imgPtr ->+          withPtr fgMask $ \fgMaskPtr -> mask_ $ do+            [C.block| void {+              cv::bgsegm::BackgroundSubtractorMOG * mog = *$(Ptr_BackgroundSubtractorMOG * mogPtr);+              mog->apply+              ( *$(Mat * imgPtr)+              , *$(Mat * fgMaskPtr)+              , $(double c'learningRate)+              );+            }|]+        pure $ unsafeCoerceMat fgMask+      where+        c'learningRate = realToFrac learningRate++    -- not supported by the backend+    getBackgroundImage mog = unsafePrimToPrim $ do+        img <- newEmptyMat+        withPtr mog $ \mogPtr ->+          withPtr img $ \imgPtr -> mask_ $ do+            [C.block| void {+              cv::bgsegm::BackgroundSubtractorMOG * mog = *$(Ptr_BackgroundSubtractorMOG * mogPtr);+              mog->getBackgroundImage(*$(Mat * imgPtr));+            }|]+            pure $ unsafeCoerceMat img
+ src/OpenCV/Extra/Internal/C/Inline.hs view
@@ -0,0 +1,49 @@+{-# language CPP #-}+{-# language QuasiQuotes #-}+{-# language TemplateHaskell #-}++#ifndef ENABLE_INTERNAL_DOCUMENTATION+{-# OPTIONS_HADDOCK hide #-}+#endif++-- | Interface between OpenCV (extra modules) and inline-c(pp) (Haskell)+module OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx ) where++import "base" Data.Monoid ( (<>) )+import qualified "containers" Data.Map as M+import qualified "inline-c" Language.C.Inline as C+import qualified "inline-c" Language.C.Types  as C+import qualified "inline-c" Language.C.Inline.Context as C+import "opencv" OpenCV.Internal.C.Inline ( openCvCtx )+import "this" OpenCV.Extra.Internal.C.Types++-- | Context useful to work with the OpenCV library's extra modules.+--+-- Based on 'C.cppCtx', 'C.bsCtx', 'C.vecCtx' and most importantly 'openCvCtx'.+--+-- 'C.ctxTypesTable': converts OpenCV basic types to their counterparts in+-- "OpenCV.Internal.C.Inline".+--+-- No 'C.ctxAntiQuoters'.+openCvExtraCtx :: C.Context+openCvExtraCtx = openCvCtx <> ctx+  where+    ctx = mempty { C.ctxTypesTable = openCvExtraTypesTable }++openCvExtraTypesTable :: C.TypesTable+openCvExtraTypesTable = M.fromList+  [ ( C.TypeName "Ptr_BackgroundSubtractorGMG", [t| C'Ptr_BackgroundSubtractorGMG |] )+  , ( C.TypeName "Ptr_BackgroundSubtractorMOG", [t| C'Ptr_BackgroundSubtractorMOG |] )+  , ( C.TypeName "Ptr_Tracker"                , [t| C'Ptr_Tracker                 |] )+  , ( C.TypeName "Ptr_TrackerFeature"         , [t| C'Ptr_TrackerFeature          |] )+  , ( C.TypeName "Ptr_MultiTracker"           , [t| C'Ptr_MultiTracker            |] )+  , ( C.TypeName "Ptr_MultiTrackerAlt"        , [t| C'Ptr_MultiTrackerAlt         |] )+  , ( C.TypeName "Ptr_SURF"                   , [t| C'Ptr_SURF                    |] )+  , ( C.TypeName "Ptr_GrayworldWB"            , [t| C'Ptr_GrayworldWB             |] )+  , ( C.TypeName "Ptr_LearningBasedWB"        , [t| C'Ptr_LearningBasedWB         |] )+  , ( C.TypeName "Ptr_SimpleWB"               , [t| C'Ptr_SimpleWB                |] )+  , ( C.TypeName "Ptr_CharucoBoard"           , [t| C'Ptr'CharucoBoard            |] )+  , ( C.TypeName "Ptr_Dictionary"             , [t| C'Ptr'Dictionary              |] )+  , ( C.TypeName "VectorVectorPoint2f"        , [t| C'Vector'Vector'Point2f       |] )+  , ( C.TypeName "VectorInt"                  , [t| C'Vector'Int                  |] )+  ]
+ src/OpenCV/Extra/Internal/C/Types.hs view
@@ -0,0 +1,40 @@+{-# language CPP #-}++#ifndef ENABLE_INTERNAL_DOCUMENTATION+{-# OPTIONS_HADDOCK hide #-}+#endif++module OpenCV.Extra.Internal.C.Types where++--------------------------------------------------------------------------------++-- | Haskell representation of an OpenCV @cv::Ptr<cv::bgsegm::BackgroundSubtractorGMG>@ object+data C'Ptr_BackgroundSubtractorGMG+-- | Haskell representation of an OpenCV @cv::Ptr<cv::bgsegm::Ptr_BackgroundSubtractorMOG>@ object+data C'Ptr_BackgroundSubtractorMOG+-- | Haskell representation of an OpenCV @cv::Ptr<cv::xfeatures2d::SURF>@ object+data C'Ptr_SURF++-- | Haskell representation of an OpenCV @cv::Ptr<cv::xphoto::GrayworldWB>@ object+data C'Ptr_GrayworldWB+-- | Haskell representation of an OpenCV @cv::Ptr<cv::xphoto::LearningBasedWB>@ object+data C'Ptr_LearningBasedWB+-- | Haskell representation of an OpenCV @cv::Ptr<cv::xphoto::SimpleWB>@ object+data C'Ptr_SimpleWB++-- | Haskell representation of an OpenCV @cv::Ptr<cv::Tracker>@ object+data C'Ptr_Tracker+data C'Ptr_TrackerFeature+data C'Ptr_MultiTracker+data C'Ptr_MultiTrackerAlt++data C'TrackerFeatureSet+data C'Ptr_TrackerSamplerAlgorithm+++data C'Ptr'Dictionary+data C'Ptr'CharucoBoard++data C'Vector'Int++data C'Vector'Vector'Point2f
+ src/OpenCV/Extra/Tracking.cpp view
@@ -0,0 +1,102 @@++#include "opencv2/core.hpp"++#include "opencv2/tracking.hpp"++#include "tracking.hpp"++using namespace cv;++extern "C" {+Ptr_Tracker * inline_c_OpenCV_Extra_Tracking_0_efe6eac7c3946190981535cdf313473c4fadfc96(const char * ctrackerType_27_inline_c_0) {++      cv::Ptr<cv::Tracker> tacker =+        cv::Tracker::create ( cv::String(ctrackerType_27_inline_c_0));+      return new cv::Ptr<cv::Tracker>(tacker);+    +}++}++extern "C" {+bool inline_c_OpenCV_Extra_Tracking_1_f5218c121fc0cacbb2549b312cc1a0f25f8d3052(Ptr_Tracker * trkPtr_inline_c_0, Mat * srcPtr_inline_c_1, Rect2d * rectPtr_inline_c_2) {++           return (*trkPtr_inline_c_0)->init+              ( *srcPtr_inline_c_1+              , *rectPtr_inline_c_2+              );+         +}++}++extern "C" {+bool inline_c_OpenCV_Extra_Tracking_2_cfa88d7e1596b908857073456e505f8a57bfd55f(Ptr_Tracker * trkPtr_inline_c_0, Mat * srcPtr_inline_c_1, Rect2d * rectPtr_inline_c_2) {++           return (*trkPtr_inline_c_0)->update+              ( *srcPtr_inline_c_1+              , *rectPtr_inline_c_2+              );+         +}++}++extern "C" {+Ptr_MultiTracker * inline_c_OpenCV_Extra_Tracking_3_f3a6cc587d88595f175227bf695c32d2015f0e8d(const char * ctrackerType_27_inline_c_0) {++    cv::Ptr<cv::MultiTracker> mtracker =+      new cv::MultiTracker ( cv::String(ctrackerType_27_inline_c_0));+      return new cv::Ptr<cv::MultiTracker>(mtracker);+    +}++}++extern "C" {+Ptr_TrackerFeature * inline_c_OpenCV_Extra_Tracking_4_ccebdf6970bfcdb2823cf254bf81c506730c3f7f(const char * ctrackerFeatureType_27_inline_c_0) {++        cv::Ptr<cv::TrackerFeature> ftracker =+          cv::TrackerFeature::create ( cv::String(ctrackerFeatureType_27_inline_c_0));+          return new cv::Ptr<cv::TrackerFeature>(ftracker);++    +}++}++extern "C" {+void inline_c_OpenCV_Extra_Tracking_5_6622f23d9a44ed62d61cf22707e9d8ac3e4f2186(Ptr_MultiTrackerAlt * ptr_inline_c_0) {++                  delete ptr_inline_c_0;+                +}++}++extern "C" {+void inline_c_OpenCV_Extra_Tracking_6_778deb976c698e950da3d4b45362d8b29a2c2547(Ptr_MultiTracker * ptr_inline_c_0) {++                  delete ptr_inline_c_0;+                +}++}++extern "C" {+void inline_c_OpenCV_Extra_Tracking_7_a535e1801086ce360682ac32352766b0a063504e(Ptr_TrackerFeature * ptr_inline_c_0) {++                  delete ptr_inline_c_0;+                +}++}++extern "C" {+void inline_c_OpenCV_Extra_Tracking_8_89f1496eff75dd40a161328bb1f958178e2152e9(Ptr_Tracker * ptr_inline_c_0) {++                  delete ptr_inline_c_0;+                +}++}
+ src/OpenCV/Extra/Tracking.hs view
@@ -0,0 +1,214 @@+{-# language TemplateHaskell #-}+{-# language QuasiQuotes #-}+{-# language MultiParamTypeClasses #-}++{-# language PackageImports #-}+{-# language TypeFamilies #-}++{- |+Tracking extra opencv module+-}++module OpenCV.Extra.Tracking+  ( Tracker(..)+  , MultiTracker (..)+  , MultiTrackerAlt (..)+  , TrackerType (..)+  , TrackerFeature (..)+  , TrackerFeatureType (..)+  , newTracker+  , initTracker+  , updateTracker+  , newMultiTracker+--   , newMultiTrackerAlt+  , newTrackerFeature+  ) where++import "base" Data.Word+import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )+import "base" Foreign.C.String ( withCString )+import "base" Foreign.Marshal.Utils ( toBool )+import qualified "inline-c" Language.C.Inline as C+import qualified "inline-c" Language.C.Inline.Unsafe as CU+import qualified "inline-c-cpp" Language.C.Inline.Cpp as C+import "opencv" OpenCV.Core.Types+import "opencv" OpenCV.Internal+import "opencv" OpenCV.TypeLevel+import "opencv" OpenCV.Internal.C.Types+import "primitive" Control.Monad.Primitive+import "this" OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx )+import "this" OpenCV.Extra.Internal.C.Types+--------------------------------------------------------------------------------++C.context openCvExtraCtx++C.include "opencv2/core.hpp"+C.include "opencv2/tracking.hpp"++C.include "tracking.hpp"++C.using "namespace cv"+--------------------------------------------------------------------------------++data TrackerType+  = BOOSTING    -- ^+  | MIL         -- ^+  | KCF         -- ^+  | MEDIANFLOW  -- ^+  | TLD         -- ^+    deriving (Eq, Show, Enum, Bounded)++data TrackerFeatureType+  = HAAR      -- ^ Haar Feature-based+  | HOG       -- ^ soon Histogram of Oriented Gradients features+  | LBP       -- ^ soon Local Binary Pattern features+  | FEATURE2D -- ^ soon All types of Feature2D+    deriving (Eq, Show, Enum, Bounded)++--------------------------------------------------------------------------------+++newtype Tracker s = Tracker { unTracker :: ForeignPtr C'Ptr_Tracker }+type instance C (Tracker s) = C'Ptr_Tracker++instance WithPtr (Tracker s) where+    withPtr = withForeignPtr . unTracker+++instance FromPtr (Tracker s) where+    fromPtr = objFromPtr Tracker $ \ptr ->+                [CU.block| void {+                  delete $(Ptr_Tracker * ptr);+                }|]++newTracker+  :: (PrimMonad m)+  => TrackerType+     -- ^ Name+  -> m (Tracker (PrimState m))+newTracker trackerType =+  unsafePrimToPrim $ fromPtr $+    withCString (show trackerType) $ \c'trackerType ->+    [CU.block|Ptr_Tracker * {+      cv::Ptr<cv::Tracker> tacker =+        cv::Tracker::create ( cv::String($(const char * c'trackerType)));+      return new cv::Ptr<cv::Tracker>(tacker);+    }|]++initTracker+  :: (PrimMonad m, IsRect rect C.CDouble)+  => Tracker (PrimState m)+  -> Mat ('S '[ 'D, 'D]) ('D) ('D)+  -> rect C.CDouble+  -> m Bool+initTracker trk srcImg boundingBox = unsafePrimToPrim $+    withPtr trk $ \trkPtr ->+    withPtr srcImg $ \srcPtr ->+    withPtr (toRect boundingBox) $ \rectPtr -> toBool <$>+           [C.block| bool {+           return (*$(Ptr_Tracker * trkPtr))->init+              ( *$(Mat * srcPtr)+              , *$(Rect2d * rectPtr)+              );+         }+         |]++updateTracker+     :: (PrimMonad m)+     => Tracker (PrimState m)+     -> Mat ('D) ('D) ('S Word8)+     -> m (Maybe (Rect C.CDouble))+--      -> m (Maybe (Rect Int32))+updateTracker trk srcImg = unsafePrimToPrim $+    withPtr trk $ \trkPtr ->+      withPtr srcImg $ \srcPtr ->+      withPtr rect $ \rectPtr -> do+        ok <- toBool <$> [C.block| bool {+           return (*$(Ptr_Tracker * trkPtr))->update+              ( *$(Mat * srcPtr)+              , *$(Rect2d * rectPtr)+              );+         }+         |]+        return $ if ok+           then+              Just rect+           else+              Nothing+  where+    rect :: Rect2d+    rect = toRect HRect{ hRectTopLeft = pure 0+                       , hRectSize    = pure 0+                       }++--------------------------------------------------------------------------------++newtype TrackerFeature s = TrackerFeature { unTrackerFeature :: ForeignPtr C'Ptr_TrackerFeature }+type instance C (TrackerFeature s) = C'Ptr_TrackerFeature++instance WithPtr (TrackerFeature s) where+    withPtr = withForeignPtr . unTrackerFeature+++instance FromPtr (TrackerFeature s) where+    fromPtr = objFromPtr TrackerFeature $ \ptr ->+                [CU.block| void {+                  delete $(Ptr_TrackerFeature * ptr);+                }|]++newtype MultiTracker s = MultiTracker { unMultiTracker :: ForeignPtr C'Ptr_MultiTracker }+type instance C (MultiTracker s) = C'Ptr_MultiTracker++instance WithPtr (MultiTracker s) where+    withPtr = withForeignPtr . unMultiTracker++instance FromPtr (MultiTracker s) where+    fromPtr = objFromPtr MultiTracker $ \ptr ->+                [CU.block| void {+                  delete $(Ptr_MultiTracker * ptr);+                }|]++newtype MultiTrackerAlt s = MultiTrackerAlt { unMultiTrackerAlt :: ForeignPtr C'Ptr_MultiTrackerAlt }+type instance C (MultiTrackerAlt s) = C'Ptr_MultiTrackerAlt++instance WithPtr (MultiTrackerAlt s) where+    withPtr = withForeignPtr . unMultiTrackerAlt++instance FromPtr (MultiTrackerAlt s) where+    fromPtr = objFromPtr MultiTrackerAlt $ \ptr ->+                [CU.block| void {+                  delete $(Ptr_MultiTrackerAlt * ptr);+                }|]++--------------------------------------------------------------------------------++newMultiTracker+    :: (PrimMonad m)+    => TrackerType+       -- ^ Name+    -> m (MultiTracker (PrimState m))+newMultiTracker trackerType =+  unsafePrimToPrim $ fromPtr $+    withCString (show trackerType) $ \c'trackerType ->+    [CU.block|Ptr_MultiTracker * {+    cv::Ptr<cv::MultiTracker> mtracker =+      new cv::MultiTracker ( cv::String($(const char * c'trackerType)));+      return new cv::Ptr<cv::MultiTracker>(mtracker);+    }|]++--------------------------------------------------------------------------------++newTrackerFeature+  :: (PrimMonad m)+  => TrackerFeatureType+     -- ^ Name+  -> m (TrackerFeature (PrimState m))+newTrackerFeature trackerFeatureType =+  unsafePrimToPrim $ fromPtr $+    withCString (show trackerFeatureType) $ \c'trackerFeatureType ->+    [CU.block|Ptr_TrackerFeature * {+        cv::Ptr<cv::TrackerFeature> ftracker =+          cv::TrackerFeature::create ( cv::String($(const char * c'trackerFeatureType)));+          return new cv::Ptr<cv::TrackerFeature>(ftracker);++    }|]
+ src/OpenCV/Extra/XFeatures2d.cpp view
@@ -0,0 +1,94 @@++#include "opencv2/core.hpp"++#include "opencv2/xfeatures2d.hpp"++#include "xfeatures/surf.hpp"++using namespace cv;++extern "C" {+Ptr_SURF * inline_c_OpenCV_Extra_XFeatures2d_0_bc51f58e60712bc5e3af0c96b0bc52ae5b9b1c1a(double chessianThreshold_27_inline_c_0, int32_t surf_nOctaves_inline_c_1, int32_t surf_nOctaveLayers_inline_c_2, bool cextended_27_inline_c_3, bool cupright_27_inline_c_4) {++      cv::Ptr<cv::xfeatures2d::SURF> surfPtr =+        cv::xfeatures2d::SURF::create+        ( chessianThreshold_27_inline_c_0+        , surf_nOctaves_inline_c_1+        , surf_nOctaveLayers_inline_c_2+        , cextended_27_inline_c_3+        , cupright_27_inline_c_4+        );+      return new cv::Ptr<cv::xfeatures2d::SURF>(surfPtr);+    +}++}++extern "C" {+Exception * inline_c_OpenCV_Extra_XFeatures2d_1_010dc4a635b061c9b20e8bc1a0f09def3d5e993b(Ptr_SURF * surfPtr_inline_c_0, Mat * maskPtr_inline_c_1, Mat * imgPtr_inline_c_2, Mat * descPtr_inline_c_3, int32_t * numPtsPtr_inline_c_4, KeyPoint *** arrayPtrPtr_inline_c_5) {++  try+  {   +          cv::xfeatures2d::SURF * surf = *surfPtr_inline_c_0;+          cv::Mat * maskPtr = maskPtr_inline_c_1;++          std::vector<cv::KeyPoint> keypoints = std::vector<cv::KeyPoint>();+          surf->+            detectAndCompute+            ( *imgPtr_inline_c_2+            , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())+            , keypoints+            , *descPtr_inline_c_3+            , false+            );++          *numPtsPtr_inline_c_4 = keypoints.size();++          cv::KeyPoint * * * arrayPtrPtr = arrayPtrPtr_inline_c_5;+          cv::KeyPoint * * arrayPtr = new cv::KeyPoint * [keypoints.size()];+          *arrayPtrPtr = arrayPtr;++          for (std::vector<cv::KeyPoint>::size_type ix = 0; ix != keypoints.size(); ix++)+          {+            cv::KeyPoint & org = keypoints[ix];+            cv::KeyPoint * newPt =+              new cv::KeyPoint( org.pt+                              , org.size+                              , org.angle+                              , org.response+                              , org.octave+                              , org.class_id+                              );+            arrayPtr[ix] = newPt;+          }+        +    return NULL;+  }+  catch (const cv::Exception & e)+  {+    return new cv::Exception(e);+  }++}++}++extern "C" {+void inline_c_OpenCV_Extra_XFeatures2d_2_cf7ed8abd0aadc595f02b1ca9ec2ba13285a12cd(KeyPoint *** arrayPtrPtr_inline_c_0) {++            delete [] *arrayPtrPtr_inline_c_0;+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_XFeatures2d_3_0a78fb7b80501d1c0a37452b7758538729bc3810(Ptr_SURF * ptr_inline_c_0) {++                  cv::Ptr<cv::xfeatures2d::SURF> * surf_ptr_ptr = ptr_inline_c_0;+                  surf_ptr_ptr->release();+                  delete surf_ptr_ptr;+                +}++}
+ src/OpenCV/Extra/XFeatures2d.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}++module OpenCV.Extra.XFeatures2d+    ( -- * SURF+      Surf+    , SurfParams(..)+    , defaultSurfParams+    , mkSurf+    , surfDetectAndCompute++    ) where++import "base" Control.Exception ( mask_ )+import "base" Data.Int+import "base" Data.Word+import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )+import "base" Foreign.Marshal.Alloc ( alloca )+import "base" Foreign.Marshal.Array ( peekArray )+import "base" Foreign.Marshal.Utils ( fromBool )+import "base" Foreign.Ptr ( Ptr, nullPtr )+import "base" Foreign.Storable ( peek )+import "base" System.IO.Unsafe ( unsafePerformIO )+import qualified "inline-c" Language.C.Inline as C+import qualified "inline-c" Language.C.Inline.Unsafe as CU+import qualified "inline-c-cpp" Language.C.Inline.Cpp as C+import "opencv" OpenCV.Core.Types+import "opencv" OpenCV.Internal+import "opencv" OpenCV.Internal.Core.Types.Mat+import "opencv" OpenCV.Internal.C.Types+import "opencv" OpenCV.Internal.Exception ( cvExcept, unsafeWrapException )+import "opencv" OpenCV.TypeLevel+import "this"   OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx )+import "this"   OpenCV.Extra.Internal.C.Types+import qualified "vector" Data.Vector as V++--------------------------------------------------------------------------------++C.context openCvExtraCtx++C.include "opencv2/core.hpp"+C.include "opencv2/xfeatures2d.hpp"+C.include "xfeatures/surf.hpp"++C.using "namespace cv"++--------------------------------------------------------------------------------+-- SURF - Speeded Up Roubst Features+--------------------------------------------------------------------------------++-- Internally, an Surf is a pointer to a @cv::Ptr<cv::xfeatures2d::SURF>@, which in turn points+-- to an actual @cv::xfeatures2d::SURF@ object.+newtype Surf = Surf {unSurf :: ForeignPtr C'Ptr_SURF}++type instance C Surf = C'Ptr_SURF++instance WithPtr Surf where+    withPtr = withForeignPtr . unSurf++instance FromPtr Surf where+    fromPtr = objFromPtr Surf $ \ptr ->+                [CU.block| void {+                  cv::Ptr<cv::xfeatures2d::SURF> * surf_ptr_ptr = $(Ptr_SURF * ptr);+                  surf_ptr_ptr->release();+                  delete surf_ptr_ptr;+                }|]++--------------------------------------------------------------------------------++data SurfParams+   = SurfParams+     { surf_hessianThreshold :: !Double+       -- ^ Threshold for hessian keypoint detector used in SURF+     , surf_nOctaves :: !Int32+       -- ^ Number of pyramid octaves the keypoint detector will use.+     , surf_nOctaveLayers :: !Int32+       -- ^ Number of octave layers within each octave.+     , surf_extended :: !Bool+       -- ^ Extended descriptor flag (true - use extended 128-element descriptors; false - use 64-element descriptors).+     , surf_upright :: !Bool+       -- ^ Up-right or rotated features flag (true - do not compute orientation of features; false - compute orientation).+     }++defaultSurfParams :: SurfParams+defaultSurfParams =+    SurfParams+     { surf_hessianThreshold = 100+     , surf_nOctaves = 4+     , surf_nOctaveLayers = 3+     , surf_extended = False+     , surf_upright = False+     }++--------------------------------------------------------------------------------++newSurf :: SurfParams -> IO Surf+newSurf SurfParams{..} = fromPtr+    [CU.block|Ptr_SURF * {+      cv::Ptr<cv::xfeatures2d::SURF> surfPtr =+        cv::xfeatures2d::SURF::create+        ( $(double  c'hessianThreshold)+        , $(int32_t surf_nOctaves)+        , $(int32_t surf_nOctaveLayers)+        , $(bool    c'extended)+        , $(bool    c'upright)+        );+      return new cv::Ptr<cv::xfeatures2d::SURF>(surfPtr);+    }|]+  where+    c'hessianThreshold = realToFrac surf_hessianThreshold+    c'extended = fromBool surf_extended+    c'upright = fromBool surf_upright+++mkSurf :: SurfParams -> Surf+mkSurf = unsafePerformIO . newSurf++--------------------------------------------------------------------------------++{- | Detect keypoints and compute descriptors++Example:++@+surfDetectAndComputeImg+    :: forall (width    :: Nat)+              (height   :: Nat)+              (channels :: Nat)+              (depth    :: *)+     . (Mat (ShapeT [height, width]) ('S channels) ('S depth) ~ Frog)+    => Mat (ShapeT [height, width]) ('S channels) ('S depth)+surfDetectAndComputeImg = exceptError $ do+    (kpts, _descs) <- surfDetectAndCompute surf frog Nothing+    withMatM (Proxy :: Proxy [height, width])+             (Proxy :: Proxy channels)+             (Proxy :: Proxy depth)+             white $ \\imgM -> do+      void $ matCopyToM imgM (V2 0 0) frog Nothing+      forM_ kpts $ \\kpt -> do+        let kptRec = keyPointAsRec kpt+        circle imgM (round \<$> kptPoint kptRec :: V2 Int32) 5 blue 1 LineType_AA 0+  where+    surf = mkSurf defaultSurfParams+@++<<doc/generated/examples/surfDetectAndComputeImg.png surfDetectAndComputeImg>>+-}+surfDetectAndCompute+    :: Surf+    -> Mat ('S [height, width]) channels depth -- ^ Image.+    -> Maybe (Mat ('S [height, width]) ('S 1) ('S Word8)) -- ^ Mask.+    -> CvExcept ( V.Vector KeyPoint+                , Mat 'D 'D 'D+                )+surfDetectAndCompute surf img mbMask = unsafeWrapException $ do+    descriptors <- newEmptyMat+    withPtr surf $ \surfPtr ->+      withPtr img $ \imgPtr ->+      withPtr mbMask $ \maskPtr ->+      withPtr descriptors $ \descPtr ->+      alloca $ \(numPtsPtr :: Ptr Int32) ->+      alloca $ \(arrayPtrPtr :: Ptr (Ptr (Ptr C'KeyPoint))) -> mask_ $ do+        ptrException <- [cvExcept|+          cv::xfeatures2d::SURF * surf = *$(Ptr_SURF * surfPtr);+          cv::Mat * maskPtr = $(Mat * maskPtr);++          std::vector<cv::KeyPoint> keypoints = std::vector<cv::KeyPoint>();+          surf->+            detectAndCompute+            ( *$(Mat * imgPtr)+            , maskPtr ? cv::_InputArray(*maskPtr) : cv::_InputArray(noArray())+            , keypoints+            , *$(Mat * descPtr)+            , false+            );++          *$(int32_t * numPtsPtr) = keypoints.size();++          cv::KeyPoint * * * arrayPtrPtr = $(KeyPoint * * * arrayPtrPtr);+          cv::KeyPoint * * arrayPtr = new cv::KeyPoint * [keypoints.size()];+          *arrayPtrPtr = arrayPtr;++          for (std::vector<cv::KeyPoint>::size_type ix = 0; ix != keypoints.size(); ix++)+          {+            cv::KeyPoint & org = keypoints[ix];+            cv::KeyPoint * newPt =+              new cv::KeyPoint( org.pt+                              , org.size+                              , org.angle+                              , org.response+                              , org.octave+                              , org.class_id+                              );+            arrayPtr[ix] = newPt;+          }+        |]+        if ptrException /= nullPtr+        then Left . BindingException <$> fromPtr (pure ptrException)+        else do+          numPts <- fromIntegral <$> peek numPtsPtr+          arrayPtr <- peek arrayPtrPtr+          keypoints <- mapM (fromPtr . pure) =<< peekArray numPts arrayPtr++          [CU.block| void {+            delete [] *$(KeyPoint * * * arrayPtrPtr);+          }|]++          pure $ Right (V.fromList keypoints, relaxMat descriptors)+++-- vim: ft=haskell
+ src/OpenCV/Extra/XPhoto.cpp view
@@ -0,0 +1,28 @@++#include "opencv2/core.hpp"++#include "opencv2/xphoto.hpp"++using namespace cv;++extern "C" {+Exception * inline_c_OpenCV_Extra_XPhoto_0_06297e612174af62db1078e41dba8535638659d5(Mat * srcPtr_inline_c_0, Mat * dstPtr_inline_c_1, double csigma_27_inline_c_2, int32_t cpSize_27_inline_c_3) {++  try+  {   +        cv::xphoto::dctDenoising( *srcPtr_inline_c_0+                                , *dstPtr_inline_c_1+                                , csigma_27_inline_c_2+                                , cpSize_27_inline_c_3+                                );+      +    return NULL;+  }+  catch (const cv::Exception & e)+  {+    return new cv::Exception(e);+  }++}++}
+ src/OpenCV/Extra/XPhoto.hs view
@@ -0,0 +1,80 @@+{-# language CPP #-}+{-# language QuasiQuotes #-}+{-# language TemplateHaskell #-}++#if __GLASGOW_HASKELL__ >= 800+{-# options_ghc -Wno-redundant-constraints #-}+#endif++module OpenCV.Extra.XPhoto+  ( dctDenoising+  ) where++import "base" Data.Int ( Int32 )+import "base" Data.Word ( Word8 )+import "base" Data.Maybe ( fromMaybe )+import qualified "inline-c" Language.C.Inline as C+import qualified "inline-c-cpp" Language.C.Inline.Cpp as C+import "opencv" OpenCV.Internal.C.Inline ( openCvCtx )+import "opencv" OpenCV.Internal.C.Types ( withPtr )+import "opencv" OpenCV.Internal.Exception+import "opencv" OpenCV.Internal.Core.Types.Mat+import "opencv" OpenCV.TypeLevel++--------------------------------------------------------------------------------++C.context openCvCtx++C.include "opencv2/core.hpp"+C.include "opencv2/xphoto.hpp"+C.using "namespace cv"++{-| Perform dctDenoising function for colored images.++Example:++@+dctDenoisingImg+    :: forall h w w2 c d+     . ( Mat (ShapeT [h, w]) ('S c) ('S d) ~ Lenna_512x512+       , w2 ~ ((*) w 2)+       )+    => Mat ('S ['S h, 'S w2]) ('S c) ('S d)+dctDenoisingImg = exceptError $ do+    denoised <- dctDenoising 10 Nothing lenna_512x512+    withMatM+      (Proxy :: Proxy [h, w2])+      (Proxy :: Proxy c)+      (Proxy :: Proxy d)+      black $ \\imgM -> do+        matCopyToM imgM (V2 0 0) lenna_512x512 Nothing+        matCopyToM imgM (V2 w 0) denoised Nothing+  where+    w = fromInteger $ natVal (Proxy :: Proxy w)+@++<<doc/generated/examples/dctDenoisingImg.png dctDenoisingImg>>+-}++dctDenoising+   :: Double -- ^ expected noise standard deviation+   -> Maybe Int32  -- ^ size of block side where dct is computed use default 16+   -> Mat ('S [h, w]) ('S 3) ('S Word8) -- ^ Input image 8-bit 3-channel image.+   -> CvExcept (Mat ('S [h, w]) ('S 3) ('S Word8))+             -- ^ Output image same size and type as input.+dctDenoising sigma mPSize src =+  unsafeWrapException $ do+    dst <- newEmptyMat+    handleCvException (pure $ unsafeCoerceMat dst) $+      withPtr src         $ \srcPtr         ->+      withPtr dst         $ \dstPtr         ->+      [cvExcept|+        cv::xphoto::dctDenoising( *$(Mat * srcPtr)+                                , *$(Mat * dstPtr)+                                , $(double c'sigma)+                                , $(int32_t c'pSize)+                                );+      |]+  where+    c'sigma = realToFrac sigma+    c'pSize = fromMaybe 16 mPSize
+ src/OpenCV/Extra/XPhoto/WhiteBalancer.cpp view
@@ -0,0 +1,182 @@++#include "opencv2/core.hpp"++#include "opencv2/xphoto.hpp"++#include "white-ballance.hpp"++using namespace cv;++extern "C" {+Ptr_GrayworldWB * inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_0_4fd73c46202741401678ebad8803d1640b421482(double cvarThreshold_27_inline_c_0) {++      cv::Ptr<cv::xphoto::GrayworldWB> wbAlg = cv::xphoto::createGrayworldWB ();+      wbAlg->setSaturationThreshold(cvarThreshold_27_inline_c_0);+      return new cv::Ptr<cv::xphoto::GrayworldWB>(wbAlg);+    +}++}++extern "C" {+Ptr_LearningBasedWB * inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_1_0692032a7bec02f065f9e8e1c88aeec372b3efe9(int cvarHistBinNum_27_inline_c_0, int cvarRangeMaxVal_27_inline_c_1, double cvarSaturationThreshold_27_inline_c_2) {++      cv::Ptr<cv::xphoto::LearningBasedWB> wbAlg = cv::xphoto::createLearningBasedWB ();+      wbAlg->setHistBinNum(cvarHistBinNum_27_inline_c_0);+      wbAlg->setRangeMaxVal(cvarRangeMaxVal_27_inline_c_1);+      wbAlg->setSaturationThreshold(cvarSaturationThreshold_27_inline_c_2);+      return new cv::Ptr<cv::xphoto::LearningBasedWB>(wbAlg);+    +}++}++extern "C" {+Ptr_SimpleWB * inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_2_4ecea8417cf34021c3e52bee10fb9be4499827ea(double cvarIMin_27_inline_c_0, double cvarIMax_27_inline_c_1, double cvarOMin_27_inline_c_2, double cvarOMax_27_inline_c_3, double cvarP_27_inline_c_4) {++      cv::Ptr<cv::xphoto::SimpleWB> wbAlg = cv::xphoto::createSimpleWB ();+      wbAlg->setInputMin( cvarIMin_27_inline_c_0);+      wbAlg->setInputMax( cvarIMax_27_inline_c_1);+      wbAlg->setOutputMin(cvarOMin_27_inline_c_2);+      wbAlg->setOutputMax(cvarOMax_27_inline_c_3);+      wbAlg->setP(cvarP_27_inline_c_4);+      return new cv::Ptr<cv::xphoto::SimpleWB>(wbAlg);+    +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_3_2378626bf54d7674c38c44cac881e7801e57d543(Ptr_SimpleWB * wbAlgPtr_inline_c_0, Mat * imgInPtr_inline_c_1, Mat * imgOutPtr_inline_c_2) {++              cv::xphoto::SimpleWB * wb = *wbAlgPtr_inline_c_0;+              wb->balanceWhite+              ( *imgInPtr_inline_c_1+              , *imgOutPtr_inline_c_2+              );+            +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_4_9c296a6aea62311d052959acbc63d86a7c62253b(Ptr_LearningBasedWB * wbAlgPtr_inline_c_0, Mat * imgInPtr_inline_c_1, Mat * imgOutPtr_inline_c_2) {++              cv::xphoto::LearningBasedWB * wb = *wbAlgPtr_inline_c_0;+              wb->balanceWhite+              ( *imgInPtr_inline_c_1+              , *imgOutPtr_inline_c_2+              );+            +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_5_80e5036bd319618f74258d98ddd7b0d8f641651b(Ptr_GrayworldWB * wbAlgPtr_inline_c_0, Mat * imgInPtr_inline_c_1, Mat * imgOutPtr_inline_c_2) {++              cv::xphoto::GrayworldWB * wb = *wbAlgPtr_inline_c_0;+              wb->balanceWhite+              ( *imgInPtr_inline_c_1+              , *imgOutPtr_inline_c_2+              );+            +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_6_3326c72a78f150bf51e4e5874c00ca2e9deed8ec(Ptr_SimpleWB * knnPtr_inline_c_0) {++              cv::xphoto::SimpleWB * knn = *knnPtr_inline_c_0;+              knn->clear();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_7_f5f092be98dedc30e21c12bd8c827d45feeeac9f(Ptr_SimpleWB * knnPtr_inline_c_0, bool * emptyPtr_inline_c_1) {++              cv::xphoto::SimpleWB * knn = *knnPtr_inline_c_0;+              *emptyPtr_inline_c_1 = knn->empty();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_8_8d9092fd1aec4fa0c8ea6ce464757e5b4a90738f(Ptr_LearningBasedWB * knnPtr_inline_c_0) {++              cv::xphoto::LearningBasedWB * knn = *knnPtr_inline_c_0;+              knn->clear();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_9_fb6d5b983e28c8b8df2c941c172abb66b3802cea(Ptr_LearningBasedWB * knnPtr_inline_c_0, bool * emptyPtr_inline_c_1) {++              cv::xphoto::LearningBasedWB * knn = *knnPtr_inline_c_0;+              *emptyPtr_inline_c_1 = knn->empty();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_10_c7381c418d45bf665351fc19c11208bbda9dff4f(Ptr_GrayworldWB * knnPtr_inline_c_0) {++              cv::xphoto::GrayworldWB * knn = *knnPtr_inline_c_0;+              knn->clear();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_11_d692009848de0a973eeb08ab410c913952046b11(Ptr_GrayworldWB * knnPtr_inline_c_0, bool * emptyPtr_inline_c_1) {++              cv::xphoto::GrayworldWB * knn = *knnPtr_inline_c_0;+              *emptyPtr_inline_c_1 = knn->empty();+          +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_12_97c5d79b5414aedba9c9d3333bfc0d26531e5bdb(Ptr_SimpleWB * ptr_inline_c_0) {++                  cv::Ptr<cv::xphoto::SimpleWB> * knn_ptr_ptr =+                    ptr_inline_c_0;+                  knn_ptr_ptr->release();+                  delete knn_ptr_ptr;+                +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_13_680790a74227e4ede15c2bb1a2657d8b4e6969eb(Ptr_LearningBasedWB * ptr_inline_c_0) {++                  cv::Ptr<cv::xphoto::LearningBasedWB> * knn_ptr_ptr =+                    ptr_inline_c_0;+                  knn_ptr_ptr->release();+                  delete knn_ptr_ptr;+                +}++}++extern "C" {+void inline_c_OpenCV_Extra_XPhoto_WhiteBalancer_14_1ec8441459880af3f8a2cb39d16f08188b544e0e(Ptr_GrayworldWB * ptr_inline_c_0) {++                  cv::Ptr<cv::xphoto::GrayworldWB> * knn_ptr_ptr =+                    ptr_inline_c_0;+                  knn_ptr_ptr->release();+                  delete knn_ptr_ptr;+                +}++}
+ src/OpenCV/Extra/XPhoto/WhiteBalancer.hs view
@@ -0,0 +1,312 @@+{-# language TemplateHaskell #-}+{-# language QuasiQuotes #-}++module OpenCV.Extra.XPhoto.WhiteBalancer+ ( WhiteBalancer (..)+ , GrayworldWB+ , LearningBasedWB+ , SimpleWB+ , newGrayworldWB+ , newLearningBasedWB+ , newSimpleWB+ ) where++import "base" Data.Int+import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )+import "base" Foreign.Marshal.Alloc ( alloca )+import "base" Foreign.Marshal.Utils ( toBool )+import "base" Foreign.Storable ( peek )+import qualified "inline-c" Language.C.Inline as C+import qualified "inline-c" Language.C.Inline.Unsafe as CU+import qualified "inline-c-cpp" Language.C.Inline.Cpp as C+import "opencv" OpenCV.Core.Types+import "opencv" OpenCV.Internal+import "opencv" OpenCV.Internal.Core.Types.Mat+import "opencv" OpenCV.Internal.C.Types+-- import "opencv" OpenCV.Video.MotionAnalysis ( BackgroundSubtractor(..) )+import "primitive" Control.Monad.Primitive+import "this" OpenCV.Extra.Internal.C.Inline ( openCvExtraCtx )+import "this" OpenCV.Extra.Internal.C.Types+import "opencv" OpenCV.TypeLevel++C.context openCvExtraCtx++C.include "opencv2/core.hpp"+C.include "opencv2/xphoto.hpp"+C.include "white-ballance.hpp"++C.using "namespace cv"++--------------------------------------------------------------------------------+-- WhiteBalancer+--------------------------------------------------------------------------------++class WhiteBalancer a where+    balanceWhite+        :: (PrimMonad m)+        => a (PrimState m)+        ->    Mat ('S [h, w]) channels depth  -- ^ The input Image.+        -> m (Mat ('S [h, w]) channels depth) -- ^ The output image.++--------------------------------------------------------------------------------+-- Background subtractors+--------------------------------------------------------------------------------++newtype GrayworldWB s+      = GrayworldWB+        { unGrayworldWB :: ForeignPtr C'Ptr_GrayworldWB }++type instance C (GrayworldWB  s) = C'Ptr_GrayworldWB++instance WithPtr (GrayworldWB s) where+    withPtr = withForeignPtr . unGrayworldWB++instance FromPtr (GrayworldWB s) where+    fromPtr = objFromPtr GrayworldWB $ \ptr ->+                [CU.block| void {+                  cv::Ptr<cv::xphoto::GrayworldWB> * knn_ptr_ptr =+                    $(Ptr_GrayworldWB * ptr);+                  knn_ptr_ptr->release();+                  delete knn_ptr_ptr;+                }|]++newtype LearningBasedWB s+      = LearningBasedWB+        { unLearningBasedWB :: ForeignPtr C'Ptr_LearningBasedWB }++type instance C (LearningBasedWB  s) = C'Ptr_LearningBasedWB++instance WithPtr (LearningBasedWB s) where+    withPtr = withForeignPtr . unLearningBasedWB++instance FromPtr (LearningBasedWB s) where+    fromPtr = objFromPtr LearningBasedWB $ \ptr ->+                [CU.block| void {+                  cv::Ptr<cv::xphoto::LearningBasedWB> * knn_ptr_ptr =+                    $(Ptr_LearningBasedWB * ptr);+                  knn_ptr_ptr->release();+                  delete knn_ptr_ptr;+                }|]++newtype SimpleWB s+      = SimpleWB+        { unSimpleWB :: ForeignPtr C'Ptr_SimpleWB }++type instance C (SimpleWB  s) = C'Ptr_SimpleWB++instance WithPtr (SimpleWB s) where+    withPtr = withForeignPtr . unSimpleWB++instance FromPtr (SimpleWB s) where+    fromPtr = objFromPtr SimpleWB $ \ptr ->+                [CU.block| void {+                  cv::Ptr<cv::xphoto::SimpleWB> * knn_ptr_ptr =+                    $(Ptr_SimpleWB * ptr);+                  knn_ptr_ptr->release();+                  delete knn_ptr_ptr;+                }|]++---+instance Algorithm GrayworldWB where+    algorithmClearState knn = unsafePrimToPrim $+        withPtr knn $ \knnPtr ->+          [C.block|void {+              cv::xphoto::GrayworldWB * knn = *$(Ptr_GrayworldWB * knnPtr);+              knn->clear();+          }|]++    algorithmIsEmpty knn = unsafePrimToPrim $+        withPtr knn $ \knnPtr ->+        alloca $ \emptyPtr -> do+          [C.block|void {+              cv::xphoto::GrayworldWB * knn = *$(Ptr_GrayworldWB * knnPtr);+              *$(bool * emptyPtr) = knn->empty();+          }|]+          toBool <$> peek emptyPtr++instance Algorithm LearningBasedWB where+    algorithmClearState knn = unsafePrimToPrim $+        withPtr knn $ \knnPtr ->+          [C.block|void {+              cv::xphoto::LearningBasedWB * knn = *$(Ptr_LearningBasedWB * knnPtr);+              knn->clear();+          }|]++    algorithmIsEmpty knn = unsafePrimToPrim $+        withPtr knn $ \knnPtr ->+        alloca $ \emptyPtr -> do+          [C.block|void {+              cv::xphoto::LearningBasedWB * knn = *$(Ptr_LearningBasedWB * knnPtr);+              *$(bool * emptyPtr) = knn->empty();+          }|]+          toBool <$> peek emptyPtr++instance Algorithm SimpleWB where+    algorithmClearState knn = unsafePrimToPrim $+        withPtr knn $ \knnPtr ->+          [C.block|void {+              cv::xphoto::SimpleWB * knn = *$(Ptr_SimpleWB * knnPtr);+              knn->clear();+          }|]++    algorithmIsEmpty knn = unsafePrimToPrim $+        withPtr knn $ \knnPtr ->+        alloca $ \emptyPtr -> do+          [C.block|void {+              cv::xphoto::SimpleWB * knn = *$(Ptr_SimpleWB * knnPtr);+              *$(bool * emptyPtr) = knn->empty();+          }|]+          toBool <$> peek emptyPtr+---++instance WhiteBalancer GrayworldWB where+    balanceWhite wbAlg imgIn = unsafePrimToPrim $ do+        imgOut <- newEmptyMat+        withPtr wbAlg $ \wbAlgPtr ->+          withPtr imgIn $ \imgInPtr ->+          withPtr imgOut $ \imgOutPtr -> do+            [C.block| void {+              cv::xphoto::GrayworldWB * wb = *$(Ptr_GrayworldWB * wbAlgPtr);+              wb->balanceWhite+              ( *$(Mat * imgInPtr)+              , *$(Mat * imgOutPtr)+              );+            }|]+            pure $ unsafeCoerceMat imgOut++instance WhiteBalancer LearningBasedWB where+    balanceWhite wbAlg imgIn = unsafePrimToPrim $ do+        imgOut <- newEmptyMat+        withPtr wbAlg $ \wbAlgPtr ->+          withPtr imgIn $ \imgInPtr ->+          withPtr imgOut $ \imgOutPtr -> do+            [C.block| void {+              cv::xphoto::LearningBasedWB * wb = *$(Ptr_LearningBasedWB * wbAlgPtr);+              wb->balanceWhite+              ( *$(Mat * imgInPtr)+              , *$(Mat * imgOutPtr)+              );+            }|]+            pure $ unsafeCoerceMat imgOut++instance WhiteBalancer SimpleWB where+    balanceWhite wbAlg imgIn = unsafePrimToPrim $ do+        imgOut <- newEmptyMat+        withPtr wbAlg $ \wbAlgPtr ->+          withPtr imgIn $ \imgInPtr ->+          withPtr imgOut $ \imgOutPtr -> do+            [C.block| void {+              cv::xphoto::SimpleWB * wb = *$(Ptr_SimpleWB * wbAlgPtr);+              wb->balanceWhite+              ( *$(Mat * imgInPtr)+              , *$(Mat * imgOutPtr)+              );+            }|]+            pure $ unsafeCoerceMat imgOut+---++{-| Perform GrayworldWB a simple grayworld white balance algorithm.++Example:++@+grayworldWBImg+    :: forall h w h2 w2 c d+     . ( Mat (ShapeT [h, w]) ('S c) ('S d) ~ Sailboat_768x512+       , w2 ~ ((*) w 2)+       , h2 ~ ((*) h 2)+       )+    => IO (Mat ('S ['S h2, 'S w2]) ('S c) ('S d))+grayworldWBImg = do+    let+      bw :: (WhiteBalancer a) => a (PrimState IO) -> IO (Mat (ShapeT [h, w]) ('S c) ('S d))+      bw = flip balanceWhite sailboat_768x512+    balancedGrayworldWB <- bw =<< newGrayworldWB Nothing+    balancedLearningBasedWB <- bw =<< newLearningBasedWB Nothing Nothing Nothing+    balancedSimpleWB <- bw =<< newSimpleWB Nothing Nothing Nothing Nothing Nothing+    pure $ exceptError $+        withMatM+          (Proxy :: Proxy [h2, w2])+          (Proxy :: Proxy c)+          (Proxy :: Proxy d)+          black $ \\imgM -> do+            matCopyToM imgM (V2 0 0) sailboat_768x512 Nothing+            matCopyToM imgM (V2 w 0) balancedGrayworldWB Nothing+            matCopyToM imgM (V2 0 h) balancedLearningBasedWB Nothing+            matCopyToM imgM (V2 w h) balancedSimpleWB Nothing+  where+    w = fromInteger $ natVal (Proxy :: Proxy w)+    h = fromInteger $ natVal (Proxy :: Proxy h)+@++<<doc/generated/examples/grayworldWBImg.png grayworldWBImg>>++-}++newGrayworldWB+    :: (PrimMonad m)+    => Maybe Double+       -- ^ A threshold of 1 means that all pixels are used to white-balance,+       -- while a threshold of 0 means no pixels are used. Lower thresholds+       -- are useful in white-balancing saturated images. Default: 0.9.+    -> m (GrayworldWB (PrimState m))+newGrayworldWB mbVarThreshold = unsafePrimToPrim $ fromPtr+    [CU.block|Ptr_GrayworldWB * {+      cv::Ptr<cv::xphoto::GrayworldWB> wbAlg = cv::xphoto::createGrayworldWB ();+      wbAlg->setSaturationThreshold($(double  c'varThreshold ));+      return new cv::Ptr<cv::xphoto::GrayworldWB>(wbAlg);+    }|]+  where+    c'varThreshold = maybe 0.9 realToFrac mbVarThreshold++newLearningBasedWB+    :: (PrimMonad m)+    => Maybe Int32+      -- ^ default 64, Defines the size of one dimension of a+      -- three-dimensional RGB histogram that is used internally by the algorithm.+      -- It often makes sense to increase the number of bins for images with+      -- higher bit depth (e.g. 256 bins for a 12 bit image).+    -> Maybe Int32+      -- ^ default 255, Maximum possible value of the input image (e.g. 255 for 8 bit images, 4095 for 12 bit images)+    -> Maybe Double+      -- ^ default 0.98, Threshold that is used to determine saturated pixels,+      -- i.e. pixels where at least one of the channels exceeds+    -> m (LearningBasedWB (PrimState m))+newLearningBasedWB mbVarHistBinNum mbRangeMaxVal mbVarSaturationThreshold+  = unsafePrimToPrim $ fromPtr+    [CU.block|Ptr_LearningBasedWB * {+      cv::Ptr<cv::xphoto::LearningBasedWB> wbAlg = cv::xphoto::createLearningBasedWB ();+      wbAlg->setHistBinNum($(int  c'varHistBinNum ));+      wbAlg->setRangeMaxVal($(int  c'varRangeMaxVal ));+      wbAlg->setSaturationThreshold($(double  c'varSaturationThreshold ));+      return new cv::Ptr<cv::xphoto::LearningBasedWB>(wbAlg);+    }|]+  where+    c'varHistBinNum          = maybe 64   fromIntegral mbVarHistBinNum+    c'varRangeMaxVal         = maybe 255  fromIntegral mbRangeMaxVal+    c'varSaturationThreshold = maybe 0.98 realToFrac   mbVarSaturationThreshold++newSimpleWB+    :: (PrimMonad m)+    => Maybe Double -- ^ Input Min (default: 0)+    -> Maybe Double -- ^ Input Max (default: 255)+    -> Maybe Double -- ^ Output Min (default: 0)+    -> Maybe Double -- ^ Output Max (default: 255)+    -> Maybe Double -- ^ Percent of top/bottom values to ignore (default: 2)+    -> m (SimpleWB (PrimState m))+newSimpleWB mbIMin mbIMax mbOMin mbOMax mbP = unsafePrimToPrim $ fromPtr+    [CU.block|Ptr_SimpleWB * {+      cv::Ptr<cv::xphoto::SimpleWB> wbAlg = cv::xphoto::createSimpleWB ();+      wbAlg->setInputMin( $(double  c'varIMin  ));+      wbAlg->setInputMax( $(double  c'varIMax  ));+      wbAlg->setOutputMin($(double  c'varOMin  ));+      wbAlg->setOutputMax($(double  c'varOMax  ));+      wbAlg->setP($(double  c'varP     ));+      return new cv::Ptr<cv::xphoto::SimpleWB>(wbAlg);+    }|]+  where+    c'varIMin  = maybe 0   realToFrac mbIMin+    c'varIMax  = maybe 255 realToFrac mbIMax+    c'varOMin  = maybe 0   realToFrac mbOMin+    c'varOMax  = maybe 255 realToFrac mbOMax+    c'varP     = maybe 2   realToFrac mbP