-- Routines dealing with memory management in marshalling functions.

module Data.GI.CodeGen.Transfer
    ( freeInArg
    , freeInArgOnError
    , freeContainerType
    ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>))
#endif

import Control.Monad (when)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Conversions
import Data.GI.CodeGen.GObject
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util

-- Basic primitives for freeing the given types. Types that point to
-- Haskell objects with memory managed by the GC should not be freed
-- here. For containers this is only for freeing the container itself,
-- freeing the elements is done separately.
basicFreeFn :: Type -> Maybe Text
basicFreeFn :: Type -> Maybe Text
basicFreeFn (TBasicType BasicType
TUTF8) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"freeMem"
basicFreeFn (TBasicType BasicType
TFileName) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"freeMem"
basicFreeFn (TBasicType BasicType
_) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (TInterface Name
_) = Maybe Text
forall a. Maybe a
Nothing
-- Just passed along
basicFreeFn (TCArray Bool
False (-1) (-1) (TBasicType BasicType
TUInt8)) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (TCArray{}) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"freeMem"
basicFreeFn (TGArray Type
_) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefGArray"
basicFreeFn (TPtrArray Type
_) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefPtrArray"
basicFreeFn (Type
TByteArray) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefGByteArray"
basicFreeFn (TGList Type
_) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"g_list_free"
basicFreeFn (TGSList Type
_) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"g_slist_free"
basicFreeFn (TGHash Type
_ Type
_) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefGHashTable"
basicFreeFn (Type
TError) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (Type
TVariant) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (Type
TGValue) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"B.GValue.unsetGValue"
basicFreeFn (Type
TParamSpec) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (TGClosure Maybe Type
_) = Maybe Text
forall a. Maybe a
Nothing

-- Basic free primitives in the case that an error occured. This is
-- run in the exception handler, so any type which we ref/allocate
-- with the expectation that the called function will consume it (on
-- TransferEverything) should be freed here.
basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe Text)
basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe Text)
basicFreeFnOnError (TBasicType BasicType
TUTF8) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"freeMem"
basicFreeFnOnError (TBasicType BasicType
TFileName) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"freeMem"
basicFreeFnOnError (TBasicType BasicType
_) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
basicFreeFnOnError Type
TVariant Transfer
transfer =
    Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferEverything
             then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefGVariant"
             else Maybe Text
forall a. Maybe a
Nothing
basicFreeFnOnError Type
TParamSpec Transfer
transfer =
    Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferEverything
             then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefGParamSpec"
             else Maybe Text
forall a. Maybe a
Nothing
basicFreeFnOnError Type
TGValue Transfer
transfer =
    Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferEverything
             then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"SP.freeMem"
             else Maybe Text
forall a. Maybe a
Nothing
basicFreeFnOnError (TGClosure Maybe Type
_) Transfer
transfer =
    Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferEverything
             then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"B.GClosure.unrefGClosure"
             else Maybe Text
forall a. Maybe a
Nothing
basicFreeFnOnError t :: Type
t@(TInterface Name
_) Transfer
transfer = do
  Maybe API
api <- HasCallStack => Type -> CodeGen (Maybe API)
Type -> CodeGen (Maybe API)
findAPI Type
t
  case Maybe API
api of
    Just (APIObject Object
_) -> if Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferEverything
                          then do
                            Bool
isGO <- Type -> CodeGen Bool
isGObject Type
t
                            if Bool
isGO
                            then Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefObject"
                            else do
                              Text -> CodeGen ()
line Text
"-- XXX Transfer a non-GObject object"
                              Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                          else Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    Just (APIInterface Interface
_) -> if Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferEverything
                             then do
                               Bool
isGO <- Type -> CodeGen Bool
isGObject Type
t
                               if Bool
isGO
                               then Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefObject"
                               else do
                                 Text -> CodeGen ()
line Text
"-- XXX Transfer a non-GObject object"
                                 Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                             else Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    Just (APIUnion Union
u) -> if Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferEverything
                         then if Union -> Bool
unionIsBoxed Union
u
                              then Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"freeBoxed"
                              else do
                                Text -> CodeGen ()
line Text
"-- XXX Transfer a non-boxed union"
                                Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                         else Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    Just (APIStruct Struct
s) -> if Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferEverything
                          then if Struct -> Bool
structIsBoxed Struct
s
                               then Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"freeBoxed"
                               else do
                                 Text -> CodeGen ()
line Text
"-- XXX Transfer a non-boxed struct"
                                 Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                          else Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    Maybe API
_ -> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
-- Just passed along
basicFreeFnOnError (TCArray Bool
False (-1) (-1) (TBasicType BasicType
TUInt8)) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
basicFreeFnOnError (TCArray{}) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"freeMem"
basicFreeFnOnError (TGArray Type
_) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefGArray"
basicFreeFnOnError (TPtrArray Type
_) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefPtrArray"
basicFreeFnOnError (Type
TByteArray) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefGByteArray"
basicFreeFnOnError (TGList Type
_) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"g_list_free"
basicFreeFnOnError (TGSList Type
_) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"g_slist_free"
basicFreeFnOnError (TGHash Type
_ Type
_) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"unrefGHashTable"
basicFreeFnOnError (Type
TError) Transfer
_ = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing

-- Free just the container, but not the elements.
freeContainer :: Type -> Text -> CodeGen [Text]
freeContainer :: Type -> Text -> CodeGen [Text]
freeContainer Type
t Text
label =
    case Type -> Maybe Text
basicFreeFn Type
t of
      Maybe Text
Nothing -> [Text] -> BaseCodeGen e [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just Text
fn -> [Text] -> BaseCodeGen e [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label]

-- Free one element using the given free function.
freeElem :: Type -> Text -> Text -> ExcCodeGen Text
freeElem :: Type -> Text -> Text -> ExcCodeGen Text
freeElem Type
t Text
label Text
free =
    case Type -> Text -> Maybe (Type, Text)
elementTypeAndMap Type
t Text
forall a. HasCallStack => a
undefined of
      Maybe (Type, Text)
Nothing -> Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
free
      Just (TCArray Bool
False Int
_ Int
_ Type
_, Text
_) ->
          Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Text
"Element type in container \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Text
"\" is an array of unknown length."
      Just (Type
innerType, Text
mapFn) -> do
        let elemFree :: Text
elemFree = Text
"freeElemOf" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
label
        Type -> Text -> ExcCodeGen (Maybe Text)
fullyFree Type
innerType (Text -> Text
prime Text
label) ExcCodeGen (Maybe Text)
-> (Maybe Text -> ExcCodeGen Text) -> ExcCodeGen Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Maybe Text
Nothing -> Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Text
free Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" e"
                  Just Text
elemInnerFree -> do
                     Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
elemFree Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" e = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mapFn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
elemInnerFree Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" e >> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
free Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" e"
                     Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
elemFree

-- Construct a function to free the memory associated with a type, and
-- recursively free any elements of this type in case that it is a
-- container.
fullyFree :: Type -> Text -> ExcCodeGen (Maybe Text)
fullyFree :: Type -> Text -> ExcCodeGen (Maybe Text)
fullyFree Type
t Text
label = case Type -> Maybe Text
basicFreeFn Type
t of
                      Maybe Text
Nothing -> Maybe Text -> ExcCodeGen (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                      Just Text
free -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> ExcCodeGen Text -> ExcCodeGen (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Text -> Text -> ExcCodeGen Text
freeElem Type
t Text
label Text
free

-- Like fullyFree, but free the toplevel element using basicFreeFnOnError.
fullyFreeOnError :: Type -> Text -> Transfer -> ExcCodeGen (Maybe Text)
fullyFreeOnError :: Type -> Text -> Transfer -> ExcCodeGen (Maybe Text)
fullyFreeOnError Type
t Text
label Transfer
transfer =
    Type -> Transfer -> CodeGen (Maybe Text)
basicFreeFnOnError Type
t Transfer
transfer ExcCodeGen (Maybe Text)
-> (Maybe Text -> ExcCodeGen (Maybe Text))
-> ExcCodeGen (Maybe Text)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Text
Nothing -> Maybe Text -> ExcCodeGen (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
        Just Text
free -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> ExcCodeGen Text -> ExcCodeGen (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Text -> Text -> ExcCodeGen Text
freeElem Type
t Text
label Text
free

-- Free the elements in a container type.
freeElements :: Type -> Text -> Text -> ExcCodeGen [Text]
freeElements :: Type -> Text -> Text -> ExcCodeGen [Text]
freeElements Type
t Text
label Text
len =
   case Type -> Text -> Maybe (Type, Text)
elementTypeAndMap Type
t Text
len of
     Maybe (Type, Text)
Nothing -> [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
     Just (Type
inner, Text
mapFn) ->
         Type -> Text -> ExcCodeGen (Maybe Text)
fullyFree Type
inner Text
label ExcCodeGen (Maybe Text)
-> (Maybe Text -> ExcCodeGen [Text]) -> ExcCodeGen [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Maybe Text
Nothing -> [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                   Just Text
innerFree ->
                       [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
mapFn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
innerFree Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label]

-- | Free a container and/or the contained elements, depending on the
-- transfer mode.
freeContainerType :: Transfer -> Type -> Text -> Text -> ExcCodeGen ()
freeContainerType :: Transfer -> Type -> Text -> Text -> BaseCodeGen CGError ()
freeContainerType Transfer
transfer (TGHash Type
_ Type
_) Text
label Text
_ = Transfer -> Text -> BaseCodeGen CGError ()
freeGHashTable Transfer
transfer Text
label
freeContainerType Transfer
transfer Type
t Text
label Text
len = do
      Bool -> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
== Transfer
TransferEverything) (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$
           (Text -> BaseCodeGen CGError ())
-> [Text] -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line ([Text] -> BaseCodeGen CGError ())
-> ExcCodeGen [Text] -> BaseCodeGen CGError ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Text -> Text -> ExcCodeGen [Text]
freeElements Type
t Text
label Text
len
      Bool -> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Transfer
transfer Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
/= Transfer
TransferNothing) (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$
           (Text -> BaseCodeGen CGError ())
-> [Text] -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line ([Text] -> BaseCodeGen CGError ())
-> ExcCodeGen [Text] -> BaseCodeGen CGError ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Text -> CodeGen [Text]
freeContainer Type
t Text
label

freeGHashTable :: Transfer -> Text -> ExcCodeGen ()
freeGHashTable :: Transfer -> Text -> BaseCodeGen CGError ()
freeGHashTable Transfer
TransferNothing Text
_ = () -> BaseCodeGen CGError ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
freeGHashTable Transfer
TransferContainer Text
label =
    Text -> BaseCodeGen CGError ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ Text
"Hash table argument with transfer = Container? "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label
-- Hash tables support setting a free function for keys and elements,
-- we assume that these are always properly set. The worst that can
-- happen this way is a memory leak, as opposed to a double free if we
-- try do free anything here.
freeGHashTable Transfer
TransferEverything Text
label =
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"unrefGHashTable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label

-- Free the elements of a container type in the case an error ocurred,
-- in particular args that should have been transferred did not get
-- transfered.
freeElementsOnError :: Transfer -> Type -> Text -> Text ->
                       ExcCodeGen [Text]
freeElementsOnError :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeElementsOnError Transfer
transfer Type
t Text
label Text
len =
    case Type -> Text -> Maybe (Type, Text)
elementTypeAndMap Type
t Text
len of
      Maybe (Type, Text)
Nothing -> [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just (Type
inner, Text
mapFn) ->
         Type -> Text -> Transfer -> ExcCodeGen (Maybe Text)
fullyFreeOnError Type
inner Text
label Transfer
transfer ExcCodeGen (Maybe Text)
-> (Maybe Text -> ExcCodeGen [Text]) -> ExcCodeGen [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Maybe Text
Nothing -> [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                   Just Text
innerFree ->
                       [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
mapFn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
innerFree Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label]

freeIn :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeIn :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeIn Transfer
transfer (TGHash Type
_ Type
_) Text
label Text
_ =
    Transfer -> Text -> ExcCodeGen [Text]
freeInGHashTable Transfer
transfer Text
label
freeIn Transfer
transfer Type
t Text
label Text
len =
    case Transfer
transfer of
      Transfer
TransferNothing -> [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
(<>) ([Text] -> [Text] -> [Text])
-> ExcCodeGen [Text]
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     ([Text] -> [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Text -> Text -> ExcCodeGen [Text]
freeElements Type
t Text
label Text
len ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except CGError))
  ([Text] -> [Text])
-> ExcCodeGen [Text] -> ExcCodeGen [Text]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Text -> CodeGen [Text]
freeContainer Type
t Text
label
      Transfer
TransferContainer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeElements Type
t Text
label Text
len
      Transfer
TransferEverything -> [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []

freeInOnError :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeInOnError :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeInOnError Transfer
transfer (TGHash Type
_ Type
_) Text
label Text
_ =
    Transfer -> Text -> ExcCodeGen [Text]
freeInGHashTable Transfer
transfer Text
label
freeInOnError Transfer
transfer Type
t Text
label Text
len =
    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
(<>) ([Text] -> [Text] -> [Text])
-> ExcCodeGen [Text]
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     ([Text] -> [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeElementsOnError Transfer
transfer Type
t Text
label Text
len
             ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except CGError))
  ([Text] -> [Text])
-> ExcCodeGen [Text] -> ExcCodeGen [Text]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Text -> CodeGen [Text]
freeContainer Type
t Text
label

-- See freeGHashTable above.
freeInGHashTable :: Transfer -> Text -> ExcCodeGen [Text]
freeInGHashTable :: Transfer -> Text -> ExcCodeGen [Text]
freeInGHashTable Transfer
TransferEverything Text
_ = [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
freeInGHashTable Transfer
TransferContainer Text
label =
    Text -> ExcCodeGen [Text]
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen [Text]) -> Text -> ExcCodeGen [Text]
forall a b. (a -> b) -> a -> b
$ Text
"Hash table argument with TransferContainer? "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label
freeInGHashTable Transfer
TransferNothing Text
label = [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"unrefGHashTable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label]

freeOut :: Text -> CodeGen [Text]
freeOut :: Text -> CodeGen [Text]
freeOut Text
label = [Text]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"freeMem " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label]

-- | Given an input argument to a C callable, and its label in the code,
-- return the list of actions relevant to freeing the memory allocated
-- for the argument (if appropriate, depending on the ownership
-- transfer semantics of the callable).
freeInArg :: Arg -> Text -> Text -> ExcCodeGen [Text]
freeInArg :: Arg -> Text -> Text -> ExcCodeGen [Text]
freeInArg Arg
arg Text
label Text
len = do
  -- Arguments that we alloc ourselves do not always need to be freed,
  -- they will sometimes be soaked up by the wrapPtr constructor, or
  -- they will be DirectionIn.
  if Arg -> Bool
willWrap Arg
arg
    then [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else case Arg -> Direction
direction Arg
arg of
         Direction
DirectionIn -> Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeIn (Arg -> Transfer
transfer Arg
arg) (Arg -> Type
argType Arg
arg) Text
label Text
len
         Direction
DirectionOut -> Text -> CodeGen [Text]
freeOut Text
label
         Direction
DirectionInout -> Text -> CodeGen [Text]
freeOut Text
label

  -- Whether memory ownership of the pointer passed in to the function
  -- will be assumed by the C->Haskell wrapper.
  where willWrap :: Arg -> Bool
        willWrap :: Arg -> Bool
willWrap = Arg -> Bool
argCallerAllocates

-- | Same thing as freeInArg, but called in case the call to C didn't
-- succeed. We thus free everything we allocated in preparation for
-- the call, including args that would have been transferred to C.
freeInArgOnError :: Arg -> Text -> Text -> ExcCodeGen [Text]
freeInArgOnError :: Arg -> Text -> Text -> ExcCodeGen [Text]
freeInArgOnError Arg
arg Text
label Text
len =
    case Arg -> Direction
direction Arg
arg of
      Direction
DirectionIn -> Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeInOnError (Arg -> Transfer
transfer Arg
arg) (Arg -> Type
argType Arg
arg) Text
label Text
len
      Direction
DirectionOut -> Text -> CodeGen [Text]
freeOut Text
label
      Direction
DirectionInout ->
          -- Caller-allocates arguments are like "in" arguments for
          -- memory management purposes.
          if Arg -> Bool
argCallerAllocates Arg
arg
          then Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeInOnError (Arg -> Transfer
transfer Arg
arg) (Arg -> Type
argType Arg
arg) Text
label Text
len
          else Text -> CodeGen [Text]
freeOut Text
label