diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,5 +1,5 @@ name: haskell-gi -version: 0.12 +version: 0.13 synopsis: Generate Haskell bindings for GObject Introspection capable libraries description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably Gtk+, but many other libraries in the GObject ecosystem provide introspection data too. @@ -36,7 +36,7 @@ bytestring, xdg-basedir, xml-conduit >= 1.3.0, - haskell-gi-base == 0.12.*, + haskell-gi-base == 0.13.*, text >= 1.0, free @@ -66,7 +66,6 @@ GI.GIR.Union, GI.GIR.XMLUtils, GI.API, - GI.Attributes, GI.Cabal, GI.Callable, GI.Code, @@ -79,6 +78,8 @@ GI.Inheritance, GI.LibGIRepository, GI.OverloadedSignals, + GI.OverloadedLabels, + GI.OverloadedMethods, GI.Overrides, GI.PkgConfig, GI.ProjectInfo, diff --git a/src/GI/API.hs b/src/GI/API.hs --- a/src/GI/API.hs +++ b/src/GI/API.hs @@ -213,8 +213,9 @@ let (name, version) = S.elemAt 0 requested doc <- readGiRepository verbose name (Just version) extraPaths let newLoaded = M.insert (name, version) doc loaded + loadedSet = S.fromList (M.keys newLoaded) newRequested = S.union requested (documentListIncludes doc) - notYetLoaded = S.filter (/= (name, version)) newRequested + notYetLoaded = S.difference newRequested loadedSet loadDependencies verbose notYetLoaded newLoaded extraPaths -- | Load a given GIR file and recursively its dependencies diff --git a/src/GI/Attributes.hs b/src/GI/Attributes.hs deleted file mode 100644 --- a/src/GI/Attributes.hs +++ /dev/null @@ -1,54 +0,0 @@ -module GI.Attributes - ( genAllAttributes - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Control.Monad (forM_) -import qualified Data.Set as S -import Data.Text (Text) - -import GI.API -import GI.Code -import GI.SymbolNaming -import GI.Util (lcFirst) - --- A list of distinct property names for all GObjects appearing in the --- given list of APIs. -findObjectPropNames :: [(Name, API)] -> CodeGen [Text] -findObjectPropNames apis = S.toList <$> go apis S.empty - where - go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text) - go [] set = return set - go ((_, api):apis) set = - case api of - APIInterface iface -> - go apis $ insertProps (ifProperties iface) set - APIObject object -> - go apis $ insertProps (objProperties object) set - _ -> go apis set - - insertProps :: [Property] -> S.Set Text -> S.Set Text - insertProps props set = S.union set ((S.fromList . map propName) props) - -genPropertyAttr :: Text -> CodeGen () -genPropertyAttr pName = group $ do - line $ "-- Property \"" <> pName <> "\"" - let name = hyphensToCamelCase pName - line $ "_" <> lcFirst name <> " :: Proxy \"" <> pName <> "\"" - line $ "_" <> lcFirst name <> " = Proxy" - exportToplevel ("_" <> lcFirst name) - -genAllAttributes :: [(Name, API)] -> CodeGen () -genAllAttributes allAPIs = do - setLanguagePragmas ["DataKinds"] - setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport] - - line $ "import Data.Proxy (Proxy(..))" - blank - - propNames <- findObjectPropNames allAPIs - forM_ propNames $ \name -> do - genPropertyAttr name - blank diff --git a/src/GI/Cabal.hs b/src/GI/Cabal.hs --- a/src/GI/Cabal.hs +++ b/src/GI/Cabal.hs @@ -117,8 +117,9 @@ -- | Try to generate the cabal project. In case of error return the -- corresponding error string. -genCabalProject :: GIRInfo -> [GIRInfo] -> [Text] -> CodeGen (Maybe Text) -genCabalProject gir deps exposedModules = +genCabalProject :: GIRInfo -> [GIRInfo] -> [Text] -> BaseVersion -> + CodeGen (Maybe Text) +genCabalProject gir deps exposedModules minBaseVersion = handleCGExc (return . Just . describeCGError) $ do cfg <- config let pkMap = pkgConfigMap (overrides cfg) @@ -148,15 +149,16 @@ line $ "library" indent $ do line $ padTo 20 "default-language:" <> "Haskell2010" - line $ padTo 20 "default-extensions:" <> "OverloadedStrings, NegativeLiterals, ConstraintKinds, TypeFamilies, MultiParamTypeClasses, KindSignatures, FlexibleInstances, UndecidableInstances, DataKinds, FlexibleContexts" - line $ padTo 20 "other-extensions:" <> "PatternSynonyms ScopedTypeVariables, ViewPatterns" + line $ padTo 20 "default-extensions:" <> "ScopedTypeVariables, CPP, OverloadedStrings, NegativeLiterals, ConstraintKinds, TypeFamilies, MultiParamTypeClasses, KindSignatures, FlexibleInstances, UndecidableInstances, DataKinds, FlexibleContexts" + line $ padTo 20 "other-extensions:" <> "PatternSynonyms ViewPatterns" line $ padTo 20 "ghc-options:" <> "-fno-warn-unused-imports -fno-warn-warnings-deprecations" line $ padTo 20 "exposed-modules:" <> head exposedModules forM_ (tail exposedModules) $ \mod -> line $ padTo 20 "" <> mod line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= " <> tshow major <> "." <> tshow minor - line $ padTo 20 "build-depends: base >= 4.7 && <5," + line $ padTo 20 "build-depends: base >= " + <> showBaseVersion minBaseVersion <> " && <5," indent $ do line $ "haskell-gi-base >= " <> tshow haskellGIAPIVersion <> "." <> tshow haskellGIMinor diff --git a/src/GI/Callable.hs b/src/GI/Callable.hs --- a/src/GI/Callable.hs +++ b/src/GI/Callable.hs @@ -5,6 +5,8 @@ , hOutType , arrayLengths , arrayLengthsMap + , callableSignature + , fixupCallerAllocates , wrapMaybe , inArgInterfaces @@ -17,6 +19,7 @@ import Data.Bool (bool) import Data.List (nub, (\\)) import Data.Maybe (isJust) +import Data.Tuple (swap) import Data.Typeable (TypeRep, typeOf) import qualified Data.Map as Map import qualified Data.Text as T @@ -65,12 +68,14 @@ fArgStr arg = do ft <- foreignType $ argType arg weAlloc <- isJust <$> requiresAlloc (argType arg) - let ft' = if direction arg == DirectionIn || weAlloc then + let ft' = if direction arg == DirectionIn || weAlloc + || argCallerAllocates arg + then ft else ptr ft let start = tshow ft' <> " -> " - return $ padTo 40 start <> "-- " <> (argName arg) + return $ padTo 40 start <> "-- " <> (argCName arg) <> " : " <> tshow (argType arg) last = tshow <$> io <$> case returnType callable of TBasicType TVoid -> return $ typeOf () @@ -94,7 +99,7 @@ nullable <- isNullable (argType arg) if nullable then return True - else badIntroError $ "argument \"" <> (argName arg) + else badIntroError $ "argument \"" <> (argCName arg) <> "\" is not of nullable type (" <> tshow (argType arg) <> "), but it is marked as such." else return False @@ -171,8 +176,8 @@ -- Read the length of an array into the corresponding variable. readInArrayLength :: Arg -> Arg -> ExcCodeGen () readInArrayLength array length = do - let lvar = escapeReserved $ argName length - avar = escapeReserved $ argName array + let lvar = escapedArgName length + avar = escapedArgName array wrapMaybe array >>= bool (do al <- computeArrayLength avar (argType array) @@ -189,12 +194,12 @@ -- variable. checkInArrayLength :: Name -> Arg -> Arg -> Arg -> ExcCodeGen () checkInArrayLength n array length previous = do - name <- lowerName n - let funcName = namespace n <> "." <> name - lvar = escapeReserved $ argName length - avar = escapeReserved $ argName array + let name = lowerName n + funcName = namespace n <> "." <> name + lvar = escapedArgName length + avar = escapedArgName array expectedLength = avar <> "_expected_length_" - pvar = escapeReserved $ argName previous + pvar = escapedArgName previous wrapMaybe array >>= bool (do al <- computeArrayLength avar (argType array) @@ -229,13 +234,13 @@ where actions :: ExcCodeGen [[Text]] actions = forM (args callable) $ \arg -> - case Map.lookup (escapeReserved $ argName arg) nameMap of + case Map.lookup (escapedArgName arg) nameMap of Just name -> freeFn arg name $ -- Pass in the length argument in case it's needed. case argType arg of TCArray False (-1) (-1) _ -> undefined TCArray False (-1) length _ -> - escapeReserved $ argName $ (args callable)!!length + escapedArgName $ (args callable)!!length _ -> undefined Nothing -> badIntroError $ "freeInArgs: do not understand " <> tshow arg @@ -263,7 +268,7 @@ case direction arg of DirectionIn -> if arg `elem` omitted - then return . escapeReserved . argName $ arg + then return . escapedArgName $ arg else if isCallback then prepareInCallback arg else prepareInArg arg @@ -272,7 +277,7 @@ prepareInArg :: Arg -> ExcCodeGen Text prepareInArg arg = do - let name = escapeReserved $ argName arg + let name = escapedArgName arg wrapMaybe arg >>= bool (convert name $ hToF (argType arg) (transfer arg)) (do @@ -291,7 +296,7 @@ -- Callbacks are a fairly special case, we treat them separately. prepareInCallback :: Arg -> ExcCodeGen Text prepareInCallback arg = do - let name = escapeReserved $ argName arg + let name = escapedArgName arg ptrName = "ptr" <> name scope = argScope arg @@ -358,14 +363,17 @@ -- The semantics of this case are somewhat undefined. (notImplementedError "Nullable inout structs not supported") Nothing -> do - name'' <- genConversion (prime name') $ - literal $ M $ "allocMem :: " <> tshow (io $ ptr ft) - line $ "poke " <> name'' <> " " <> name' - return name'' + if argCallerAllocates arg + then return name' + else do + name'' <- genConversion (prime name') $ + literal $ M $ "allocMem :: " <> tshow (io $ ptr ft) + line $ "poke " <> name'' <> " " <> name' + return name'' prepareOutArg :: Arg -> CodeGen Text prepareOutArg arg = do - let name = escapeReserved $ argName arg + let name = escapedArgName arg ft <- foreignType $ argType arg allocInfo <- requiresAlloc (argType arg) case allocInfo of @@ -382,9 +390,9 @@ -- Convert a non-zero terminated out array, stored in a variable -- named "aname", into the corresponding Haskell object. convertOutCArray :: Callable -> Type -> Text -> Map.Map Text Text -> - Transfer -> ExcCodeGen Text + Transfer -> (Text -> Text) -> ExcCodeGen Text convertOutCArray callable t@(TCArray False fixed length _) aname - nameMap transfer = do + nameMap transfer primeLength = do if fixed > -1 then do unpacked <- convert aname $ unpackCArray (tshow fixed) t transfer @@ -394,26 +402,26 @@ else do when (length == -1) $ badIntroError $ "Unknown length for \"" <> aname <> "\"" - let lname = escapeReserved $ argName $ (args callable)!!length + let lname = escapedArgName $ (args callable)!!length lname' <- case Map.lookup lname nameMap of Just n -> return n Nothing -> badIntroError $ "Couldn't find out array length " <> lname - let lname'' = prime lname' + let lname'' = primeLength lname' unpacked <- convert aname $ unpackCArray lname'' t transfer -- Free the memory associated with the array freeContainerType transfer t aname lname'' return unpacked -- Remove the warning, this should never be reached. -convertOutCArray _ t _ _ _ = +convertOutCArray _ t _ _ _ _ = terror $ "convertOutCArray : unexpected " <> tshow t -- Read the array lengths for out arguments. readOutArrayLengths :: Callable -> Map.Map Text Text -> ExcCodeGen () readOutArrayLengths callable nameMap = do - let lNames = nub $ map (escapeReserved . argName) $ + let lNames = nub $ map escapedArgName $ filter ((/= DirectionIn) . direction) $ arrayLengths callable forM_ lNames $ \lname -> do @@ -428,7 +436,7 @@ -- C function was called. touchInArg :: Arg -> ExcCodeGen () touchInArg arg = when (direction arg /= DirectionOut) $ do - let name = escapeReserved $ argName arg + let name = escapedArgName arg case elementType (argType arg) of Just a -> do managed <- isManaged a @@ -480,8 +488,8 @@ <> "\n" <> T.pack (ppShow m) <> "\n" <> tshow closure Just cb -> do - let closureName = escapeReserved $ argName $ (args callable)!!closure - n = escapeReserved $ argName cb + let closureName = escapedArgName $ (args callable)!!closure + n = escapedArgName cb n' <- case Map.lookup n nameMap of Just n -> return n Nothing -> badIntroError $ "Cannot find closure name!! " @@ -497,7 +505,7 @@ "ScopeTypeNotified without destructor! " <> T.pack (ppShow callable) k -> let destroyName = - escapeReserved . argName $ (args callable)!!k in + escapedArgName $ (args callable)!!k in line $ "let " <> destroyName <> " = safeFreeFunPtrPtr" ScopeTypeAsync -> line $ "let " <> closureName <> " = nullPtr" @@ -506,7 +514,7 @@ freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen () freeCallCallbacks callable nameMap = forM_ (args callable) $ \arg -> do - let name = escapeReserved $ argName arg + let name = escapedArgName arg name' <- case Map.lookup name nameMap of Just n -> return n Nothing -> badIntroError $ "Could not find " <> name @@ -515,123 +523,70 @@ when (argScope arg == ScopeTypeCall) $ line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name' -hSignature :: [Arg] -> TypeRep -> ExcCodeGen () -hSignature hInArgs retType = do - (argConstraints, types) <- inArgInterfaces hInArgs +formatHSignature :: Callable -> Bool -> ExcCodeGen () +formatHSignature callable throwsGError = do + (constraints, vars) <- callableSignature callable throwsGError indent $ do - line $ "(" <> T.intercalate ", " ("MonadIO m" : argConstraints) <> ") =>" - forM_ (zip types hInArgs) $ \(t, a) -> - line $ withComment (t <> " ->") $ (argName a) - line . tshow $ "m" `con` [retType] + line $ "(" <> T.intercalate ", " constraints <> ") =>" + forM_ (zip ("" : repeat "-> ") vars) $ \(prefix, (t, name)) -> + line $ withComment (prefix <> t) name -genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen () -genCallable n symbol callable throwsGError = do - group $ do - line $ "-- Args : " <> (tshow $ args callable) - line $ "-- Lengths : " <> (tshow $ arrayLengths callable) - line $ "-- hInArgs : " <> tshow hInArgs - line $ "-- returnType : " <> (tshow $ returnType callable) - line $ "-- throws : " <> (tshow throwsGError) - line $ "-- Skip return : " <> (tshow $ skipReturn callable) - when (skipReturn callable && returnType callable /= TBasicType TBoolean) $ - do line "-- XXX return value ignored, but it is not a boolean." - line "-- This may be a memory leak?" - mkForeignImport symbol callable throwsGError - blank - wrapper +-- | The Haskell signature for the given callable. It returns a tuple +-- ([constraints], [(type, argname)]). +callableSignature :: Callable -> Bool -> ExcCodeGen ([Text], [(Text, Text)]) +callableSignature callable throwsGError = do + let (hInArgs, _) = callableHInArgs callable + (argConstraints, types) <- inArgInterfaces hInArgs + let constraints = ("MonadIO m" : argConstraints) + ignoreReturn = skipRetVal callable throwsGError + outType <- hOutType callable (callableHOutArgs callable) ignoreReturn + let allNames = map escapedArgName hInArgs ++ ["result"] + allTypes = types ++ [tshow ("m" `con` [outType])] + return (constraints, zip allTypes allNames) - where - inArgs = filter ((/= DirectionOut) . direction) $ args callable - -- We do not expose user_data arguments, destroynotify arguments, - -- and C array length arguments to Haskell code. - closures = map (args callable!!) . filter (/= -1) . map argClosure $ inArgs - destroyers = map (args callable!!) . filter (/= -1) . map argDestroy $ inArgs - omitted = arrayLengths callable <> closures <> destroyers - hInArgs = filter (`notElem` omitted) inArgs - outArgs = filter ((/= DirectionIn) . direction) $ args callable - hOutArgs = filter (`notElem` (arrayLengths callable)) outArgs +-- | "In" arguments for the given callable on the Haskell side, +-- together with the omitted arguments. +callableHInArgs :: Callable -> ([Arg], [Arg]) +callableHInArgs callable = + let inArgs = filter ((/= DirectionOut) . direction) $ args callable + -- We do not expose user_data arguments, + -- destroynotify arguments, and C array length + -- arguments to Haskell code. + closures = map (args callable!!) . filter (/= -1) . map argClosure $ inArgs + destroyers = map (args callable!!) . filter (/= -1) . map argDestroy $ inArgs + omitted = arrayLengths callable <> closures <> destroyers + in (filter (`notElem` omitted) inArgs, omitted) - ignoreReturn = skipRetVal callable throwsGError +-- | "Out" arguments for the given callable on the Haskell side. +callableHOutArgs :: Callable -> [Arg] +callableHOutArgs callable = + let outArgs = filter ((/= DirectionIn) . direction) $ args callable + in filter (`notElem` (arrayLengths callable)) outArgs - wrapper = group $ do - let argName' = escapeReserved . argName - name <- lowerName n - exportMethod name name - line $ deprecatedPragma name $ callableDeprecated callable - line $ name <> " ::" - hSignature hInArgs =<< hOutType callable hOutArgs ignoreReturn - line $ name <> " " <> T.intercalate " " (map argName' hInArgs) <> " = liftIO $ do" +-- | Convert the result of the foreign call to Haskell. +convertResult :: Callable -> Text -> Bool -> Map.Map Text Text -> + ExcCodeGen Text +convertResult callable symbol ignoreReturn nameMap = + if ignoreReturn || returnType callable == TBasicType TVoid + then return (error "convertResult: unreachable code reached, bug!") + else do + if returnMayBeNull callable + then do + line $ "maybeResult <- convertIfNonNull result $ \\result' -> do" indent $ do - readInArrayLengths n callable hInArgs - inArgNames <- forM (args callable) $ \arg -> - prepareArgForCall omitted arg - -- Map from argument names to names passed to the C function - let nameMap = Map.fromList $ flip zip inArgNames - $ map argName' $ args callable - prepareClosures callable nameMap - if throwsGError - then do - line "onException (do" - indent $ do - invokeCFunction inArgNames - readOutArrayLengths callable nameMap - result <- convertResult nameMap - pps <- convertOut nameMap - freeCallCallbacks callable nameMap - forM_ (args callable) touchInArg - mapM_ line =<< freeInArgs callable nameMap - returnResult result pps - line " ) (do" - indent $ do - freeCallCallbacks callable nameMap - actions <- freeInArgsOnError callable nameMap - case actions of - [] -> line $ "return ()" - _ -> mapM_ line actions - line " )" - else do - invokeCFunction inArgNames - readOutArrayLengths callable nameMap - result <- convertResult nameMap - pps <- convertOut nameMap - freeCallCallbacks callable nameMap - forM_ (args callable) touchInArg - mapM_ line =<< freeInArgs callable nameMap - returnResult result pps - - invokeCFunction argNames = do - let returnBind = case returnType callable of - TBasicType TVoid -> "" - _ -> if ignoreReturn - then "_ <- " - else "result <- " - maybeCatchGErrors = if throwsGError - then "propagateGError $ " - else "" - line $ returnBind <> maybeCatchGErrors - <> symbol <> (T.concat . map (" " <>)) argNames - - convertResult :: Map.Map Text Text -> ExcCodeGen Text - convertResult nameMap = - if ignoreReturn || returnType callable == TBasicType TVoid - then return (error "convertResult: unreachable code reached, bug!") - else do - if returnMayBeNull callable - then do - line $ "maybeResult <- convertIfNonNull result $ \\result' -> do" - indent $ do - converted <- unwrappedConvertResult "result'" - line $ "return " <> converted - return "maybeResult" - else do - nullable <- isNullable (returnType callable) - when nullable $ - line $ "checkUnexpectedReturnNULL \"" <> symbol - <> "\" result" - unwrappedConvertResult "result" + converted <- unwrappedConvertResult "result'" + line $ "return " <> converted + return "maybeResult" + else do + nullable <- isNullable (returnType callable) + when nullable $ + line $ "checkUnexpectedReturnNULL \"" <> symbol + <> "\" result" + unwrappedConvertResult "result" - where - unwrappedConvertResult rname = case returnType callable of + where + unwrappedConvertResult rname = + case returnType callable of -- Arrays without length information are just passed -- along. TCArray False (-1) (-1) _ -> return rname @@ -639,69 +594,218 @@ -- length, so we deal with them directly. t@(TCArray False _ _ _) -> convertOutCArray callable t rname nameMap - (returnTransfer callable) + (returnTransfer callable) prime t -> do result <- convert rname $ fToH (returnType callable) (returnTransfer callable) freeContainerType (returnTransfer callable) t rname undefined return result - convertOut :: Map.Map Text Text -> ExcCodeGen [Text] - convertOut nameMap = do - -- Convert out parameters and result - forM hOutArgs $ \arg -> do - let name = escapeReserved $ argName arg - inName <- case Map.lookup name nameMap of - Just name' -> return name' - Nothing -> badIntroError $ "Parameter " <> name <> " not found!" - case argType arg of - -- Passed along as a raw pointer - TCArray False (-1) (-1) _ -> genConversion inName $ apply $ M "peek" - t@(TCArray False _ _ _) -> do - aname' <- genConversion inName $ apply $ M "peek" - let wrapArray a = convertOutCArray callable t a - nameMap (transfer arg) - wrapMaybe arg >>= bool - (wrapArray aname') - (do line $ "maybe" <> ucFirst aname' - <> " <- convertIfNonNull " <> aname' - <> " $ \\" <> prime aname' <> " -> do" - indent $ do - wrapped <- wrapArray (prime aname') - line $ "return " <> wrapped - return $ "maybe" <> ucFirst aname') - t -> do - weAlloc <- isJust <$> requiresAlloc t - peeked <- if weAlloc - then return inName - else genConversion inName $ apply $ M "peek" - -- If we alloc we always take control of the resulting - -- memory, otherwise we may leak. - let transfer' = if weAlloc - then TransferEverything - else transfer arg - result <- do - let wrap ptr = convert ptr $ fToH (argType arg) transfer' - wrapMaybe arg >>= bool - (wrap peeked) - (do line $ "maybe" <> ucFirst peeked - <> " <- convertIfNonNull " <> peeked - <> " $ \\" <> prime peeked <> " -> do" - indent $ do - wrapped <- wrap (prime peeked) - line $ "return " <> wrapped - return $ "maybe" <> ucFirst peeked) - -- Free the memory associated with the out argument - freeContainerType transfer' t peeked undefined - return result +-- | Marshal a foreign out argument to Haskell, returning the name of +-- the variable containing the converted Haskell value. +convertOutArg :: Callable -> Map.Map Text Text -> Arg -> ExcCodeGen Text +convertOutArg callable nameMap arg = do + let name = escapedArgName arg + inName <- case Map.lookup name nameMap of + Just name' -> return name' + Nothing -> badIntroError $ "Parameter " <> name <> " not found!" + case argType arg of + -- Passed along as a raw pointer + TCArray False (-1) (-1) _ -> + if argCallerAllocates arg + then return inName + else genConversion inName $ apply $ M "peek" + t@(TCArray False _ _ _) -> do + aname' <- if argCallerAllocates arg + then return inName + else genConversion inName $ apply $ M "peek" + let arrayLength = if argCallerAllocates arg + then id + else prime + wrapArray a = convertOutCArray callable t a + nameMap (transfer arg) arrayLength + wrapMaybe arg >>= bool + (wrapArray aname') + (do line $ "maybe" <> ucFirst aname' + <> " <- convertIfNonNull " <> aname' + <> " $ \\" <> prime aname' <> " -> do" + indent $ do + wrapped <- wrapArray (prime aname') + line $ "return " <> wrapped + return $ "maybe" <> ucFirst aname') + t -> do + weAlloc <- isJust <$> requiresAlloc t + peeked <- if weAlloc || argCallerAllocates arg + then return inName + else genConversion inName $ apply $ M "peek" + -- If we alloc we always take control of the resulting + -- memory, otherwise we may leak. + let transfer' = if weAlloc || argCallerAllocates arg + then TransferEverything + else transfer arg + result <- do + let wrap ptr = convert ptr $ fToH (argType arg) transfer' + wrapMaybe arg >>= bool + (wrap peeked) + (do line $ "maybe" <> ucFirst peeked + <> " <- convertIfNonNull " <> peeked + <> " $ \\" <> prime peeked <> " -> do" + indent $ do + wrapped <- wrap (prime peeked) + line $ "return " <> wrapped + return $ "maybe" <> ucFirst peeked) + -- Free the memory associated with the out argument + freeContainerType transfer' t peeked undefined + return result - returnResult :: Text -> [Text] -> CodeGen () - returnResult result pps = - if ignoreReturn || returnType callable == TBasicType TVoid - then case pps of - [] -> line "return ()" - (pp:[]) -> line $ "return " <> pp - _ -> line $ "return (" <> T.intercalate ", " pps <> ")" - else case pps of - [] -> line $ "return " <> result - _ -> line $ "return (" <> T.intercalate ", " (result : pps) <> ")" +-- | Convert the list of out arguments to Haskell, returning the +-- names of the corresponding variables containing the marshaled values. +convertOutArgs :: Callable -> Map.Map Text Text -> [Arg] -> ExcCodeGen [Text] +convertOutArgs callable nameMap hOutArgs = + forM hOutArgs (convertOutArg callable nameMap) + +-- | Invoke the given C function, taking care of errors. +invokeCFunction :: Callable -> Text -> Bool -> Bool -> [Text] -> CodeGen () +invokeCFunction callable symbol throwsGError ignoreReturn argNames = do + let returnBind = case returnType callable of + TBasicType TVoid -> "" + _ -> if ignoreReturn + then "_ <- " + else "result <- " + maybeCatchGErrors = if throwsGError + then "propagateGError $ " + else "" + line $ returnBind <> maybeCatchGErrors + <> symbol <> (T.concat . map (" " <>)) argNames + +-- | Return the result of the call, possibly including out arguments. +returnResult :: Callable -> Bool -> Text -> [Text] -> CodeGen () +returnResult callable ignoreReturn result pps = + if ignoreReturn || returnType callable == TBasicType TVoid + then case pps of + [] -> line "return ()" + (pp:[]) -> line $ "return " <> pp + _ -> line $ "return (" <> T.intercalate ", " pps <> ")" + else case pps of + [] -> line $ "return " <> result + _ -> line $ "return (" <> T.intercalate ", " (result : pps) <> ")" + +-- | Generate a Haskell wrapper for the given foreign function. +genHaskellWrapper :: Name -> Text -> Callable -> Bool -> ExcCodeGen () +genHaskellWrapper n symbol callable throwsGError = group $ do + let name = lowerName n + (hInArgs, omitted) = callableHInArgs callable + hOutArgs = callableHOutArgs callable + ignoreReturn = skipRetVal callable throwsGError + + line $ name <> " ::" + formatHSignature callable ignoreReturn + line $ name <> " " <> T.intercalate " " (map escapedArgName hInArgs) <> " = liftIO $ do" + indent (genWrapperBody n symbol callable throwsGError + ignoreReturn hInArgs hOutArgs omitted) + +-- | Generate the body of the Haskell wrapper for the given foreign symbol. +genWrapperBody :: Name -> Text -> Callable -> Bool -> + Bool -> [Arg] -> [Arg] -> [Arg] -> + ExcCodeGen () +genWrapperBody n symbol callable throwsGError + ignoreReturn hInArgs hOutArgs omitted = do + readInArrayLengths n callable hInArgs + inArgNames <- forM (args callable) $ \arg -> + prepareArgForCall omitted arg + -- Map from argument names to names passed to the C function + let nameMap = Map.fromList $ flip zip inArgNames + $ map escapedArgName $ args callable + prepareClosures callable nameMap + if throwsGError + then do + line "onException (do" + indent $ do + invokeCFunction callable symbol throwsGError + ignoreReturn inArgNames + readOutArrayLengths callable nameMap + result <- convertResult callable symbol ignoreReturn nameMap + pps <- convertOutArgs callable nameMap hOutArgs + freeCallCallbacks callable nameMap + forM_ (args callable) touchInArg + mapM_ line =<< freeInArgs callable nameMap + returnResult callable ignoreReturn result pps + line " ) (do" + indent $ do + freeCallCallbacks callable nameMap + actions <- freeInArgsOnError callable nameMap + case actions of + [] -> line $ "return ()" + _ -> mapM_ line actions + line " )" + else do + invokeCFunction callable symbol throwsGError + ignoreReturn inArgNames + readOutArrayLengths callable nameMap + result <- convertResult callable symbol ignoreReturn nameMap + pps <- convertOutArgs callable nameMap hOutArgs + freeCallCallbacks callable nameMap + forM_ (args callable) touchInArg + mapM_ line =<< freeInArgs callable nameMap + returnResult callable ignoreReturn result pps + +-- | caller-allocates arguments are arguments that the caller +-- allocates, and the called function modifies. They are marked as +-- 'out' argumens in the introspection data, we treat them as 'inout' +-- arguments instead. The semantics are somewhat tricky: for memory +-- management purposes they should be treated as "in" arguments, but +-- from the point of view of the exposed API they should be treated as +-- "inout". Unfortunately we cannot always just assume that they are +-- purely "out", so in many cases the generated API is somewhat +-- suboptimal (since the initial values are not important): for +-- example for g_io_channel_read_chars the size of the buffer to read +-- is determined by the caller-allocates argument. As a compromise, we +-- assume that we can allocate anything that is not a TCArray. +fixupCallerAllocates :: Callable -> Callable +fixupCallerAllocates c = + c{args = map (fixupLength . fixupArg . normalize) (args c)} + where fixupArg :: Arg -> Arg + fixupArg a = if argCallerAllocates a + then a {direction = DirectionInout} + else a + + lengthsMap :: Map.Map Arg Arg + lengthsMap = Map.fromList (map swap (arrayLengthsMap c)) + + -- Length arguments of caller-allocates arguments should be + -- treated as "in". + fixupLength :: Arg -> Arg + fixupLength a = case Map.lookup a lengthsMap of + Nothing -> a + Just array -> + if argCallerAllocates array + then a {direction = DirectionIn} + else a + + -- We impose that out or inout arguments of non-array type + -- are never caller-allocates. + normalize :: Arg -> Arg + normalize (a@Arg{argType = TCArray _ _ _ _}) = a + normalize a = a {argCallerAllocates = False} + +genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen () +genCallable n symbol callable throwsGError = do + group $ do + line $ "-- Args : " <> (tshow $ args callable) + line $ "-- Lengths : " <> (tshow $ arrayLengths callable) + line $ "-- returnType : " <> (tshow $ returnType callable) + line $ "-- throws : " <> (tshow throwsGError) + line $ "-- Skip return : " <> (tshow $ skipReturn callable) + when (skipReturn callable && returnType callable /= TBasicType TBoolean) $ + do line "-- XXX return value ignored, but it is not a boolean." + line "-- This may be a memory leak?" + + let callable' = fixupCallerAllocates callable + + mkForeignImport symbol callable' throwsGError + + blank + + line $ deprecatedPragma (lowerName n) (callableDeprecated callable) + exportMethod (lowerName n) (lowerName n) + genHaskellWrapper n symbol callable' throwsGError diff --git a/src/GI/Code.hs b/src/GI/Code.hs --- a/src/GI/Code.hs +++ b/src/GI/Code.hs @@ -13,6 +13,9 @@ , writeModuleCode , codeToText , transitiveModuleDeps + , minBaseVersion + , BaseVersion(..) + , showBaseVersion , loadDependency , getDeps @@ -32,10 +35,13 @@ , hsBoot , submodule , setLanguagePragmas + , setGHCOptions , setModuleFlags + , setModuleMinBase , addModuleDocumentation , exportToplevel + , exportModule , exportDecl , exportMethod , exportProperty @@ -137,8 +143,11 @@ , moduleDeps :: Deps -- ^ Set of dependencies for this module. , moduleExports :: Seq Export -- ^ Exports for the module. , modulePragmas :: Set.Set Text -- ^ Set of language pragmas for the module. + , moduleGHCOpts :: Set.Set Text -- ^ GHC options for compiling the module. , moduleFlags :: Set.Set ModuleFlag -- ^ Flags for the module. , moduleDoc :: Maybe Text -- ^ Documentation for the module. + , moduleMinBase :: BaseVersion -- ^ Minimal version of base the + -- module will work on. } -- | Flags for module code generation. @@ -149,6 +158,16 @@ | Reexport -- ^ Reexport the module (as is) from .Types deriving (Show, Eq, Ord) +-- | Minimal version of base supported by a given module. +data BaseVersion = Base47 -- ^ 4.7.0 + | Base48 -- ^ 4.8.0 + deriving (Show, Eq, Ord) + +-- | A `Text` representation of the given base version bound. +showBaseVersion :: BaseVersion -> Text +showBaseVersion Base47 = "4.7" +showBaseVersion Base48 = "4.8" + -- | Generate the empty module. emptyModule :: ModuleName -> ModuleInfo emptyModule m = ModuleInfo { moduleName = m @@ -158,8 +177,10 @@ , moduleDeps = Set.empty , moduleExports = S.empty , modulePragmas = Set.empty + , moduleGHCOpts = Set.empty , moduleFlags = Set.empty , moduleDoc = Nothing + , moduleMinBase = Base47 } -- | Information for the code generator. @@ -200,7 +221,7 @@ cleanInfo :: ModuleInfo -> ModuleInfo cleanInfo info = info { moduleCode = NoCode, submodules = M.empty, bootCode = NoCode, moduleExports = S.empty, - moduleDoc = Nothing } + moduleDoc = Nothing, moduleMinBase = Base47 } -- | Run the given code generator using the state and config of an -- ambient CodeGen, but without adding the generated code to @@ -236,13 +257,16 @@ newSubmodules = M.unionWith mergeInfo (submodules oldState) (submodules newState) newExports = moduleExports oldState <> moduleExports newState newPragmas = Set.union (modulePragmas oldState) (modulePragmas newState) + newGHCOpts = Set.union (moduleGHCOpts oldState) (moduleGHCOpts newState) newFlags = Set.union (moduleFlags oldState) (moduleFlags newState) newBoot = bootCode oldState <> bootCode newState newDoc = moduleDoc oldState <> moduleDoc newState + newMinBase = max (moduleMinBase oldState) (moduleMinBase newState) in oldState {moduleDeps = newDeps, submodules = newSubmodules, moduleExports = newExports, modulePragmas = newPragmas, - moduleFlags = newFlags, bootCode = newBoot, - moduleDoc = newDoc } + moduleGHCOpts = newGHCOpts, moduleFlags = newFlags, + bootCode = newBoot, moduleDoc = newDoc, + moduleMinBase = newMinBase } -- | Merge the infos, including code too. mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo @@ -340,6 +364,13 @@ Set.unions (moduleDeps minfo : map transitiveModuleDeps (M.elems $ submodules minfo)) +-- | Return the minimal base version supported by the module and all +-- its submodules. +minBaseVersion :: ModuleInfo -> BaseVersion +minBaseVersion minfo = + maximum (moduleMinBase minfo + : map minBaseVersion (M.elems $ submodules minfo)) + -- | Give a friendly textual description of the error for presenting -- to the user. describeCGError :: CGError -> Text @@ -413,6 +444,10 @@ export e = modify' $ \s -> s{moduleExports = moduleExports s |> e} +-- | Reexport a whole module. +exportModule :: SymbolName -> CodeGen () +exportModule m = export (Export ExportModule m) + -- | Export a toplevel (i.e. belonging to no section) symbol. exportToplevel :: SymbolName -> CodeGen () exportToplevel t = export (Export ExportToplevel t) @@ -438,11 +473,21 @@ setLanguagePragmas ps = modify' $ \s -> s{modulePragmas = Set.fromList ps} +-- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma). +setGHCOptions :: [Text] -> CodeGen () +setGHCOptions opts = + modify' $ \s -> s{moduleGHCOpts = Set.fromList opts} + -- | Set the given flags for the module. setModuleFlags :: [ModuleFlag] -> CodeGen () setModuleFlags flags = modify' $ \s -> s{moduleFlags = Set.fromList flags} +-- | Set the minimum base version supported by the current module. +setModuleMinBase :: BaseVersion -> CodeGen () +setModuleMinBase v = + modify' $ \s -> s{moduleMinBase = max v (moduleMinBase s)} + -- | Add the given text to the module-level documentation for the -- module being generated. addModuleDocumentation :: Maybe Documentation -> CodeGen () @@ -569,6 +614,11 @@ languagePragmas [] = "" languagePragmas ps = "{-# LANGUAGE " <> T.intercalate ", " ps <> " #-}\n" +-- | Write down the list of GHC options. +ghcOptions :: [Text] -> Text +ghcOptions [] = "" +ghcOptions opts = "{-# OPTIONS_GHC " <> T.intercalate ", " opts <> " #-}\n" + -- | Standard fields for every module. standardFields :: Text standardFields = T.unlines [ "Copyright : " <> authors @@ -596,7 +646,7 @@ modulePrelude name exports reexportedModules = "module " <> name <> "\n ( " <> formatExportList (map (Export ExportModule) reexportedModules) - <> "\n , " + <> "\n" <> formatExportList exports <> " ) where\n\n" <> T.unlines (map ("import " <>) reexportedModules) @@ -630,6 +680,7 @@ dirname = takeDirectory fname code = codeToText (moduleCode minfo) pragmas = languagePragmas (Set.toList $ modulePragmas minfo) + optionsGHC = ghcOptions (Set.toList $ moduleGHCOpts minfo) prelude = modulePrelude (dotModuleName $ moduleName minfo) (F.toList (moduleExports minfo)) submoduleExports @@ -653,7 +704,7 @@ when verbose $ putStrLn ((T.unpack . dotModuleName . moduleName) minfo ++ " -> " ++ fname) createDirectoryIfMissing True dirname - TIO.writeFile fname (T.unlines [pragmas, haddock, prelude, + TIO.writeFile fname (T.unlines [pragmas, optionsGHC, haddock, prelude, imports, types, callbacks, deps, code]) when (bootCode minfo /= NoCode) $ do let bootFName = moduleNameToPath dirPrefix (moduleName minfo) ".hs-boot" diff --git a/src/GI/CodeGen.hs b/src/GI/CodeGen.hs --- a/src/GI/CodeGen.hs +++ b/src/GI/CodeGen.hs @@ -11,7 +11,7 @@ import Control.Monad (forM, forM_, when, unless, filterM) import Data.List (nub) import Data.Tuple (swap) -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe, isNothing) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text) @@ -24,24 +24,29 @@ import GI.Constant (genConstant) import GI.Code import GI.GObject -import GI.Inheritance (instanceTree) +import GI.Inheritance (instanceTree, fullObjectMethodList, + fullInterfaceMethodList) import GI.Properties (genInterfaceProperties, genObjectProperties) import GI.OverloadedSignals (genInterfaceSignals, genObjectSignals) +import GI.OverloadedMethods (genMethodList, genMethodInfo, + genUnsupportedMethodInfo) import GI.Signal (genSignal, genCallback) import GI.Struct (genStructOrUnionFields, extractCallbacksInStruct, - fixAPIStructs, ignoreStruct) + fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion) import GI.SymbolNaming (upperName, classConstraint, noName) import GI.Type import GI.Util (tshow) genFunction :: Name -> Function -> CodeGen () -genFunction n (Function symbol throws callable) = - submodule "Functions" $ group $ do - line $ "-- function " <> symbol - handleCGExc (\e -> line ("-- XXX Could not generate function " +genFunction n (Function symbol throws fnMovedTo callable) = + -- Only generate the function if it has not been moved. + when (Nothing == fnMovedTo) $ + submodule "Functions" $ group $ do + line $ "-- function " <> symbol + handleCGExc (\e -> line ("-- XXX Could not generate function " <> symbol <> "\n-- Error was : " <> describeCGError e)) - (genCallable n symbol callable throws) + (genCallable n symbol callable throws) genBoxedObject :: Name -> Text -> CodeGen () genBoxedObject n typeInit = do @@ -180,21 +185,30 @@ genBoxedObject n (fromJust $ structTypeInit s) exportDecl (name' <> ("(..)")) + -- Generate a builder for a structure filled with zeroes. + genZeroStruct n s + noName name' -- Generate code for fields. genStructOrUnionFields n (structFields s) -- Methods - forM_ (structMethods s) $ \(mn, f) -> - do isFunction <- symbolFromFunction (methodSymbol f) - unless isFunction $ - handleCGExc + methods <- forM (structMethods s) $ \f -> do + let mn = methodName f + isFunction <- symbolFromFunction (methodSymbol f) + if not isFunction + then handleCGExc (\e -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n" - <> "-- Error was : " <> describeCGError e)) - (genMethod n mn f) + <> "-- Error was : " <> describeCGError e) >> + return Nothing) + (genMethod n f >> return (Just (n, f))) + else return Nothing + -- Overloaded methods + genMethodList n (catMaybes methods) + genUnion :: Name -> Union -> CodeGen () genUnion n u = do name' <- upperName n @@ -208,21 +222,30 @@ genBoxedObject n (fromJust $ unionTypeInit u) exportDecl (name' <> "(..)") + -- Generate a builder for a structure filled with zeroes. + genZeroUnion n u + noName name' -- Generate code for fields. genStructOrUnionFields n (unionFields u) -- Methods - forM_ (unionMethods u) $ \(mn, f) -> - do isFunction <- symbolFromFunction (methodSymbol f) - unless isFunction $ - handleCGExc + methods <- forM (unionMethods u) $ \f -> do + let mn = methodName f + isFunction <- symbolFromFunction (methodSymbol f) + if not isFunction + then handleCGExc (\e -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n" - <> "-- Error was : " <> describeCGError e)) - (genMethod n mn f) + <> "-- Error was : " <> describeCGError e) + >> return Nothing) + (genMethod n f >> return (Just (n, f))) + else return Nothing + -- Overloaded methods + genMethodList n (catMaybes methods) + -- Add the implicit object argument to methods of an object. Since we -- are prepending an argument we need to adjust the offset of the -- length arguments of CArrays, and closure and destroyer offsets. @@ -255,13 +278,14 @@ else arg objArg = Arg { - argName = "_obj", + argCName = "_obj", argType = TInterface (namespace cn) (name cn), direction = DirectionIn, mayBeNull = False, argScope = ScopeTypeInvalid, argClosure = -1, argDestroy = -1, + argCallerAllocates = False, transfer = TransferNothing } -- For constructors we want to return the actual type of the object, @@ -275,13 +299,14 @@ else returnType c -genMethod :: Name -> Name -> Method -> ExcCodeGen () -genMethod cn mn (Method { - methodSymbol = sym, - methodCallable = c, - methodType = t, - methodThrows = throws - }) = do +genMethod :: Name -> Method -> ExcCodeGen () +genMethod cn m@(Method { + methodName = mn, + methodSymbol = sym, + methodCallable = c, + methodType = t, + methodThrows = throws + }) = do name' <- upperName cn returnsGObject <- isGObject (returnType c) line $ "-- method " <> name' <> "::" <> name mn @@ -296,6 +321,8 @@ else c' genCallable mn' sym c'' throws + genMethodInfo cn (m {methodCallable = c''}) + -- Type casting with type checking genGObjectCasts :: Bool -> Name -> Text -> [Name] -> CodeGen () genGObjectCasts isIU n cn_ parents = do @@ -356,6 +383,8 @@ noName name' + fullObjectMethodList n o >>= genMethodList n + forM_ (objSignals o) $ \s -> handleCGExc (line . (T.concat ["-- XXX Could not generate signal ", name', "::" @@ -367,12 +396,13 @@ genObjectSignals n o -- Methods - forM_ (objMethods o) $ \(mn, f) -> - handleCGExc - (\e -> line ("-- XXX Could not generate method " - <> name' <> "::" <> name mn <> "\n" - <> "-- Error was : " <> describeCGError e)) - (genMethod n mn f) + forM_ (objMethods o) $ \f -> do + let mn = methodName f + handleCGExc (\e -> line ("-- XXX Could not generate method " + <> name' <> "::" <> name mn <> "\n" + <> "-- Error was : " <> describeCGError e) + >> genUnsupportedMethodInfo n f) + (genMethod n f) genInterface :: Name -> Interface -> CodeGen () genInterface n iface = do @@ -386,6 +416,8 @@ noName name' + fullInterfaceMethodList n iface >>= genMethodList n + forM_ (ifSignals iface) $ \s -> handleCGExc (line . (T.concat ["-- XXX Could not generate signal ", name', "::" , sigName s @@ -415,32 +447,52 @@ line $ "type " <> parentObjectsType <> " = '[]" -- Methods - forM_ (ifMethods iface) $ \(mn, f) -> do + forM_ (ifMethods iface) $ \f -> do + let mn = methodName f isFunction <- symbolFromFunction (methodSymbol f) unless isFunction $ handleCGExc (\e -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n" - <> "-- Error was : " <> describeCGError e)) - (genMethod n mn f) + <> "-- Error was : " <> describeCGError e) + >> genUnsupportedMethodInfo n f) + (genMethod n f) -- Some type libraries include spurious interface/struct methods, -- where a method Mod.Foo::func also appears as an ordinary function --- in the list of APIs. If we find a matching function, we don't --- generate the method. +-- in the list of APIs. If we find a matching function (without the +-- "moved-to" annotation), we don't generate the method. -- -- It may be more expedient to keep a map of symbol -> function. --- --- XXX Maybe the GIR helps here? Sometimes such functions are --- annotated with the "moved-to". symbolFromFunction :: Text -> CodeGen Bool symbolFromFunction sym = do apis <- getAPIs return $ any (hasSymbol sym . snd) $ M.toList apis where - hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2 })) = sym1 == sym2 + hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2, + fnMovedTo = movedTo })) = + sym1 == sym2 && movedTo == Nothing hasSymbol _ _ = False +-- | Remove functions and methods annotated with "moved-to". +dropMovedItems :: API -> Maybe API +dropMovedItems (APIFunction f) = if fnMovedTo f == Nothing + then Just (APIFunction f) + else Nothing +dropMovedItems (APIInterface i) = + (Just . APIInterface) i {ifMethods = filterMovedMethods (ifMethods i)} +dropMovedItems (APIObject o) = + (Just . APIObject) o {objMethods = filterMovedMethods (objMethods o)} +dropMovedItems (APIStruct s) = + (Just . APIStruct) s {structMethods = filterMovedMethods (structMethods s)} +dropMovedItems (APIUnion u) = + (Just . APIUnion) u {unionMethods = filterMovedMethods (unionMethods u)} +dropMovedItems a = Just a + +-- | Drop the moved methods. +filterMovedMethods :: [Method] -> [Method] +filterMovedMethods = filter (isNothing . methodMovedTo) + genAPI :: Name -> API -> CodeGen () genAPI n (APIConst c) = genConstant n c genAPI n (APIFunction f) = genFunction n f @@ -464,6 +516,7 @@ , Name "GLib" "Variant" , Name "GObject" "Value" , Name "GObject" "Closure"]) . fst) + $ mapMaybe (traverse dropMovedItems) -- Some callback types are defined inside structs $ map fixAPIStructs $ M.toList @@ -475,6 +528,11 @@ genModule :: M.Map Name API -> CodeGen () genModule apis = do + -- Reexport Data.GI.Base for convenience (so it does not need to be + -- imported separately). + line "import Data.GI.Base" + exportModule "Data.GI.Base" + -- Some API symbols are embedded into structures, extract these and -- inject them into the set of APIs loaded and being generated. let embeddedAPIs = (M.fromList diff --git a/src/GI/Constant.hs b/src/GI/Constant.hs --- a/src/GI/Constant.hs +++ b/src/GI/Constant.hs @@ -32,9 +32,11 @@ writePattern name (SimpleSynonym value t) = line $ "pattern " <> name <> " = " <> value <> " :: " <> t writePattern name (ExplicitSynonym view expression value t) = do - line $ - "pattern " <> name <> " <- (" <> view <> " -> " <> value <> ") :: " <> t <> " where" - indent $ line $ + -- Supported only on ghc >= 7.10 + setModuleMinBase Base48 + line $ "pattern " <> name <> " <- (" <> view <> " -> " + <> value <> ") :: " <> t <> " where" + indent $ line $ name <> " = " <> expression <> " " <> value <> " :: " <> t genConstant :: Name -> Constant -> CodeGen () @@ -64,8 +66,12 @@ case api of Just (APIEnum _) -> writePattern name (ExplicitSynonym "fromEnum" "toEnum" value ht) - Just (APIFlags _) -> - writePattern name (ExplicitSynonym "gflagsToWord" "wordToGFlags" value ht) + Just (APIFlags _) -> do + -- gflagsToWord and wordToGFlags are polymorphic, so in this + -- case we need to specialize so the type of the pattern is + -- not ambiguous. + let wordValue = "(" <> value <> " :: Word64)" + writePattern name (ExplicitSynonym "gflagsToWord" "wordToGFlags" wordValue ht) _ -> notImplementedError $ "Don't know how to treat constants of type " <> tshow t assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " <> tshow t @@ -91,5 +97,7 @@ showBasicType TFileName fn = return . tshow $ fn showBasicType TUniChar c = return $ "'" <> c <> "'" showBasicType TGType gtype = return $ "GType " <> gtype +showBasicType TIntPtr ptr = return ptr +showBasicType TUIntPtr ptr = return ptr -- We take care of this one separately above showBasicType TVoid _ = notImplementedError $ "Cannot directly show a pointer" diff --git a/src/GI/Conversions.hs b/src/GI/Conversions.hs --- a/src/GI/Conversions.hs +++ b/src/GI/Conversions.hs @@ -601,6 +601,8 @@ haskellBasicType TDouble = typeOf (0 :: Double) haskellBasicType TUniChar = typeOf ('\0' :: Char) haskellBasicType TFileName = "[Char]" `con` [] +haskellBasicType TIntPtr = "CIntPtr" `con` [] +haskellBasicType TUIntPtr = "CUIntPtr" `con` [] -- This translates GI types to the types used for generated Haskell code. haskellType :: Type -> CodeGen TypeRep diff --git a/src/GI/GIR/Arg.hs b/src/GI/GIR/Arg.hs --- a/src/GI/GIR/Arg.hs +++ b/src/GI/GIR/Arg.hs @@ -26,13 +26,16 @@ deriving (Show, Eq, Ord) data Arg = Arg { - argName :: Text, + argCName :: Text, -- ^ "C" name for the argument. For a + -- escaped name valid in Haskell code, use + -- `GI.SymbolNaming.escapedArgName`. argType :: Type, direction :: Direction, mayBeNull :: Bool, argScope :: Scope, argClosure :: Int, argDestroy :: Int, + argCallerAllocates :: Bool, transfer :: Transfer } deriving (Show, Eq, Ord) @@ -64,13 +67,15 @@ closure <- optionalAttr "closure" (-1) parseIntegral destroy <- optionalAttr "destroy" (-1) parseIntegral nullable <- optionalAttr "nullable" False parseBool + callerAllocates <- optionalAttr "caller-allocates" False parseBool t <- parseType - return $ Arg { argName = name + return $ Arg { argCName = name , argType = t , direction = d , mayBeNull = nullable , argScope = scope , argClosure = closure , argDestroy = destroy + , argCallerAllocates = callerAllocates , transfer = ownership } diff --git a/src/GI/GIR/Function.hs b/src/GI/GIR/Function.hs --- a/src/GI/GIR/Function.hs +++ b/src/GI/GIR/Function.hs @@ -9,9 +9,10 @@ import GI.GIR.Parser data Function = Function { - fnSymbol :: Text, - fnThrows :: Bool, - fnCallable :: Callable + fnSymbol :: Text + , fnThrows :: Bool + , fnMovedTo :: Maybe Text + , fnCallable :: Callable } deriving Show parseFunction :: Parser (Name, Function) @@ -24,9 +25,11 @@ callable <- parseCallable symbol <- getAttrWithNamespace CGIRNS "identifier" throws <- optionalAttr "throws" False parseBool + movedTo <- queryAttr "moved-to" return $ (exposedName, Function { fnSymbol = symbol , fnCallable = callable , fnThrows = throws + , fnMovedTo = movedTo }) diff --git a/src/GI/GIR/Interface.hs b/src/GI/GIR/Interface.hs --- a/src/GI/GIR/Interface.hs +++ b/src/GI/GIR/Interface.hs @@ -15,7 +15,7 @@ ifPrerequisites :: [Name], ifProperties :: [Property], ifSignals :: [Signal], - ifMethods :: [(Name, Method)], + ifMethods :: [Method], ifDeprecated :: Maybe DeprecationInfo } deriving Show diff --git a/src/GI/GIR/Method.hs b/src/GI/GIR/Method.hs --- a/src/GI/GIR/Method.hs +++ b/src/GI/GIR/Method.hs @@ -16,13 +16,15 @@ deriving (Eq, Show) data Method = Method { + methodName :: Name, methodSymbol :: Text, methodThrows :: Bool, methodType :: MethodType, + methodMovedTo :: Maybe Text, methodCallable :: Callable - } deriving Show + } deriving (Eq, Show) -parseMethod :: MethodType -> Parser (Name, Method) +parseMethod :: MethodType -> Parser Method parseMethod mType = do name <- parseName shadows <- queryAttr "shadows" @@ -32,10 +34,12 @@ callable <- parseCallable symbol <- getAttrWithNamespace CGIRNS "identifier" throws <- optionalAttr "throws" False parseBool - return $ (exposedName, - Method { - methodSymbol = symbol + movedTo <- queryAttr "moved-to" + return $ Method { + methodName = exposedName + , methodSymbol = symbol , methodThrows = throws , methodType = mType + , methodMovedTo = movedTo , methodCallable = callable - }) + } diff --git a/src/GI/GIR/Object.hs b/src/GI/GIR/Object.hs --- a/src/GI/GIR/Object.hs +++ b/src/GI/GIR/Object.hs @@ -18,7 +18,7 @@ objInterfaces :: [Name], objDeprecated :: Maybe DeprecationInfo, objDocumentation :: Maybe Documentation, - objMethods :: [(Name, Method)], + objMethods :: [Method], objProperties :: [Property], objSignals :: [Signal] } deriving Show diff --git a/src/GI/GIR/Struct.hs b/src/GI/GIR/Struct.hs --- a/src/GI/GIR/Struct.hs +++ b/src/GI/GIR/Struct.hs @@ -18,7 +18,7 @@ -- https://bugzilla.gnome.org/show_bug.cgi?id=560248 structIsDisguised :: Bool, structFields :: [Field], - structMethods :: [(Name, Method)], + structMethods :: [Method], structDeprecated :: Maybe DeprecationInfo, structDocumentation :: Maybe Documentation } deriving Show @@ -36,6 +36,7 @@ fields <- parseFields constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) + functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction) return (name, Struct { structIsBoxed = error ("[boxed] unfixed struct " ++ show name) @@ -44,7 +45,7 @@ , gtypeStructFor = structFor , structIsDisguised = disguised , structFields = fields - , structMethods = constructors ++ methods + , structMethods = constructors ++ methods ++ functions , structDeprecated = deprecated , structDocumentation = doc }) diff --git a/src/GI/GIR/Type.hs b/src/GI/GIR/Type.hs --- a/src/GI/GIR/Type.hs +++ b/src/GI/GIR/Type.hs @@ -39,6 +39,8 @@ nameToBasicType "GType" = Just TGType nameToBasicType "utf8" = Just TUTF8 nameToBasicType "filename" = Just TFileName +nameToBasicType "gintptr" = Just TIntPtr +nameToBasicType "guintptr" = Just TUIntPtr nameToBasicType "gshort" = case sizeOf (0 :: CShort) of 2 -> Just TInt16 4 -> Just TInt32 diff --git a/src/GI/GIR/Union.hs b/src/GI/GIR/Union.hs --- a/src/GI/GIR/Union.hs +++ b/src/GI/GIR/Union.hs @@ -16,7 +16,7 @@ unionSize :: Int, unionTypeInit :: Maybe Text, unionFields :: [Field], - unionMethods :: [(Name, Method)], + unionMethods :: [Method], unionDeprecated :: Maybe DeprecationInfo } deriving Show @@ -28,13 +28,14 @@ fields <- parseFields constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) + functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction) return (name, Union { unionIsBoxed = isJust typeInit , unionTypeInit = typeInit , unionSize = error ("unfixed union size " ++ show name) , unionFields = fields - , unionMethods = constructors ++ methods + , unionMethods = constructors ++ methods ++ functions , unionDeprecated = deprecated }) diff --git a/src/GI/Inheritance.hs b/src/GI/Inheritance.hs --- a/src/GI/Inheritance.hs +++ b/src/GI/Inheritance.hs @@ -4,13 +4,15 @@ , fullInterfacePropertyList , fullObjectSignalList , fullInterfaceSignalList + , fullObjectMethodList + , fullInterfaceMethodList , instanceTree ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif -import Control.Monad (foldM) +import Control.Monad (foldM, when) import qualified Data.Map as M import Data.Text (Text) @@ -55,6 +57,11 @@ objInheritables = objSignals iName = sigName +instance Inheritable Method where + ifInheritables = ifMethods + objInheritables = objMethods + iName = name . methodName + -- Returns a list of all inheritables defined for this object -- (including those defined by its ancestors and the interfaces it -- implements), together with the name of the interface defining the @@ -96,8 +103,8 @@ -- they are not isomorphic we refuse to set either, and print a -- warning in the generated code. removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) => - [(Name, i)] -> CodeGen [(Name, i)] -removeDuplicates inheritables = + Bool -> [(Name, i)] -> CodeGen [(Name, i)] +removeDuplicates verbose inheritables = (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables where filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) -> @@ -108,9 +115,10 @@ | tainted -> return m | (p == prop) -> return m -- Duplicated, but isomorphic property | otherwise -> - do line "--- XXX Duplicated object with different types:" - line $ " --- " <> tshow n <> " -> " <> tshow p - line $ " --- " <> tshow name <> " -> " <> tshow prop + do when verbose $ do + line "--- XXX Duplicated object with different types:" + line $ " --- " <> tshow n <> " -> " <> tshow p + line $ " --- " <> tshow name <> " -> " <> tshow prop -- Tainted return $ M.insert (iName prop) (True, n, p) m Nothing -> return $ M.insert (iName prop) (False, name, prop) m @@ -122,22 +130,34 @@ -- defined by its ancestors. fullObjectPropertyList :: Name -> Object -> CodeGen [(Name, Property)] fullObjectPropertyList n o = fullObjectInheritableList n o >>= - removeDuplicates + removeDuplicates True -- | List all properties defined for an interface, including those -- defined by its prerequisites. fullInterfacePropertyList :: Name -> Interface -> CodeGen [(Name, Property)] fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>= - removeDuplicates + removeDuplicates True -- | List all signals defined for an object, including those -- defined by its ancestors. fullObjectSignalList :: Name -> Object -> CodeGen [(Name, Signal)] fullObjectSignalList n o = fullObjectInheritableList n o >>= - removeDuplicates + removeDuplicates True -- | List all signals defined for an interface, including those -- defined by its prerequisites. fullInterfaceSignalList :: Name -> Interface -> CodeGen [(Name, Signal)] fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>= - removeDuplicates + removeDuplicates True + +-- | List all methods defined for an object, including those defined +-- by its ancestors. +fullObjectMethodList :: Name -> Object -> CodeGen [(Name, Method)] +fullObjectMethodList n o = fullObjectInheritableList n o >>= + removeDuplicates False + +-- | List all methods defined for an interface, including those +-- defined by its prerequisites. +fullInterfaceMethodList :: Name -> Interface -> CodeGen [(Name, Method)] +fullInterfaceMethodList n i = fullInterfaceInheritableList n i >>= + removeDuplicates False diff --git a/src/GI/OverloadedLabels.hs b/src/GI/OverloadedLabels.hs new file mode 100644 --- /dev/null +++ b/src/GI/OverloadedLabels.hs @@ -0,0 +1,84 @@ +module GI.OverloadedLabels + ( genOverloadedLabels + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Data.Maybe (isNothing) +import Control.Monad (forM_) +import qualified Data.Set as S +import Data.Text (Text) + +import GI.API +import GI.Code +import GI.SymbolNaming +import GI.Util (lcFirst) + +-- | A list of all overloadable identifiers in the set of APIs (current +-- properties and methods). +findOverloaded :: [(Name, API)] -> CodeGen [Text] +findOverloaded apis = S.toList <$> go apis S.empty + where + go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text) + go [] set = return set + go ((_, api):apis) set = + case api of + APIInterface iface -> go apis (scanInterface iface set) + APIObject object -> go apis (scanObject object set) + APIStruct s -> go apis (scanStruct s set) + APIUnion u -> go apis (scanUnion u set) + _ -> go apis set + + scanObject :: Object -> S.Set Text -> S.Set Text + scanObject o set = + let props = (map propToLabel . objProperties) o + methods = (map methodToLabel . filterMethods . objMethods) o + in S.unions [set, S.fromList props, S.fromList methods] + + scanInterface :: Interface -> S.Set Text -> S.Set Text + scanInterface i set = + let props = (map propToLabel . ifProperties) i + methods = (map methodToLabel . filterMethods . ifMethods) i + in S.unions [set, S.fromList props, S.fromList methods] + + scanStruct :: Struct -> S.Set Text -> S.Set Text + scanStruct s set = + let methods = (map methodToLabel . filterMethods . structMethods) s + in S.unions [set, S.fromList methods] + + scanUnion :: Union -> S.Set Text -> S.Set Text + scanUnion u set = + let methods = (map methodToLabel . filterMethods . unionMethods) u + in S.unions [set, S.fromList methods] + + propToLabel :: Property -> Text + propToLabel = lcFirst . hyphensToCamelCase . propName + + methodToLabel :: Method -> Text + methodToLabel = lowerName . methodName + + filterMethods :: [Method] -> [Method] + filterMethods = filter (\m -> (isNothing . methodMovedTo) m && + methodType m == OrdinaryMethod) + +genOverloadedLabel :: Text -> CodeGen () +genOverloadedLabel l = group $ do + line $ "_" <> l <> " :: IsLabelProxy \"" <> l <> "\" a => a" + line $ "_" <> l <> " = fromLabelProxy (Proxy :: Proxy \"" + <> l <> "\")" + exportToplevel ("_" <> l) + +genOverloadedLabels :: [(Name, API)] -> CodeGen () +genOverloadedLabels allAPIs = do + setLanguagePragmas ["DataKinds", "FlexibleContexts"] + setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport] + + line $ "import Data.Proxy (Proxy(..))" + line $ "import Data.GI.Base.Overloading (IsLabelProxy(..))" + blank + + labels <- findOverloaded allAPIs + forM_ labels $ \l -> do + genOverloadedLabel l + blank diff --git a/src/GI/OverloadedMethods.hs b/src/GI/OverloadedMethods.hs new file mode 100644 --- /dev/null +++ b/src/GI/OverloadedMethods.hs @@ -0,0 +1,106 @@ +module GI.OverloadedMethods + ( genMethodList + , genMethodInfo + , genUnsupportedMethodInfo + ) where + +import Control.Monad (forM, forM_, when) +import Data.Text (Text) +import qualified Data.Text as T + +import GI.API +import GI.Callable (callableSignature, fixupCallerAllocates) +import GI.Code +import GI.SymbolNaming (lowerName, upperName) +import GI.Util (ucFirst) + +-- | Qualified name for the info for a given method. +methodInfoName :: Name -> Method -> CodeGen Text +methodInfoName n method = do + n' <- upperName n + let mn' = (ucFirst . lowerName . methodName) method + return $ n' <> mn' <> "MethodInfo" + +-- | Appropriate instances so overloaded labels are properly resolved. +genMethodResolver :: Text -> CodeGen () +genMethodResolver n = do + group $ do + line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " + <> "MethodInfo info " <> n <> " p) => IsLabelProxy t (" + <> n <> " -> p) where" + indent $ line $ "fromLabelProxy _ = overloadedMethod (MethodProxy :: MethodProxy info)" + group $ do + line $ "#if MIN_VERSION_base(4,9,0)" + line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " + <> "MethodInfo info " <> n <> " p) => IsLabel t (" + <> n <> " -> p) where" + indent $ line $ "fromLabel _ = overloadedMethod (MethodProxy :: MethodProxy info)" + line $ "#endif" + +-- | Generate the `MethodList` instance given the list of methods for +-- the given named type. +genMethodList :: Name -> [(Name, Method)] -> CodeGen () +genMethodList n methods = do + name <- upperName n + let filteredMethods = filter isOrdinaryMethod methods + gets = filter isGet filteredMethods + sets = filter isSet filteredMethods + others = filter (\m -> not (isSet m || isGet m)) filteredMethods + orderedMethods = others ++ gets ++ sets + infos <- forM orderedMethods $ \(owner, method) -> + do mi <- methodInfoName owner method + return ((lowerName . methodName) method, mi) + group $ do + let resolver = "Resolve" <> name <> "Method" + line $ "type family " <> resolver <> " (t :: Symbol) (o :: *) :: * where" + indent $ forM_ infos $ \(label, info) -> do + line $ resolver <> " \"" <> label <> "\" o = " <> info + indent $ line $ resolver <> " l o = MethodResolutionFailed l o" + + genMethodResolver name + + where isOrdinaryMethod :: (Name, Method) -> Bool + isOrdinaryMethod (_, m) = methodType m == OrdinaryMethod + + isGet :: (Name, Method) -> Bool + isGet (_, m) = "get_" `T.isPrefixOf` (name . methodName) m + + isSet :: (Name, Method) -> Bool + isSet (_, m) = "set_" `T.isPrefixOf` (name . methodName) m + +-- | Generate the `MethodInfo` type and instance for the given method. +genMethodInfo :: Name -> Method -> ExcCodeGen () +genMethodInfo n m = + when (methodType m == OrdinaryMethod) $ + group $ do + infoName <- methodInfoName n m + let callable = fixupCallerAllocates (methodCallable m) + (constraints, types) <- callableSignature callable (methodThrows m) + bline $ "data " <> infoName + -- This should not happen, since ordinary methods always + -- have the instance as first argument. + when (null types) $ + error $ "Internal error: too few parameters! " ++ show m + let (obj:otherTypes) = map fst types + sigConstraint = "signature ~ (" <> T.intercalate " -> " otherTypes + <> ")" + line $ "instance (" <> T.intercalate ", " (sigConstraint : constraints) + <> ") => MethodInfo " <> infoName <> " " <> obj <> " signature where" + let mn = methodName m + mangled = lowerName (mn {name = name n <> "_" <> name mn}) + indent $ line $ "overloadedMethod _ = " <> mangled + exportMethod mangled infoName + +-- | Generate a method info that is not actually callable, but rather +-- gives a type error when trying to use it. +genUnsupportedMethodInfo :: Name -> Method -> CodeGen () +genUnsupportedMethodInfo n m = do + infoName <- methodInfoName n m + line $ "-- XXX: Dummy instance, since code generation failed.\n" + <> "-- Please file a bug at http://github.com/haskell-gi/haskell-gi." + bline $ "data " <> infoName + line $ "instance (p ~ (), o ~ MethodResolutionFailed \"" + <> lowerName (methodName m) <> "\" " <> name n + <> ") => MethodInfo " <> infoName <> " o p where" + indent $ line $ "overloadedMethod _ = undefined" + exportMethod "Unsupported methods" infoName diff --git a/src/GI/OverloadedSignals.hs b/src/GI/OverloadedSignals.hs --- a/src/GI/OverloadedSignals.hs +++ b/src/GI/OverloadedSignals.hs @@ -18,8 +18,8 @@ import GI.Inheritance (fullObjectSignalList, fullInterfaceSignalList) import GI.GObject (apiIsGObject) import GI.Signal (signalHaskellName) -import GI.SymbolNaming (upperName) -import GI.Util (padTo, ucFirst) +import GI.SymbolNaming (upperName, hyphensToCamelCase) +import GI.Util (lcFirst, ucFirst) -- A list of distinct signal names for all GObjects appearing in the -- given list of APIs. @@ -42,23 +42,28 @@ -- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ... genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen () genOverloadedSignalConnectors allAPIs = do - setLanguagePragmas ["DataKinds", "GADTs", "KindSignatures", "FlexibleInstances"] + setLanguagePragmas ["DataKinds", "PatternSynonyms", "CPP", + -- For ghc 7.8 support + "RankNTypes", "ScopedTypeVariables", "TypeFamilies"] setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport] - line "import GHC.TypeLits" - line "import GHC.Exts (Constraint)" - blank - line "class NoConstraint a" - line "instance NoConstraint a" + line "import Data.GI.Base.Signals (SignalProxy(..))" + line "import Data.GI.Base.Overloading (ResolveSignal)" blank - line "data SignalProxy (a :: Symbol) (b :: Symbol) (c :: * -> Constraint) where" - indent $ do - signalNames <- findSignalNames allAPIs - let maxLength = maximum $ map (T.length . signalHaskellName) signalNames - forM_ signalNames $ \sn -> - line $ padTo (maxLength + 1) (ucFirst (signalHaskellName sn)) <> - ":: SignalProxy \"" <> sn <> "\" \"\" NoConstraint" - exportToplevel "SignalProxy(..)" + signalNames <- findSignalNames allAPIs + forM_ signalNames $ \sn -> group $ do + let camelName = hyphensToCamelCase sn + line $ "#if MIN_VERSION_base(4,8,0)" + line $ "pattern " <> camelName <> + " :: SignalProxy object (ResolveSignal \"" + <> lcFirst camelName <> "\" object)" + line $ "pattern " <> camelName <> " = SignalProxy" + line $ "#else" + line $ "pattern " <> camelName <> " = SignalProxy :: forall info object. " + <> "info ~ ResolveSignal \"" <> lcFirst camelName + <> "\" object => SignalProxy object info" + line $ "#endif" + exportDecl $ "pattern " <> camelName -- | Qualified name for the "(sigName, info)" tag for a given signal. signalInfoName :: Name -> Signal -> CodeGen Text @@ -92,17 +97,13 @@ infos <- fullObjectSignalList n o >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal - return $ "'(\"" <> sigName signal + return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal <> "\", " <> si <> ")") - -- The "notify::[property]" signal is a generic signal used for - -- connecting to property notifications. - let allSignals = infos <> - ["'(\"notify::[property]\", GObjectNotifySignalInfo)"] group $ do let signalListType = name <> "SignalList" line $ "type instance SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ " - <> T.intercalate ", " allSignals <> "] :: [(Symbol, *)])" + <> T.intercalate ", " infos <> "] :: [(Symbol, *)])" -- | Signal instances for interfaces. genInterfaceSignals :: Name -> Interface -> CodeGen () @@ -112,17 +113,10 @@ infos <- fullInterfaceSignalList n iface >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal - return $ "'(\"" <> sigName signal + return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal <> "\", " <> si <> ")") - isGO <- apiIsGObject n (APIInterface iface) - -- The "notify::[property]" signal is a generic signal used for - -- connecting to property notifications of a GObject. - let allSignals = - if isGO - then infos <> ["'(\"notify::[property]\", GObjectNotifySignalInfo)"] - else infos group $ do let signalListType = name <> "SignalList" line $ "type instance SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ " - <> T.intercalate ", " allSignals <> "] :: [(Symbol, *)])" + <> T.intercalate ", " infos <> "] :: [(Symbol, *)])" diff --git a/src/GI/Overrides.hs b/src/GI/Overrides.hs --- a/src/GI/Overrides.hs +++ b/src/GI/Overrides.hs @@ -137,15 +137,15 @@ -- | Filter a set of named objects based on a lookup list of names to -- ignore. -filterNamed :: [(Name, a)] -> S.Set Text -> [(Name, a)] -filterNamed set ignores = - filter ((`S.notMember` ignores) . name . fst) set +filterMethods :: [Method] -> S.Set Text -> [Method] +filterMethods set ignores = + filter ((`S.notMember` ignores) . name . methodName) set -- | Filter one API according to the given config. filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API) filterOneAPI ovs (n, APIStruct s, maybeIgnores) = (n, APIStruct s {structMethods = maybe (structMethods s) - (filterNamed (structMethods s)) + (filterMethods (structMethods s)) maybeIgnores, structFields = if n `S.member` sealedStructs ovs then [] @@ -153,17 +153,17 @@ -- The rest only apply if there are ignores. filterOneAPI _ (n, api, Nothing) = (n, api) filterOneAPI _ (n, APIObject o, Just ignores) = - (n, APIObject o {objMethods = filterNamed (objMethods o) ignores, + (n, APIObject o {objMethods = filterMethods (objMethods o) ignores, objSignals = filter ((`S.notMember` ignores) . sigName) (objSignals o) }) filterOneAPI _ (n, APIInterface i, Just ignores) = - (n, APIInterface i {ifMethods = filterNamed (ifMethods i) ignores, + (n, APIInterface i {ifMethods = filterMethods (ifMethods i) ignores, ifSignals = filter ((`S.notMember` ignores) . sigName) (ifSignals i) }) filterOneAPI _ (n, APIUnion u, Just ignores) = - (n, APIUnion u {unionMethods = filterNamed (unionMethods u) ignores}) + (n, APIUnion u {unionMethods = filterMethods (unionMethods u) ignores}) filterOneAPI _ (n, api, _) = (n, api) -- | Given a list of APIs modify them according to the given config. diff --git a/src/GI/Properties.hs b/src/GI/Properties.hs --- a/src/GI/Properties.hs +++ b/src/GI/Properties.hs @@ -121,6 +121,13 @@ line $ "construct" <> pName <> " val = constructObjectProperty" <> tStr <> " \"" <> propName prop <> "\" val" +-- | The property name as a lexically valid Haskell identifier. Note +-- that this is not escaped, since it is assumed that it will be used +-- with a prefix, so if a property is named "class", for example, this +-- will return "class". +hPropName :: Property -> Text +hPropName = lcFirst . hyphensToCamelCase . propName + genObjectProperties :: Name -> Object -> CodeGen () genObjectProperties n o = do isGO <- apiIsGObject n (APIObject o) @@ -129,7 +136,7 @@ allProps <- fullObjectPropertyList n o >>= mapM (\(owner, prop) -> do pi <- infoType owner prop - return $ "'(\"" <> propName prop + return $ "'(\"" <> hPropName prop <> "\", " <> pi <> ")") genProperties n (objProperties o) allProps @@ -138,7 +145,7 @@ allProps <- fullInterfacePropertyList n iface >>= mapM (\(owner, prop) -> do pi <- infoType owner prop - return $ "'(\"" <> propName prop + return $ "'(\"" <> hPropName prop <> "\", " <> pi <> ")") genProperties n (ifProperties iface) allProps @@ -242,8 +249,7 @@ line $ "type AttrBaseTypeConstraint " <> it <> " = " <> classConstraint name line $ "type AttrGetType " <> it <> " = " <> outType - line $ "type AttrLabel " <> it <> " = \"" - <> name <> "::" <> propName prop <> "\"" + line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\"" line $ "attrGet _ = " <> getter line $ "attrSet _ = " <> setter line $ "attrConstruct _ = " <> constructor diff --git a/src/GI/Signal.hs b/src/GI/Signal.hs --- a/src/GI/Signal.hs +++ b/src/GI/Signal.hs @@ -17,13 +17,14 @@ import Text.Show.Pretty (ppShow) import GI.API -import GI.Callable (hOutType, arrayLengths, wrapMaybe) +import GI.Callable (hOutType, arrayLengths, wrapMaybe, fixupCallerAllocates) import GI.Code import GI.Conversions import GI.SymbolNaming import GI.Transfer (freeContainerType) import GI.Type -import GI.Util (parenthesize, withComment, tshow, terror, ucFirst, lcFirst) +import GI.Util (parenthesize, withComment, tshow, terror, ucFirst, lcFirst, + prime) -- The prototype of the callback on the Haskell side (what users of -- the binding will see) @@ -119,7 +120,7 @@ -- the callback deal with it. return aname where - lname = escapeReserved $ argName $ args callable !! length + lname = escapedArgName $ args callable !! length convertAndFree :: ExcCodeGen Text convertAndFree = do @@ -141,7 +142,7 @@ prepareInArg :: Callable -> Arg -> ExcCodeGen Text prepareInArg cb arg = do - let name = (escapeReserved . argName) arg + let name = escapedArgName arg case argType arg of t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name _ -> do @@ -150,17 +151,29 @@ prepareInoutArg :: Arg -> ExcCodeGen Text prepareInoutArg arg = do - let name = (escapeReserved . argName) arg + let name = escapedArgName arg name' <- genConversion name $ apply $ M "peek" convert name' $ fToH (argType arg) (transfer arg) saveOutArg :: Arg -> ExcCodeGen () saveOutArg arg = do - let name = (escapeReserved . argName) arg + let name = escapedArgName arg name' = "out" <> name when (transfer arg /= TransferEverything) $ notImplementedError $ "Unexpected transfer type for \"" <> name <> "\"" - name'' <- convert name' $ hToF (argType arg) TransferEverything + isMaybe <- wrapMaybe arg + name'' <- if isMaybe + then do + let name'' = prime name' + line $ name'' <> " <- case " <> name' <> " of" + indent $ do + line "Nothing -> return nullPtr" + line $ "Just " <> name'' <> " -> do" + indent $ do + converted <- convert name'' $ hToF (argType arg) TransferEverything + line $ "return " <> converted + return name'' + else convert name' $ hToF (argType arg) TransferEverything line $ "poke " <> name <> " " <> name'' -- The wrapper itself, marshalling to and from Haskell. The first @@ -174,7 +187,7 @@ genCallbackWrapper subsec cb name' dataptrs hInArgs hOutArgs isSignal = do let cName arg = if arg `elem` dataptrs then "_" - else (escapeReserved . argName) arg + else escapedArgName arg cArgNames = map cName (args cb) wrapperName = lcFirst name' <> "Wrapper" @@ -209,8 +222,7 @@ let maybeReturn = case returnType cb of TBasicType TVoid -> [] _ -> ["result"] - argName' = escapeReserved . argName - returnVars = maybeReturn <> map (("out"<>) . argName') hOutArgs + returnVars = maybeReturn <> map (("out"<>) . escapedArgName) hOutArgs returnBind = case returnVars of [] -> "" [r] -> r <> " <- " @@ -253,15 +265,16 @@ <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb) else do let closure = lcFirst name' <> "Closure" + cb' = fixupCallerAllocates cb handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for " <> name' <> "\n-- Error was : " <> describeCGError e)) (genClosure name' name' closure False >> - genCCallbackPrototype name' cb name' False >> + genCCallbackPrototype name' cb' name' False >> genCallbackWrapperFactory name' name' >> - genHaskellCallbackPrototype name' cb name' hInArgs hOutArgs >> - genCallbackWrapper name' cb name' dataptrs hInArgs hOutArgs False) + genHaskellCallbackPrototype name' cb' name' hInArgs hOutArgs >> + genCallbackWrapper name' cb' name' dataptrs hInArgs hOutArgs False) -- | Return the name for the signal in Haskell CamelCase conventions. signalHaskellName :: Text -> Text diff --git a/src/GI/Struct.hs b/src/GI/Struct.hs --- a/src/GI/Struct.hs +++ b/src/GI/Struct.hs @@ -1,4 +1,6 @@ module GI.Struct ( genStructOrUnionFields + , genZeroStruct + , genZeroUnion , extractCallbacksInStruct , fixAPIStructs , ignoreStruct) @@ -101,3 +103,27 @@ ":" <> fieldName field <> "\" :: " <> describeCGError e)) (buildFieldGetter n field) + +-- | 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 n size isBoxed = + when (size /= 0) $ group $ do + name <- upperName n + let builder = "newZero" <> name + tsize = tshow size + line $ "-- | Construct a `" <> name <> "` struct initialized to zero." + line $ builder <> " :: MonadIO m => m " <> name + line $ builder <> " = liftIO $ " <> + if isBoxed + then "callocBoxedBytes " <> tsize <> " >>= wrapBoxed " <> name + else "callocBytes " <> tsize <> " >>= wrapPtr " <> name + exportDecl builder + +-- | Specialization for structs of `genZeroSU`. +genZeroStruct :: Name -> Struct -> CodeGen () +genZeroStruct n s = genZeroSU n (structSize s) (structIsBoxed s) + +-- | Specialization for unions of `genZeroSU`. +genZeroUnion :: Name -> Union -> CodeGen () +genZeroUnion n u = genZeroSU n (unionSize u) (unionIsBoxed u) diff --git a/src/GI/SymbolNaming.hs b/src/GI/SymbolNaming.hs --- a/src/GI/SymbolNaming.hs +++ b/src/GI/SymbolNaming.hs @@ -4,15 +4,12 @@ , lowerName , upperName , noName - , escapeReserved + , escapedArgName , classConstraint , hyphensToCamelCase , underscoresToCamelCase ) where -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid) -#endif import Data.Text (Text) import qualified Data.Text as T @@ -24,8 +21,8 @@ classConstraint :: Text -> Text classConstraint n = n <> "K" -lowerName :: Name -> CodeGen Text -lowerName (Name _ s) = return . T.concat . rename . T.split (== '_') $ s +lowerName :: Name -> Text +lowerName (Name _ s) = T.concat . rename . T.split (== '_') $ s where rename [w] = [lcFirst w] rename (w:ws) = lcFirst w : map ucFirst' ws @@ -85,6 +82,16 @@ underscoresToCamelCase :: Text -> Text underscoresToCamelCase = T.concat . map ucFirst . T.split (== '_') +-- | Name for the given argument, making sure it is a valid Haskell +-- argument name (and escaping it if not). +escapedArgName :: Arg -> Text +escapedArgName arg + | "_" `T.isPrefixOf` argCName arg = argCName arg + | otherwise = + escapeReserved . lcFirst . underscoresToCamelCase . argCName $ arg + +-- | Reserved symbols, either because they are Haskell syntax or +-- because the clash with symbols in scope for the generated bindings. escapeReserved :: Text -> Text escapeReserved "type" = "type_" escapeReserved "in" = "in_" diff --git a/src/GI/Transfer.hs b/src/GI/Transfer.hs --- a/src/GI/Transfer.hs +++ b/src/GI/Transfer.hs @@ -233,7 +233,12 @@ then case direction arg of DirectionIn -> freeIn (transfer arg) (argType arg) label len DirectionOut -> freeOut label - DirectionInout -> freeOut label + DirectionInout -> + -- Caller-allocates arguments are like "in" arguments for + -- memory management purposes. + if argCallerAllocates arg + then freeIn (transfer arg) (argType arg) label len + else freeOut label else return [] -- | Same thing as freeInArg, but called in case the call to C didn't @@ -244,4 +249,9 @@ case direction arg of DirectionIn -> freeInOnError (transfer arg) (argType arg) label len DirectionOut -> freeOut label - DirectionInout -> freeOut label + DirectionInout -> + -- Caller-allocates arguments are like "in" arguments for + -- memory management purposes. + if argCallerAllocates arg + then freeInOnError (transfer arg) (argType arg) label len + else freeOut label diff --git a/src/GI/Type.hs b/src/GI/Type.hs --- a/src/GI/Type.hs +++ b/src/GI/Type.hs @@ -1,6 +1,7 @@ module GI.Type ( BasicType(..) + , isBasicScalar , Type(..) , io , ptr @@ -13,7 +14,6 @@ import qualified Data.Text as T import Data.Text (Text) --- This enum mirrors the definition in gitypes.h. data BasicType = TVoid | TBoolean @@ -31,6 +31,8 @@ | TGType | TUTF8 | TFileName + | TIntPtr + | TUIntPtr deriving (Eq, Enum, Show, Ord) -- This type represents the types found in GObject Introspection @@ -50,6 +52,20 @@ | TVariant | TParamSpec deriving (Eq, Show, Ord) + +-- | Whether the given type is a basic scalar, i.e. everything that is +-- not a pointer to a memory region. +isBasicScalar :: Type -> Bool +isBasicScalar (TBasicType b) = basicIsScalar b +isBasicScalar _ = False + +-- | Whether the given basic type is a scalar, i.e. not a pointer to a +-- memory region. +basicIsScalar :: BasicType -> Bool +basicIsScalar TVoid = False +basicIsScalar TUTF8 = False +basicIsScalar TFileName = False +basicIsScalar _ = True con :: Text -> [TypeRep] -> TypeRep con "[]" xs = mkTyConApp listCon xs diff --git a/src/GI/Util.hs b/src/GI/Util.hs --- a/src/GI/Util.hs +++ b/src/GI/Util.hs @@ -39,10 +39,10 @@ -- | Capitalize the first character of the given string. ucFirst :: Text -> Text -ucFirst "" = terror "ucFirst: empty text!" +ucFirst "" = "" ucFirst t = T.cons (toUpper $ T.head t) (T.tail t) -- | Make the first character of the given string lowercase. lcFirst :: Text -> Text -lcFirst "" = terror "lcFirst: empty string" +lcFirst "" = "" lcFirst t = T.cons (toLower $ T.head t) (T.tail t) diff --git a/src/haskell-gi.hs b/src/haskell-gi.hs --- a/src/haskell-gi.hs +++ b/src/haskell-gi.hs @@ -27,16 +27,16 @@ import GI.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API) import GI.Cabal (cabalConfig, setupHs, genCabalProject) -import GI.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, writeModuleCode, moduleCode, codeToText) +import GI.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, writeModuleCode, moduleCode, codeToText, minBaseVersion) import GI.Config (Config(..)) import GI.CodeGen (genModule) -import GI.Attributes (genAllAttributes) +import GI.OverloadedLabels (genOverloadedLabels) import GI.OverloadedSignals (genOverloadedSignalConnectors) import GI.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps) import GI.ProjectInfo (licenseText) import GI.Util (ucFirst) -data Mode = GenerateCode | Dump | Attributes | Signals | Help +data Mode = GenerateCode | Dump | Labels | Signals | Help data Options = Options { optMode :: Mode, @@ -62,12 +62,12 @@ optDescrs = [ Option "h" ["help"] (NoArg $ \opt -> opt { optMode = Help }) "\tprint this gentle help text", - Option "a" ["attributes"] (NoArg $ \opt -> opt {optMode = Attributes}) - "generate generic attribute accesors", Option "c" ["connectors"] (NoArg $ \opt -> opt {optMode = Signals}) "generate generic signal connectors", Option "d" ["dump"] (NoArg $ \opt -> opt { optMode = Dump }) "\tdump internal representation", + Option "l" ["labels"] (NoArg $ \opt -> opt {optMode = Labels}) + "generate overloaded labels", Option "n" ["no-cabal"] (NoArg $ \opt -> opt {optCabal = False}) "\tdo not generate .cabal file", Option "o" ["overrides"] (ReqArg @@ -98,16 +98,17 @@ gir <- loadRawGIRInfo verbose name version extraPaths return (girAPIs gir) --- Generate all generic accessor functions ("_label", for example). -genGenericAttrs :: Options -> Overrides -> [Text] -> [FilePath] -> IO () -genGenericAttrs options ovs modules extraPaths = do +-- | Generate overloaded labels ("_label", for example). +genLabels :: Options -> Overrides -> [Text] -> [FilePath] -> IO () +genLabels options ovs modules extraPaths = do apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules let allAPIs = M.unions (map M.fromList apis) cfg = Config {modName = Nothing, verbose = optVerbose options, overrides = ovs} - putStrLn $ "\t* Generating GI.Properties" - m <- genCode cfg allAPIs ["GI", "Properties"] (genAllAttributes (M.toList allAPIs)) + putStrLn $ "\t* Generating GI.OverloadedLabels" + m <- genCode cfg allAPIs ["GI", "OverloadedLabels"] + (genOverloadedLabels (M.toList allAPIs)) _ <- writeModuleCode (optVerbose options) (optOutputDir options) m return () @@ -154,11 +155,11 @@ putStrLn $ "\t\t+ " ++ fname -- The module is not a dep of itself let usedDeps = S.delete name modDeps - -- We only list as dependencies in the cabal file the -- dependencies that we use, disregarding what the .gir file says. actualDeps = filter ((`S.member` usedDeps) . girNSName) girDeps - (err, m) <- evalCodeGen cfg allAPIs [] (genCabalProject gir actualDeps moduleList) + baseVersion = minBaseVersion m + (err, m) <- evalCodeGen cfg allAPIs [] (genCabalProject gir actualDeps moduleList baseVersion) case err of Nothing -> do TIO.writeFile fname (codeToText (moduleCode m)) @@ -189,7 +190,7 @@ Right ovs -> case optMode options of GenerateCode -> forM_ names (processMod options ovs extraPaths) - Attributes -> genGenericAttrs options ovs names extraPaths + Labels -> genLabels options ovs names extraPaths Signals -> genGenericConnectors options ovs names extraPaths Dump -> forM_ names (dump options ovs) Help -> putStr showHelp