Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

use "wrapper" instead of "export"/"import" for making a callback function for glp_term_hook() #6

Merged
merged 1 commit into from
Dec 25, 2020
Merged

use "wrapper" instead of "export"/"import" for making a callback function for glp_term_hook() #6

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
22 changes: 6 additions & 16 deletions MIP-glpk/src/Numeric/Optimization/MIP/Solver/GLPK.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -117,8 +117,8 @@ instance IsSolver GLPK IO where
when (length (MIP.userCuts prob) > 0) $ do
error "GLPK does not support user cuts"

let loggingCallback :: CString -> IO Int
loggingCallback p = do
let loggingCallback :: Ptr () -> CString -> IO CInt
loggingCallback _ p = do
s <- peekCString p
solveLogger opt s
return 1
Expand All @@ -137,8 +137,8 @@ instance IsSolver GLPK IO where
}

status <-
bracket (newStablePtr loggingCallback) freeStablePtr $ \loggingCallbackPtr ->
bracket_ (Raw.glp_term_hook termHookFunPtr (castStablePtrToPtr loggingCallbackPtr)) (Raw.glp_term_hook nullFunPtr nullPtr) $
bracket (wrapTermHook loggingCallback) freeHaskellFunPtr $ \loggingCallbackPtr -> do
bracket_ (Raw.glp_term_hook loggingCallbackPtr nullPtr) (Raw.glp_term_hook nullFunPtr nullPtr) $
Raw.glp_intopt prob' p

objVal <- liftM fromFloatDigits $ Raw.glp_mip_obj_val prob'
Expand Down Expand Up @@ -173,15 +173,5 @@ fromBound PosInf _ = (Raw.glpkBounded, 1, 0) -- inconsistent
useTextAsCString :: T.Text -> (CString -> IO a) -> IO a
useTextAsCString s = B.useAsCString (encode localeEncoding s)

termHook :: Ptr () -> CString -> IO CInt
termHook p s = do
let sp :: StablePtr (CString -> IO Int)
sp = castPtrToStablePtr p
callback <- deRefStablePtr sp
liftM fromIntegral $ callback s

foreign export ccall "haskell_mip_glpk_term_hook"
termHook :: Ptr () -> CString -> IO CInt

foreign import ccall "&haskell_mip_glpk_term_hook"
termHookFunPtr :: FunPtr (Ptr () -> CString -> IO CInt)
foreign import ccall "wrapper"
wrapTermHook :: (Ptr a -> CString -> IO CInt) -> IO (FunPtr (Ptr a -> CString -> IO CInt))