-- 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 TUTF8) = Text -> Maybe Text
forall a. a -> Maybe a
Just "freeMem"
basicFreeFn (TBasicType TFileName) = Text -> Maybe Text
forall a. a -> Maybe a
Just "freeMem"
basicFreeFn (TBasicType _) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (TInterface _) = Maybe Text
forall a. Maybe a
Nothing
-- Just passed along
basicFreeFn (TCArray False (-1) (-1) (TBasicType TUInt8)) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (TCArray{}) = Text -> Maybe Text
forall a. a -> Maybe a
Just "freeMem"
basicFreeFn (TGArray _) = Text -> Maybe Text
forall a. a -> Maybe a
Just "unrefGArray"
basicFreeFn (TPtrArray _) = Text -> Maybe Text
forall a. a -> Maybe a
Just "unrefPtrArray"
basicFreeFn (Type
TByteArray) = Text -> Maybe Text
forall a. a -> Maybe a
Just "unrefGByteArray"
basicFreeFn (TGList _) = Text -> Maybe Text
forall a. a -> Maybe a
Just "g_list_free"
basicFreeFn (TGSList _) = Text -> Maybe Text
forall a. a -> Maybe a
Just "g_slist_free"
basicFreeFn (TGHash _ _) = Text -> Maybe Text
forall a. a -> Maybe a
Just "unrefGHashTable"
basicFreeFn (Type
TError) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (Type
TVariant) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (Type
TParamSpec) = Maybe Text
forall a. Maybe a
Nothing
basicFreeFn (TGClosure _) = 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 TUTF8) _ = 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 "freeMem"
basicFreeFnOnError (TBasicType TFileName) _ = 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 "freeMem"
basicFreeFnOnError (TBasicType _) _ = 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 TVariant transfer :: 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 "unrefGVariant"
             else Maybe Text
forall a. Maybe a
Nothing
basicFreeFnOnError TParamSpec transfer :: 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 "unrefGParamSpec"
             else Maybe Text
forall a. Maybe a
Nothing
basicFreeFnOnError (TGClosure _) transfer :: 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 "B.GClosure.unrefGClosure"
             else Maybe Text
forall a. Maybe a
Nothing
basicFreeFnOnError t :: Type
t@(TInterface _) transfer :: Transfer
transfer = do
  Maybe API
api <- Type -> CodeGen (Maybe API)
findAPI Type
t
  case Maybe API
api of
    Just (APIObject _) -> 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 "unrefObject"
                            else do
                              Text -> CodeGen ()
line "-- 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 _) -> 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 "unrefObject"
                               else do
                                 Text -> CodeGen ()
line "-- 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 u :: 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 "freeBoxed"
                              else do
                                Text -> CodeGen ()
line "-- 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 s :: 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 "freeBoxed"
                               else do
                                 Text -> CodeGen ()
line "-- 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 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 False (-1) (-1) (TBasicType TUInt8)) _ = 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{}) _ = 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 "freeMem"
basicFreeFnOnError (TGArray _) _ = 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 "unrefGArray"
basicFreeFnOnError (TPtrArray _) _ = 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 "unrefPtrArray"
basicFreeFnOnError (Type
TByteArray) _ = 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 "unrefGByteArray"
basicFreeFnOnError (TGList _) _ = 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 "g_list_free"
basicFreeFnOnError (TGSList _) _ = 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 "g_slist_free"
basicFreeFnOnError (TGHash _ _) _ = 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 "unrefGHashTable"
basicFreeFnOnError (Type
TError) _ = 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 t :: Type
t label :: Text
label =
    case Type -> Maybe Text
basicFreeFn Type
t of
      Nothing -> [Text]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just fn :: Text
fn -> [Text]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except 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
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 t :: Type
t label :: Text
label free :: Text
free =
    case Type -> Text -> Maybe (Type, Text)
elementTypeAndMap Type
t Text
forall a. HasCallStack => a
undefined of
      Nothing -> Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
free
      Just (TCArray False _ _ _, _) ->
          Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "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
<>
                            "\" is an array of unknown length."
      Just (innerType :: Type
innerType, mapFn :: Text
mapFn) -> do
        let elemFree :: Text
elemFree = "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
                  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
<> " e"
                  Just elemInnerFree :: Text
elemInnerFree -> do
                     Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
elemFree Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " 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
forall a. Semigroup a => a -> a -> a
<> Text
elemInnerFree Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " e >> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
free Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " 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 t :: Type
t label :: Text
label = case Type -> Maybe Text
basicFreeFn Type
t of
                      Nothing -> Maybe Text -> ExcCodeGen (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                      Just free :: 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 t :: Type
t label :: Text
label transfer :: 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
        Nothing -> Maybe Text -> ExcCodeGen (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
        Just free :: 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 t :: Type
t label :: Text
label len :: Text
len =
   case Type -> Text -> Maybe (Type, Text)
elementTypeAndMap Type
t Text
len of
     Nothing -> [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
     Just (inner :: Type
inner, mapFn :: 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
                   Nothing -> [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                   Just innerFree :: 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
forall a. Semigroup a => a -> a -> a
<> Text
innerFree Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " 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
transfer (TGHash _ _) label :: Text
label _ = Transfer -> Text -> BaseCodeGen CGError ()
freeGHashTable Transfer
transfer Text
label
freeContainerType transfer :: Transfer
transfer t :: Type
t label :: Text
label len :: 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 TransferNothing _ = () -> BaseCodeGen CGError ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
freeGHashTable TransferContainer label :: Text
label =
    Text -> BaseCodeGen CGError ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "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 TransferEverything label :: Text
label =
    Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "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
transfer t :: Type
t label :: Text
label len :: Text
len =
    case Type -> Text -> Maybe (Type, Text)
elementTypeAndMap Type
t Text
len of
      Nothing -> [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just (inner :: Type
inner, mapFn :: 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
                   Nothing -> [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                   Just innerFree :: 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
forall a. Semigroup a => a -> a -> a
<> Text
innerFree Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " 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
transfer (TGHash _ _) label :: Text
label _ =
    Transfer -> Text -> ExcCodeGen [Text]
freeInGHashTable Transfer
transfer Text
label
freeIn transfer :: Transfer
transfer t :: Type
t label :: Text
label len :: Text
len =
    case Transfer
transfer of
      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
      TransferContainer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeElements Type
t Text
label Text
len
      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
transfer (TGHash _ _) label :: Text
label _ =
    Transfer -> Text -> ExcCodeGen [Text]
freeInGHashTable Transfer
transfer Text
label
freeInOnError transfer :: Transfer
transfer t :: Type
t label :: Text
label len :: 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 TransferEverything _ = [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
freeInGHashTable TransferContainer label :: Text
label =
    Text -> ExcCodeGen [Text]
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen [Text]) -> Text -> ExcCodeGen [Text]
forall a b. (a -> b) -> a -> b
$ "Hash table argument with TransferContainer? "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label
freeInGHashTable TransferNothing label :: Text
label = [Text] -> ExcCodeGen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ["unrefGHashTable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label]

freeOut :: Text -> CodeGen [Text]
freeOut :: Text -> CodeGen [Text]
freeOut label :: Text
label = [Text]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ["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
arg label :: Text
label len :: 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
         DirectionIn -> Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeIn (Arg -> Transfer
transfer Arg
arg) (Arg -> Type
argType Arg
arg) Text
label Text
len
         DirectionOut -> Text -> CodeGen [Text]
freeOut Text
label
         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
arg label :: Text
label len :: Text
len =
    case Arg -> Direction
direction Arg
arg of
      DirectionIn -> Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]
freeInOnError (Arg -> Transfer
transfer Arg
arg) (Arg -> Type
argType Arg
arg) Text
label Text
len
      DirectionOut -> Text -> CodeGen [Text]
freeOut Text
label
      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