-- | Marshalling of structs and unions.
module Data.GI.CodeGen.Struct ( genStructOrUnionFields
                              , genZeroStruct
                              , genZeroUnion
                              , extractCallbacksInStruct
                              , fixAPIStructs
                              , ignoreStruct
                              , genWrappedPtr
                              ) where

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

import Data.Maybe (mapMaybe, isJust, catMaybes)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as T

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Conversions
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock,
                                RelativeDocPosition(DocBeforeSymbol))
import Data.GI.CodeGen.SymbolNaming (upperName, lowerName,
                                     underscoresToCamelCase,
                                     qualifiedSymbol,
                                     callbackHaskellToForeign,
                                     callbackWrapperAllocator)

import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util

-- | Whether (not) to generate bindings for the given struct.
ignoreStruct :: Name -> Struct -> Bool
ignoreStruct :: Name -> Struct -> Bool
ignoreStruct (Name _ name :: Text
name) s :: Struct
s = (Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Struct -> Maybe Name
gtypeStructFor Struct
s) Bool -> Bool -> Bool
||
                               "Private" Text -> Text -> Bool
`T.isSuffixOf` Text
name) Bool -> Bool -> Bool
&&
                               (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Struct -> Bool
structForceVisible Struct
s)

-- | Whether the given type corresponds to an ignored struct.
isIgnoredStructType :: Type -> CodeGen Bool
isIgnoredStructType :: Type -> CodeGen Bool
isIgnoredStructType t :: Type
t =
  case Type
t of
    TInterface n :: Name
n -> do
      API
api <- Type -> CodeGen API
getAPI Type
t
      case API
api of
        APIStruct s :: Struct
s -> Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Struct -> Bool
ignoreStruct Name
n Struct
s)
        _ -> Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    _ -> Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Canonical name for the type of a callback type embedded in a
-- struct field.
fieldCallbackType :: Text -> Field -> Text
fieldCallbackType :: Text -> Field -> Text
fieldCallbackType structName :: Text
structName field :: Field
field =
    Text
structName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
underscoresToCamelCase (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "FieldCallback"

-- | Fix the interface names of callback fields in the struct to
-- correspond to the ones that we are going to generate.
fixCallbackStructFields :: Name -> Struct -> Struct
fixCallbackStructFields :: Name -> Struct -> Struct
fixCallbackStructFields (Name ns :: Text
ns structName :: Text
structName) s :: Struct
s = Struct
s {structFields :: [Field]
structFields = [Field]
fixedFields}
    where fixedFields :: [Field]
          fixedFields :: [Field]
fixedFields = (Field -> Field) -> [Field] -> [Field]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Field
fixField (Struct -> [Field]
structFields Struct
s)

          fixField :: Field -> Field
          fixField :: Field -> Field
fixField field :: Field
field =
              case Field -> Maybe Callback
fieldCallback Field
field of
                Nothing -> Field
field
                Just _ -> let n' :: Text
n' = Text -> Field -> Text
fieldCallbackType Text
structName Field
field
                          in Field
field {fieldType :: Type
fieldType = Name -> Type
TInterface (Text -> Text -> Name
Name Text
ns Text
n')}

-- | Fix the interface names of callback fields in an APIStruct to
-- correspond to the ones that we are going to generate. If something
-- other than an APIStruct is passed in we don't touch it.
fixAPIStructs :: (Name, API) -> (Name, API)
fixAPIStructs :: (Name, API) -> (Name, API)
fixAPIStructs (n :: Name
n, APIStruct s :: Struct
s) = (Name
n, Struct -> API
APIStruct (Struct -> API) -> Struct -> API
forall a b. (a -> b) -> a -> b
$ Name -> Struct -> Struct
fixCallbackStructFields Name
n Struct
s)
fixAPIStructs api :: (Name, API)
api = (Name, API)
api

-- | Extract the callback types embedded in the fields of structs, and
-- at the same time fix the type of the corresponding fields. Returns
-- the list of APIs associated to this struct, not including the
-- struct itself.
extractCallbacksInStruct :: (Name, API) -> [(Name, API)]
extractCallbacksInStruct :: (Name, API) -> [(Name, API)]
extractCallbacksInStruct (n :: Name
n@(Name ns :: Text
ns structName :: Text
structName), APIStruct s :: Struct
s)
    | Name -> Struct -> Bool
ignoreStruct Name
n Struct
s = []
    | Bool
otherwise =
        (Field -> Maybe (Name, API)) -> [Field] -> [(Name, API)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Field -> Maybe (Name, API)
callbackInField (Struct -> [Field]
structFields Struct
s)
            where callbackInField :: Field -> Maybe (Name, API)
                  callbackInField :: Field -> Maybe (Name, API)
callbackInField field :: Field
field = do
                    Callback
callback <- Field -> Maybe Callback
fieldCallback Field
field
                    let n' :: Text
n' = Text -> Field -> Text
fieldCallbackType Text
structName Field
field
                    (Name, API) -> Maybe (Name, API)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Name
Name Text
ns Text
n', Callback -> API
APICallback Callback
callback)
extractCallbacksInStruct _ = []

-- | The name of the type encoding the information for a field in a
-- struct/union.
infoType :: Name -> Field -> CodeGen Text
infoType :: Name -> Field -> CodeGen Text
infoType owner :: Name
owner field :: Field
field = do
  let name :: Text
name = Name -> Text
upperName Name
owner
  let fName :: Text
fName = (Text -> Text
underscoresToCamelCase (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
field
  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "FieldInfo"

-- | Whether a given field is an embedded struct/union.
isEmbedded :: Field -> ExcCodeGen Bool
isEmbedded :: Field -> ExcCodeGen Bool
isEmbedded field :: Field
field = do
  Maybe API
api <- Type -> CodeGen (Maybe API)
findAPI (Field -> Type
fieldType Field
field)
  case Maybe API
api of
    Just (APIStruct _) -> ExcCodeGen Bool
checkEmbedding
    Just (APIUnion _) -> ExcCodeGen Bool
checkEmbedding
    _ -> Bool -> ExcCodeGen Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    checkEmbedding :: ExcCodeGen Bool
    checkEmbedding :: ExcCodeGen Bool
checkEmbedding = case Field -> Maybe Bool
fieldIsPointer Field
field of
      Nothing -> Text -> ExcCodeGen Bool
forall a. Text -> ExcCodeGen a
badIntroError "Cannot determine whether the field is embedded."
      Just isPtr :: Bool
isPtr -> Bool -> ExcCodeGen Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
isPtr)

-- | Name for the getter function
fieldGetter :: Name -> Field -> Text
fieldGetter :: Name -> Field -> Text
fieldGetter name' :: Name
name' field :: Field
field = "get" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fName Field
field

-- | Generate documentation for the given getter.
getterDoc :: Name -> Field -> Text
getterDoc :: Name -> Field -> Text
getterDoc n :: Name
n field :: Field
field = [Text] -> Text
T.unlines [
    "Get the value of the “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "@” field."
  , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , ""
  , "@"
  , "'Data.GI.Base.Attributes.get' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
  , "@"]

-- Notice that when reading the field we return a copy of any embedded
-- structs, so modifications of the returned struct will not affect
-- the original struct. This is on purpose, in order to increase
-- safety (otherwise the garbage collector may decide to free the
-- parent structure while we are modifying the embedded one, and havoc
-- will ensue).
-- | Extract a field from a struct.
buildFieldReader :: Name -> Field -> ExcCodeGen ()
buildFieldReader :: Name -> Field -> ExcCodeGen ()
buildFieldReader n :: Name
n field :: Field
field = ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
  let name' :: Text
name' = Name -> Text
upperName Name
n
      getter :: Text
getter = Name -> Field -> Text
fieldGetter Name
n Field
field

  Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field
  Maybe Text
nullConvert <- if Bool
embedded
                 then Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                 else Type -> CodeGen (Maybe Text)
maybeNullConvert (Field -> Type
fieldType Field
field)
  Text
hType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
nullConvert
                        then TypeRep -> TypeRep
maybeT (TypeRep -> TypeRep)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
                        else Type -> CodeGen TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
  Text
fType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType (Field -> Type
fieldType Field
field)

  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Field -> Text
getterDoc Name
n Field
field)

  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
getter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: MonadIO m => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
              if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Text
hType
              then Text -> Text
parenthesize Text
hType
              else Text
hType
  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
getter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " s = liftIO $ withManagedPtr s $ \\ptr -> do"
  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    let peekedType :: Text
peekedType = if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Text
fType
                     then Text -> Text
parenthesize Text
fType
                     else Text
fType
    if Bool
embedded
    then Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "let val = ptr `plusPtr` " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
peekedType
    else Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "val <- peek (ptr `plusPtr` " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ") :: IO " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
peekedType
    Text
result <- case Maybe Text
nullConvert of
              Nothing -> Text
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert "val" (BaseCodeGen CGError Converter
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
fToH (Field -> Type
fieldType Field
field) Transfer
TransferNothing
              Just nullConverter :: Text
nullConverter -> do
                Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "result <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nullConverter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " val $ \\val' -> do"
                ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
                  Text
val' <- Text
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert "val'" (BaseCodeGen CGError Converter
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
fToH (Field -> Type
fieldType Field
field) Transfer
TransferNothing
                  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val'
                Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "result"
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
result

-- | Name for the setter function
fieldSetter :: Name -> Field -> Text
fieldSetter :: Name -> Field -> Text
fieldSetter name' :: Name
name' field :: Field
field = "set" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fName Field
field

-- | Generate documentation for the given setter.
setterDoc :: Name -> Field -> Text
setterDoc :: Name -> Field -> Text
setterDoc n :: Name
n field :: Field
field = [Text] -> Text
T.unlines [
    "Set the value of the “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "@” field."
  , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , ""
  , "@"
  , "'Data.GI.Base.Attributes.set' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " [ #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " 'Data.GI.Base.Attributes.:=' value ]"
  , "@"]

-- | Write a field into a struct. Note that, since we cannot know for
-- sure who will be deallocating the fields in the struct, we leave
-- any conversions that involve pointers to the caller. What this
-- means in practice is that scalar fields will get marshalled to/from
-- Haskell, while anything that involves pointers will be returned in
-- the C representation.
buildFieldWriter :: Name -> Field -> ExcCodeGen ()
buildFieldWriter :: Name -> Field -> ExcCodeGen ()
buildFieldWriter n :: Name
n field :: Field
field = ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
  let name' :: Text
name' = Name -> Text
upperName Name
n
  let setter :: Text
setter = Name -> Field -> Text
fieldSetter Name
n Field
field

  Bool
isPtr <- Type -> CodeGen Bool
typeIsPtr (Field -> Type
fieldType Field
field)

  Text
fType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType (Field -> Type
fieldType Field
field)
  Text
hType <- if Bool
isPtr
           then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
fType
           else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType (Field -> Type
fieldType Field
field)

  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Field -> Text
setterDoc Name
n Field
field)

  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
setter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: MonadIO m => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> "
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> m ()"
  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
setter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " s val = liftIO $ withManagedPtr s $ \\ptr -> do"
  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    Text
converted <- if Bool
isPtr
                 then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "val"
                 else Text
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert "val" (BaseCodeGen CGError Converter
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
hToF (Field -> Type
fieldType Field
field) Transfer
TransferNothing
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "poke (ptr `plusPtr` " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ") (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
converted Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

-- | Name for the clear function
fieldClear :: Name -> Field -> Text
fieldClear :: Name -> Field -> Text
fieldClear name' :: Name
name' field :: Field
field = "clear" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fName Field
field

-- | Documentation for the @clear@ method.
clearDoc :: Field -> Text
clearDoc :: Field -> Text
clearDoc field :: Field
field = [Text] -> Text
T.unlines [
  "Set the value of the “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "@” field to `Nothing`."
  , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , ""
  , "@"
  , "'Data.GI.Base.Attributes.clear'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
  , "@"]

-- | Write a @NULL@ into a field of a struct of type `Ptr`.
buildFieldClear :: Name -> Field -> Text -> ExcCodeGen ()
buildFieldClear :: Name -> Field -> Text -> ExcCodeGen ()
buildFieldClear n :: Name
n field :: Field
field nullPtr :: Text
nullPtr = ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
  let name' :: Text
name' = Name -> Text
upperName Name
n
  let clear :: Text
clear = Name -> Field -> Text
fieldClear Name
n Field
field

  Text
fType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType (Field -> Type
fieldType Field
field)

  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Field -> Text
clearDoc Field
field)

  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
clear Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: MonadIO m => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> m ()"
  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
clear Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " s = liftIO $ withManagedPtr s $ \\ptr -> do"
  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "poke (ptr `plusPtr` " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ") ("  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nullPtr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

-- | Return whether the given type corresponds to a callback that does
-- not throw exceptions. See [Note: Callables that throw] for the
-- reason why we do not try to wrap callbacks that throw exceptions.
isRegularCallback :: Type -> CodeGen Bool
isRegularCallback :: Type -> CodeGen Bool
isRegularCallback t :: Type
t@(TInterface _) = do
  API
api <- Type -> CodeGen API
getAPI Type
t
  case API
api of
    APICallback (Callback {cbCallable :: Callback -> Callable
cbCallable = Callable
callable}) ->
      Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Callable -> Bool
callableThrows Callable
callable)
    _ -> Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isRegularCallback _ = Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | The types accepted by the allocating set function
-- 'Data.GI.Base.Attributes.(:&=)'.
fieldTransferTypeConstraint :: Type -> CodeGen Text
fieldTransferTypeConstraint :: Type -> CodeGen Text
fieldTransferTypeConstraint t :: Type
t = do
  Bool
isPtr <- Type -> CodeGen Bool
typeIsPtr Type
t
  Bool
isRegularCallback <- Type -> CodeGen Bool
isRegularCallback Type
t
  Text
inType <- if Bool
isPtr Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isRegularCallback
            then TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType Type
t
            else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
isoHaskellType Type
t
  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "(~)" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Text
inType
                    then Text -> Text
parenthesize Text
inType
                    else Text
inType

-- | The type generated by 'Data.GI.Base.attrTransfer' for this
-- field. This type should satisfy the
-- 'Data.GI.Base.Attributes.AttrSetTypeConstraint' for the type.
fieldTransferType :: Type -> CodeGen Text
fieldTransferType :: Type -> CodeGen Text
fieldTransferType t :: Type
t = do
  Bool
isPtr <- Type -> CodeGen Bool
typeIsPtr Type
t
  Text
inType <- if Bool
isPtr
            then TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType Type
t
            else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType Type
t
  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Text
inType
           then Text -> Text
parenthesize Text
inType
           else Text
inType

-- | Generate the field transfer function, which marshals Haskell
-- values to types that we can set, even if we need to allocate memory.
genFieldTransfer :: Text -> Type -> CodeGen ()
genFieldTransfer :: Text -> Type -> CodeGen ()
genFieldTransfer var :: Text
var t :: Type
t@(TInterface tn :: Name
tn@(Name _ n :: Text
n)) = do
  Bool
isRegularCallback <- Type -> CodeGen Bool
isRegularCallback Type
t
  if Bool
isRegularCallback
    then do
      Text
wrapper <- Text -> Name -> CodeGen Text
qualifiedSymbol (Text -> Text
callbackHaskellToForeign Text
n) Name
tn
      Text
maker <- Text -> Name -> CodeGen Text
qualifiedSymbol (Text -> Text
callbackWrapperAllocator Text
n) Name
tn
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
maker Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text -> Text
parenthesize (Text
wrapper Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " Nothing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var)
    else Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var
genFieldTransfer var :: Text
var _ = Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var

-- | Haskell name for the field
fName :: Field -> Text
fName :: Field -> Text
fName = Text -> Text
underscoresToCamelCase (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName

-- | Label associated to the field.
labelName :: Field -> Text
labelName :: Field -> Text
labelName = Text -> Text
lcFirst  (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fName

-- | Support for modifying fields as attributes. Returns a tuple with
-- the name of the overloaded label to be used for the field, and the
-- associated info type.
genAttrInfo :: Name -> Field -> ExcCodeGen Text
genAttrInfo :: Name
-> Field
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
genAttrInfo owner :: Name
owner field :: Field
field = do
  Text
it <- Name -> Field -> CodeGen Text
infoType Name
owner Field
field
  let on :: Text
on = Name -> Text
upperName Name
owner

  Bool
isPtr <- Type -> CodeGen Bool
typeIsPtr (Field -> Type
fieldType Field
field)

  Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field
  Bool
isNullable <- Type -> CodeGen Bool
typeIsNullable (Field -> Type
fieldType Field
field)
  Text
outType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool -> Bool
not Bool
embedded Bool -> Bool -> Bool
&& Bool
isNullable
                          then TypeRep -> TypeRep
maybeT (TypeRep -> TypeRep)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
                          else Type -> CodeGen TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
  Text
inType <- if Bool
isPtr
            then TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType (Field -> Type
fieldType Field
field)
            else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType (Field -> Type
fieldType Field
field)
  Text
transferType <- Type -> CodeGen Text
fieldTransferType (Field -> Type
fieldType Field
field)
  Text
transferConstraint <- Type -> CodeGen Text
fieldTransferTypeConstraint (Field -> Type
fieldType Field
field)

  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it
  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "instance AttrInfo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrBaseTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = (~) " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
on
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrAllowedOps " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
             if Bool
embedded
             then " = '[ 'AttrGet]"
             else if Bool
isPtr
                  then " = '[ 'AttrSet, 'AttrGet, 'AttrClear]"
                  else " = '[ 'AttrSet, 'AttrGet]"
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrSetTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = (~) "
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Text
inType
                then Text -> Text
parenthesize Text
inType
                else Text
inType
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrTransferTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
transferConstraint
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrTransferType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
transferType
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrGetType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outType
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrLabel " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrOrigin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
on
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrGet = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Field -> Text
fieldGetter Name
owner Field
field
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrSet = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool -> Bool
not Bool
embedded
                             then Name -> Field -> Text
fieldSetter Name
owner Field
field
                             else "undefined"
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrConstruct = undefined"
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrClear = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool -> Bool
not Bool
embedded Bool -> Bool -> Bool
&& Bool
isPtr
                               then Name -> Field -> Text
fieldClear Name
owner Field
field
                               else "undefined"
    if Bool -> Bool
not Bool
embedded
      then do
          Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrTransfer _ v = do"
          ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> Type -> CodeGen ()
genFieldTransfer "v" (Field -> Type
fieldType Field
field)
      else Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrTransfer = undefined"

  ExcCodeGen ()
CodeGen ()
blank

  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    let labelProxy :: Text
labelProxy = Text -> Text
lcFirst Text
on Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcFirst (Field -> Text
fName Field
field)
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
labelProxy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: AttrLabelProxy \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcFirst (Field -> Text
fName Field
field) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
labelProxy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = AttrLabelProxy"

    HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection (Text -> HaddockSection) -> Text -> HaddockSection
forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Field -> Text
fName Field
field) Text
labelProxy

  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ "'(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

-- | Build code for a single field.
buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text)
buildFieldAttributes :: Name
-> Field
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
buildFieldAttributes n :: Name
n field :: Field
field
    | Bool -> Bool
not (Field -> Bool
fieldVisible Field
field) = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    | Type -> Bool
privateType (Field -> Type
fieldType Field
field) = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    | Bool
otherwise = ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except CGError))
  (Maybe Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ReaderT
   CodeGenConfig
   (StateT (CGState, ModuleInfo) (Except CGError))
   (Maybe Text)
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except CGError))
      (Maybe Text))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do

     -- We don't generate bindings for private and class structs, so
     -- do not generate bindings for fields pointing to class structs
     -- either.
     Bool
ignored <- Type -> CodeGen Bool
isIgnoredStructType (Field -> Type
fieldType Field
field)
     Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ignored (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
      Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError "Field type is an unsupported struct type"

     Maybe Text
nullPtr <- Type -> CodeGen (Maybe Text)
nullPtrForType (Field -> Type
fieldType Field
field)

     Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field

     HaddockSection -> Documentation -> CodeGen ()
addSectionDocumentation HaddockSection
docSection (Field -> Documentation
fieldDocumentation Field
field)

     Name -> Field -> ExcCodeGen ()
buildFieldReader Name
n Field
field
     HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection (Name -> Field -> Text
fieldGetter Name
n Field
field)

     Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
embedded) (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
         Name -> Field -> ExcCodeGen ()
buildFieldWriter Name
n Field
field
         HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection (Name -> Field -> Text
fieldSetter Name
n Field
field)

         case Maybe Text
nullPtr of
           Just null :: Text
null -> do
              Name -> Field -> Text -> ExcCodeGen ()
buildFieldClear Name
n Field
field Text
null
              HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection (Name -> Field -> Text
fieldClear Name
n Field
field)
           Nothing -> () -> ExcCodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

     Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CPPGuard
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (Name
-> Field
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
genAttrInfo Name
n Field
field)

    where privateType :: Type -> Bool
          privateType :: Type -> Bool
privateType (TInterface n :: Name
n) = "Private" Text -> Text -> Bool
`T.isSuffixOf` Name -> Text
name Name
n
          privateType _ = Bool
False

          docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection (Text -> HaddockSection) -> Text -> HaddockSection
forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Field -> Text
fName Field
field

-- | Generate code for the given list of fields.
genStructOrUnionFields :: Name -> [Field] -> CodeGen ()
genStructOrUnionFields :: Name -> [Field] -> CodeGen ()
genStructOrUnionFields n :: Name
n fields :: [Field]
fields = do
  let name' :: Text
name' = Name -> Text
upperName Name
n

  [Maybe Text]
attrs <- [Field]
-> (Field
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe Text))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Field]
fields ((Field
  -> ReaderT
       CodeGenConfig
       (StateT (CGState, ModuleInfo) (Except e))
       (Maybe Text))
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      [Maybe Text])
-> (Field
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe Text))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     [Maybe Text]
forall a b. (a -> b) -> a -> b
$ \field :: Field
field ->
      (CGError -> CodeGen (Maybe Text))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
-> CodeGen (Maybe Text)
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (\e :: CGError
e -> Text -> CodeGen ()
line ("-- XXX Skipped attribute for \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                               ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                               CGError -> Text
describeCGError CGError
e) BaseCodeGen e ()
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                   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)
                  (Name
-> Field
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
buildFieldAttributes Name
n Field
field)

  BaseCodeGen e ()
CodeGen ()
blank

  CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    let attrListName :: Text
attrListName = Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "AttributeList"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance O.HasAttributeList " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "type instance O.AttributeList " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrListName
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrListName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = ('[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
         Text -> [Text] -> Text
T.intercalate ", " ([Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text]
attrs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "] :: [(Symbol, *)])"

-- | Generate a constructor for a zero-filled struct/union of the given
-- type, using the boxed (or GLib, for unboxed types) allocator.
genZeroSU :: Name -> Int -> Bool -> CodeGen ()
genZeroSU :: Name -> Int -> Bool -> CodeGen ()
genZeroSU n :: Name
n size :: Int
size isBoxed :: Bool
isBoxed = BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      let name :: Text
name = Name -> Text
upperName Name
n
      let builder :: Text
builder = "newZero" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
          tsize :: Text
tsize = Int -> Text
forall a. Show a => a -> Text
tshow Int
size

      RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol ("Construct a `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                     "` struct initialized to zero.")

      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
builder Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: MonadIO m => m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
builder Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = liftIO $ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
           if Bool
isBoxed
           then "callocBoxedBytes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tsize Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " >>= wrapBoxed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
           else "wrappedPtrCalloc >>= wrapPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
      Text -> CodeGen ()
exportDecl Text
builder

      BaseCodeGen e ()
CodeGen ()
blank

      -- Overloaded "new"
      BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance tag ~ 'AttrSet => Constructible " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " tag where"
        BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
           Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "new _ attrs = do"
           BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
              Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "o <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
builder
              Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "GI.Attributes.set o attrs"
              Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return o"

-- | Specialization for structs of `genZeroSU`.
genZeroStruct :: Name -> Struct -> CodeGen ()
genZeroStruct :: Name -> Struct -> CodeGen ()
genZeroStruct n :: Name
n s :: Struct
s =
    Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllocationInfo -> AllocationOp
allocCalloc (Struct -> AllocationInfo
structAllocationInfo Struct
s) AllocationOp -> AllocationOp -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> AllocationOp
AllocationOp "none" Bool -> Bool -> Bool
&&
          Struct -> Int
structSize Struct
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$
    Name -> Int -> Bool -> CodeGen ()
genZeroSU Name
n (Struct -> Int
structSize Struct
s) (Struct -> Bool
structIsBoxed Struct
s)

-- | Specialization for unions of `genZeroSU`.
genZeroUnion :: Name -> Union -> CodeGen ()
genZeroUnion :: Name -> Union -> CodeGen ()
genZeroUnion n :: Name
n u :: Union
u =
    Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllocationInfo -> AllocationOp
allocCalloc (Union -> AllocationInfo
unionAllocationInfo Union
u ) AllocationOp -> AllocationOp -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> AllocationOp
AllocationOp "none" Bool -> Bool -> Bool
&&
          Union -> Int
unionSize Union
u Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$
    Name -> Int -> Bool -> CodeGen ()
genZeroSU Name
n (Union -> Int
unionSize Union
u) (Union -> Bool
unionIsBoxed Union
u)

-- | Construct a import with the given prefix.
prefixedForeignImport :: Text -> Text -> Text -> CodeGen Text
prefixedForeignImport :: Text -> Text -> Text -> CodeGen Text
prefixedForeignImport prefix :: Text
prefix symbol :: Text
symbol prototype :: Text
prototype = BaseCodeGen e Text -> BaseCodeGen e Text
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e Text -> BaseCodeGen e Text)
-> BaseCodeGen e Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ do
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "foreign import ccall \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prototype
  Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol)

-- | Same as `prefixedForeignImport`, but import a `FunPtr` to the symbol.
prefixedFunPtrImport :: Text -> Text -> Text -> CodeGen Text
prefixedFunPtrImport :: Text -> Text -> Text -> CodeGen Text
prefixedFunPtrImport prefix :: Text
prefix symbol :: Text
symbol prototype :: Text
prototype = BaseCodeGen e Text -> BaseCodeGen e Text
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e Text -> BaseCodeGen e Text)
-> BaseCodeGen e Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ do
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "foreign import ccall \"&" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: FunPtr (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prototype Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
  Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol)

-- | Generate the typeclass with information for how to
-- allocate/deallocate a given type.
genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen ()
genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen ()
genWrappedPtr n :: Name
n info :: AllocationInfo
info size :: Int
size = BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
  let name' :: Text
name' = Name -> Text
upperName Name
n

  let prefix :: Text -> Text
prefix = \op :: Text
op -> "_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_"

  Bool -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& AllocationInfo -> AllocationOp
allocFree AllocationInfo
info AllocationOp -> AllocationOp -> Bool
forall a. Eq a => a -> a -> Bool
== AllocationOp
AllocationOpUnknown) (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
       Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?"

  Text
calloc <- case AllocationInfo -> AllocationOp
allocCalloc AllocationInfo
info of
              AllocationOp "none" ->
                  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return ("error \"calloc not permitted for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"")
              AllocationOp op :: Text
op ->
                  Text -> Text -> Text -> CodeGen Text
prefixedForeignImport (Text -> Text
prefix "calloc") Text
op "IO (Ptr a)"
              AllocationOpUnknown ->
                  if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
                  then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return ("callocBytes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
size)
                  else Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "return nullPtr"

  Text
copy <- case AllocationInfo -> AllocationOp
allocCopy AllocationInfo
info of
            AllocationOp op :: Text
op -> do
                Text
copy <- Text -> Text -> Text -> CodeGen Text
prefixedForeignImport (Text -> Text
prefix "copy") Text
op "Ptr a -> IO (Ptr a)"
                Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return ("\\p -> withManagedPtr p (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
copy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                        " >=> wrapPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")
            AllocationOpUnknown ->
                if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
                then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return ("\\p -> withManagedPtr p (copyBytes "
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
size Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " >=> wrapPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")
                else Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "return"

  Text
free <- case AllocationInfo -> AllocationOp
allocFree AllocationInfo
info of
            AllocationOp op :: Text
op -> ("Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                Text -> Text -> Text -> CodeGen Text
prefixedFunPtrImport (Text -> Text
prefix "free") Text
op "Ptr a -> IO ()"
            AllocationOpUnknown ->
                if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
                then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Just ptr_to_g_free"
                else Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Nothing"

  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance WrappedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "wrappedPtrCalloc = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
calloc
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "wrappedPtrCopy = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
copy
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "wrappedPtrFree = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
free

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
hsBoot (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance WrappedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"