diff --git a/hoppy-generator.cabal b/hoppy-generator.cabal --- a/hoppy-generator.cabal +++ b/hoppy-generator.cabal @@ -1,5 +1,5 @@ name: hoppy-generator -version: 0.1.0 +version: 0.2.0 synopsis: C++ FFI generator - Code generator homepage: http://khumba.net/projects/hoppy license: AGPL-3 @@ -22,6 +22,7 @@ , Foreign.Hoppy.Generator.Main , Foreign.Hoppy.Generator.Spec , Foreign.Hoppy.Generator.Spec.ClassFeature + , Foreign.Hoppy.Generator.Types , Foreign.Hoppy.Generator.Version other-modules: Foreign.Hoppy.Generator.Common diff --git a/src/Foreign/Hoppy/Generator/Language/Cpp.hs b/src/Foreign/Hoppy/Generator/Language/Cpp.hs --- a/src/Foreign/Hoppy/Generator/Language/Cpp.hs +++ b/src/Foreign/Hoppy/Generator/Language/Cpp.hs @@ -46,6 +46,7 @@ import Data.Foldable (forM_) import Data.List (intercalate, intersperse) import Foreign.Hoppy.Generator.Spec +import Foreign.Hoppy.Generator.Types cppNameSeparator :: String cppNameSeparator = "__" @@ -195,8 +196,8 @@ sayVar :: MonadWriter [Chunk] m => String -> Maybe [String] -> Type -> m () sayVar name maybeParamNames t = sayType' t maybeParamNames topPrecedence $ say name --- | @sayType maybeParamNames t@ renders @t@ in C++ syntax. If @t@ is a 'TFn', --- then @maybeParamNames@ will provide variable names for parameters, if +-- | @sayType maybeParamNames t@ renders @t@ in C++ syntax. If @t@ is a +-- 'fnT', then @maybeParamNames@ will provide variable names for parameters, if -- present. sayType :: MonadWriter [Chunk] m => Maybe [String] -> Type -> m () sayType maybeParamNames t = sayType' t maybeParamNames topPrecedence $ return () @@ -210,38 +211,38 @@ then unwrappedOuter else say "(" >> unwrappedOuter >> say ")" in case t of - TVoid -> say "void" >> outer - TBool -> say "bool" >> outer - TChar -> say "char" >> outer - TUChar -> say "unsigned char" >> outer - TShort -> say "short" >> outer - TUShort -> say "unsigned short" >> outer - TInt -> say "int" >> outer - TUInt -> say "unsigned int" >> outer - TLong -> say "long" >> outer - TULong -> say "unsigned long" >> outer - TLLong -> say "long long" >> outer - TULLong -> say "unsigned long long" >> outer - TFloat -> say "float" >> outer - TDouble -> say "double" >> outer - TInt8 -> say "int8_t" >> outer - TInt16 -> say "int16_t" >> outer - TInt32 -> say "int32_t" >> outer - TInt64 -> say "int64_t" >> outer - TWord8 -> say "uint8_t" >> outer - TWord16 -> say "uint16_t" >> outer - TWord32 -> say "uint32_t" >> outer - TWord64 -> say "uint64_t" >> outer - TPtrdiff -> say "ptrdiff_t" >> outer - TSize -> say "size_t" >> outer - TSSize -> say "ssize_t" >> outer - TEnum e -> sayIdentifier (enumIdentifier e) >> outer - TBitspace b -> case bitspaceCppTypeIdentifier b of + Internal_TVoid -> say "void" >> outer + Internal_TBool -> say "bool" >> outer + Internal_TChar -> say "char" >> outer + Internal_TUChar -> say "unsigned char" >> outer + Internal_TShort -> say "short" >> outer + Internal_TUShort -> say "unsigned short" >> outer + Internal_TInt -> say "int" >> outer + Internal_TUInt -> say "unsigned int" >> outer + Internal_TLong -> say "long" >> outer + Internal_TULong -> say "unsigned long" >> outer + Internal_TLLong -> say "long long" >> outer + Internal_TULLong -> say "unsigned long long" >> outer + Internal_TFloat -> say "float" >> outer + Internal_TDouble -> say "double" >> outer + Internal_TInt8 -> say "int8_t" >> outer + Internal_TInt16 -> say "int16_t" >> outer + Internal_TInt32 -> say "int32_t" >> outer + Internal_TInt64 -> say "int64_t" >> outer + Internal_TWord8 -> say "uint8_t" >> outer + Internal_TWord16 -> say "uint16_t" >> outer + Internal_TWord32 -> say "uint32_t" >> outer + Internal_TWord64 -> say "uint64_t" >> outer + Internal_TPtrdiff -> say "ptrdiff_t" >> outer + Internal_TSize -> say "size_t" >> outer + Internal_TSSize -> say "ssize_t" >> outer + Internal_TEnum e -> sayIdentifier (enumIdentifier e) >> outer + Internal_TBitspace b -> case bitspaceCppTypeIdentifier b of Just identifier -> sayIdentifier identifier >> outer Nothing -> sayType' (bitspaceType b) maybeParamNames outerPrec unwrappedOuter - TPtr t' -> sayType' t' Nothing prec $ say "*" >> outer - TRef t' -> sayType' t' Nothing prec $ say "&" >> outer - TFn paramTypes retType -> sayType' retType Nothing prec $ do + Internal_TPtr t' -> sayType' t' Nothing prec $ say "*" >> outer + Internal_TRef t' -> sayType' t' Nothing prec $ say "&" >> outer + Internal_TFn paramTypes retType -> sayType' retType Nothing prec $ do outer say "(" sequence_ $ intersperse (say ", ") $ @@ -249,10 +250,12 @@ \(ptype, pname) -> sayType' ptype Nothing topPrecedence $ forM_ pname say say ")" - TCallback cb -> says [callbackImplClassName cb, "*"] >> outer - TObj cls -> sayIdentifier (classIdentifier cls) >> outer - TObjToHeap cls -> sayType' (TRef $ TConst $ TObj cls) maybeParamNames outerPrec unwrappedOuter - TConst t' -> sayType' t' maybeParamNames outerPrec $ say "const" >> unwrappedOuter + Internal_TCallback cb -> says [callbackImplClassName cb, "*"] >> outer + Internal_TObj cls -> sayIdentifier (classIdentifier cls) >> outer + Internal_TObjToHeap cls -> + sayType' (refT $ constT $ objT cls) maybeParamNames outerPrec unwrappedOuter + Internal_TToGc t' -> sayType' t' maybeParamNames outerPrec unwrappedOuter + Internal_TConst t' -> sayType' t' maybeParamNames outerPrec $ say "const" >> unwrappedOuter -- TODO ^ Is using the outer stuff correctly here? topPrecedence :: Int @@ -260,7 +263,7 @@ typePrecedence :: Type -> Int typePrecedence t = case t of - TFn {} -> 10 - TPtr {} -> 9 - TRef {} -> 9 + Internal_TFn {} -> 10 + Internal_TPtr {} -> 9 + Internal_TRef {} -> 9 _ -> 8 diff --git a/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs b/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs --- a/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs +++ b/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs @@ -42,6 +42,7 @@ import Foreign.Hoppy.Generator.Common import Foreign.Hoppy.Generator.Language.Cpp import Foreign.Hoppy.Generator.Spec +import Foreign.Hoppy.Generator.Types data CoderDirection = DoDecode | DoEncode deriving (Eq, Show) @@ -99,7 +100,7 @@ sayFunction :: String -> [String] -> Type -> Maybe (Generator ()) -> Generator () sayFunction name paramNames t maybeBody = do case t of - TFn {} -> return () + Internal_TFn {} -> return () _ -> abort $ concat ["sayFunction: A function type is required, given ", show t, "."] say "\n" -- New top-level structure, leave a blank line. sayVar name (Just paramNames) t @@ -163,7 +164,7 @@ sayBody ExportClass cls -> when sayBody $ do - let clsPtr = TPtr $ TObj cls + let clsPtr = ptrT $ objT cls justClsPtr = Just clsPtr -- TODO Is this redundant for a completely empty class? (No ctors or methods, private dtor.) addReqsM $ classReqs cls -- This is needed at least for the delete function. @@ -181,7 +182,7 @@ when (classDtorIsPublic cls) $ sayFunction (classDeleteFnCppName cls) ["self"] - (TFn [TPtr $ TConst $ TObj cls] TVoid) $ + (fnT [ptrT $ constT $ objT cls] voidT) $ Just $ say "delete self;\n" -- Export each of the class's methods. @@ -225,17 +226,17 @@ genUpcastFns cls ancestorCls = do sayFunction (classCastFnCppName cls ancestorCls) ["self"] - (TFn [TPtr $ TConst $ TObj cls] $ TPtr $ TConst $ TObj ancestorCls) + (fnT [ptrT $ constT $ objT cls] $ ptrT $ constT $ objT ancestorCls) (Just $ say "return self;\n") forM_ (classSuperclasses ancestorCls) $ genUpcastFns cls genDowncastFns :: Class -> Class -> Generator () genDowncastFns cls ancestorCls = unless (classIsMonomorphicSuperclass ancestorCls) $ do - let clsPtr = TPtr $ TConst $ TObj cls - ancestorPtr = TPtr $ TConst $ TObj ancestorCls + let clsPtr = ptrT $ constT $ objT cls + ancestorPtr = ptrT $ constT $ objT ancestorCls sayFunction (classCastFnCppName ancestorCls cls) ["self"] - (TFn [ancestorPtr] clsPtr) $ Just $ do + (fnT [ancestorPtr] clsPtr) $ Just $ do say "return dynamic_cast<" sayType Nothing clsPtr say ">(self);\n" @@ -244,7 +245,7 @@ sayExportVariable :: Variable -> Generator () sayExportVariable v = do let (isConst, deconstType) = case varType v of - TConst t -> (True, t) + Internal_TConst t -> (True, t) t -> (False, t) -- Say a getter function. @@ -261,7 +262,7 @@ (VarWrite $ varIdentifier v) Nothing [deconstType] - TVoid + voidT True data CallType = @@ -289,18 +290,18 @@ sayFunction (externalNameToCpp extName) (maybe id (const ("self":)) maybeThisType $ zipWith3 (\t ctm -> case t of - TCallback {} -> toArgNameAlt + Internal_TCallback {} -> toArgNameAlt _ -> if isJust ctm then toArgNameAlt else toArgName) paramTypes paramCTypeMaybes [1..paramCount]) - (TFn (maybe id (:) maybeThisType paramCTypes) retCType) $ + (fnT (maybe id (:) maybeThisType paramCTypes) retCType) $ if not sayBody then Nothing else Just $ do -- Convert arguments that aren't passed in directly. mapM_ (sayArgRead DoDecode) $ zip3 [1..] paramTypes paramCTypeMaybes - -- Determine how to call the exported function or method. - let sayCall = case callType of + let -- Determines how to call the exported function or method. + sayCall = case callType of CallOp op -> do say "(" let effectiveParamCount = paramCount + if isJust maybeThisType then 1 else 0 @@ -328,25 +329,36 @@ VarRead identifier -> sayIdentifier identifier VarWrite identifier -> sayIdentifier identifier >> says [" = ", toArgName 1] - -- Write the call, transforming the return value if necessary. - case (retType, retCTypeMaybe) of - (TVoid, Nothing) -> sayCall >> say ";\n" - (_, Nothing) -> say "return " >> sayCall >> say ";\n" - (TBitspace b, Just _) -> do - addReqsM $ bitspaceReqs b - let convFn = bitspaceFromCppValueFn b - say "return " - forM_ convFn $ \f -> says [f, "("] - sayCall - when (isJust convFn) $ say ")" - say ";\n"; - (TRef cls, Just (TPtr cls')) | cls == cls' -> say "return &(" >> sayCall >> say ");\n" - (TObj cls, Just (TPtr (TConst (TObj cls')))) | cls == cls' -> sayReturnNewCopy cls sayCall - (TObjToHeap cls, Just (TPtr (TObj cls'))) | cls == cls' -> sayReturnNewCopy cls sayCall - ts -> abort $ concat ["sayExportFn: Unexpected return types ", show ts, - "while generating binding for ", show extName, "."] + -- Writes the call, transforming the return value if necessary. + -- These translations should be kept in sync with typeToCType. + sayCallAndReturn retType' retCTypeMaybe' = case (retType', retCTypeMaybe') of + (Internal_TVoid, Nothing) -> sayCall >> say ";\n" + (_, Nothing) -> say "return " >> sayCall >> say ";\n" + (Internal_TBitspace b, Just _) -> do + addReqsM $ bitspaceReqs b + let convFn = bitspaceFromCppValueFn b + say "return " + forM_ convFn $ \f -> says [f, "("] + sayCall + when (isJust convFn) $ say ")" + say ";\n"; + (Internal_TRef cls, Just (Internal_TPtr cls')) | cls == cls' -> + say "return &(" >> sayCall >> say ");\n" + (Internal_TObj cls, + Just (Internal_TPtr (Internal_TConst (Internal_TObj cls')))) | cls == cls' -> + sayReturnNew cls sayCall + (Internal_TObjToHeap cls, Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' -> + sayReturnNew cls sayCall + (Internal_TToGc (Internal_TObj cls), + Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' -> + sayReturnNew cls sayCall + (Internal_TToGc retType'', _) -> sayCallAndReturn retType'' retCTypeMaybe' + ts -> abort $ concat ["sayExportFn: Unexpected return types ", show ts, + "while generating binding for ", show extName, "."] - where sayReturnNewCopy cls sayCall = + sayCallAndReturn retType retCTypeMaybe + + where sayReturnNew cls sayCall = say "return new" >> sayIdentifier (classIdentifier cls) >> say "(" >> sayCall >> say ");\n" @@ -355,7 +367,7 @@ -- callback. sayArgRead :: CoderDirection -> (Int, Type, Maybe Type) -> Generator () sayArgRead dir (n, stripConst . normalizeType -> cppType, maybeCType) = case cppType of - TBitspace b -> case maybeCType of + Internal_TBitspace b -> case maybeCType of Just cType -> do let cppTypeId = fromMaybe (error $ concat ["sayArgRead: Expected ", show b, @@ -376,7 +388,7 @@ Nothing -> return () - TCallback cb -> do + Internal_TCallback cb -> do case dir of DoDecode -> return () DoEncode -> abort $ concat @@ -384,17 +396,28 @@ show cb, "."] says [callbackClassName cb, " ", toArgName n, "(", toArgNameAlt n, ");\n"] - TRef t -> convertObj t + Internal_TRef t -> convertObj t - TObj _ -> convertObj $ TConst cppType - TObjToHeap cls -> case dir of - DoDecode -> error $ tObjToHeapWrongDirectionErrorMsg (Just "sayArgRead") cls + Internal_TObj _ -> convertObj $ constT cppType + + Internal_TObjToHeap cls -> case dir of + DoDecode -> error $ objToHeapTWrongDirectionErrorMsg (Just "sayArgRead") cls DoEncode -> do sayIdentifier $ classIdentifier cls says ["* ", toArgName n, " = new "] sayIdentifier $ classIdentifier cls says ["(", toArgNameAlt n, ");\n"] + Internal_TToGc t' -> case dir of + DoDecode -> error $ toGcTWrongDirectionErrorMsg (Just "sayArgRead") t' + DoEncode -> do + let newCppType = case t' of + -- In the case of (TToGc (TObj _)), we copy the temporary object to + -- the heap and let the foreign language manage that value. + Internal_TObj cls -> objToHeapT cls + _ -> t' + sayArgRead dir (n, cppType, typeToCType newCppType) + -- Primitive types don't need to be encoded/decoded. But if maybeCType is a -- Just, then we're expected to do some encoding/decoding, so something is -- wrong. @@ -407,10 +430,10 @@ where convertObj cppType' = case dir of DoDecode -> do - sayVar (toArgName n) Nothing $ TRef cppType' + sayVar (toArgName n) Nothing $ refT cppType' says [" = *", toArgNameAlt n, ";\n"] DoEncode -> do - sayVar (toArgName n) Nothing $ TPtr cppType' + sayVar (toArgName n) Nothing $ ptrT cppType' says [" = &", toArgNameAlt n, ";\n"] sayArgNames :: Int -> Generator () @@ -425,8 +448,8 @@ paramTypes = callbackParams cb paramCount = length paramTypes retType = callbackReturn cb - cbType = TCallback cb - fnType = TFn paramTypes retType + cbType = callbackT cb + fnType = fnT paramTypes retType -- The function pointer we receive from foreign code will work with C-types, -- so determine what that function looks like. @@ -435,8 +458,8 @@ addReqsM . mconcat =<< mapM typeReqs (retType:paramTypes) - let fnCType = TFn paramCTypes retCType - fnPtrCType = TPtr fnCType + let fnCType = fnT paramCTypes retCType + fnPtrCType = ptrT fnCType if not sayBody then do @@ -453,7 +476,7 @@ says [" ", implClassName, "(const ", implClassName, "&);\n"] says [" ", implClassName, "& operator=(const ", implClassName, "&);\n"] say "\n" - say " " >> sayVar "f_" Nothing (TConst fnPtrCType) >> say ";\n" + say " " >> sayVar "f_" Nothing (constT fnPtrCType) >> say ";\n" say " void (*const release_)(void(*)());\n" say " const bool releaseRelease_;\n" say "};\n" @@ -500,9 +523,9 @@ -- Invoke the function pointer into foreign code. let sayCall = say "f_(" >> sayArgNames paramCount >> say ")" case (retType, retCTypeMaybe) of - (TVoid, Nothing) -> sayCall >> say ";\n" + (Internal_TVoid, Nothing) -> sayCall >> say ";\n" (_, Nothing) -> say "return " >> sayCall >> say ";\n" - (TBitspace b, Just _) -> do + (Internal_TBitspace b, Just _) -> do addReqsM $ bitspaceReqs b let convFn = bitspaceToCppValueFn b say "return " @@ -510,14 +533,17 @@ sayCall when (isJust convFn) $ say ")" say ";\n"; - (TObj cls1, Just retCType@(TPtr (TConst (TObj cls2)))) | cls1 == cls2 -> do - sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n" - sayVar "result" Nothing retType >> say " = *resultPtr;\n" - say "delete resultPtr;\n" - say "return result;\n" - (TRef (TConst (TObj cls1)), Just (TPtr (TConst (TObj cls2)))) | cls1 == cls2 -> + (Internal_TObj cls1, Just retCType@(Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) + | cls1 == cls2 -> do + sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n" + sayVar "result" Nothing retType >> say " = *resultPtr;\n" + say "delete resultPtr;\n" + say "return result;\n" + (Internal_TRef (Internal_TConst (Internal_TObj cls1)), + Just (Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) | cls1 == cls2 -> say "return *(" >> sayCall >> say ");\n" - (TRef (TObj cls1), Just (TPtr (TObj cls2))) | cls1 == cls2 -> + (Internal_TRef (Internal_TObj cls1), + Just (Internal_TPtr (Internal_TObj cls2))) | cls1 == cls2 -> say "return *(" >> sayCall >> say ");\n" ts -> abort $ concat ["sayExportCallback: Unexpected return types ", show ts, "."] @@ -528,15 +554,15 @@ (map toArgName [1..paramCount]) fnType $ Just $ do case retType of - TVoid -> say "(*impl_)(" + Internal_TVoid -> say "(*impl_)(" _ -> say "return (*impl_)(" sayArgNames paramCount say ");\n" -- Render the function that creates a new callback object. - let newCallbackFnType = TFn [ fnPtrCType - , TPtr (TFn [TPtr $ TFn [] TVoid] TVoid) - , TBool + let newCallbackFnType = fnT [ fnPtrCType + , ptrT (fnT [ptrT $ fnT [] voidT] voidT) + , boolT ] cbType sayFunction fnName ["f", "release", "releaseRelease"] newCallbackFnType $ Just $ @@ -550,58 +576,61 @@ -- converting the bitspace value, when the bitspace has a C++ type we have to -- assume that it needs to be converted. The caller will sort out whether a -- conversion is actually requested. - TBitspace b -> case bitspaceCppTypeIdentifier b of + Internal_TBitspace b -> case bitspaceCppTypeIdentifier b of Just _ -> Just $ bitspaceType b Nothing -> Nothing - TRef t' -> Just $ TPtr t' - TObj _ -> Just $ TPtr $ TConst t - TObjToHeap cls -> Just $ TPtr $ TObj cls - TConst t' -> typeToCType t' + Internal_TRef t' -> Just $ ptrT t' + Internal_TObj _ -> Just $ ptrT $ constT t + Internal_TObjToHeap cls -> Just $ ptrT $ objT cls + Internal_TToGc t'@(Internal_TObj _) -> Just $ ptrT t' + Internal_TToGc t' -> typeToCType t' + Internal_TConst t' -> typeToCType t' _ -> Nothing typeReqs :: Type -> Generator Reqs typeReqs t = case t of - TVoid -> return mempty - TBool -> return mempty - TChar -> return mempty - TUChar -> return mempty - TShort -> return mempty - TUShort -> return mempty - TInt -> return mempty - TUInt -> return mempty - TLong -> return mempty - TULong -> return mempty - TLLong -> return mempty - TULLong -> return mempty - TFloat -> return mempty - TDouble -> return mempty - TInt8 -> return cstdintReqs - TInt16 -> return cstdintReqs - TInt32 -> return cstdintReqs - TInt64 -> return cstdintReqs - TWord8 -> return cstdintReqs - TWord16 -> return cstdintReqs - TWord32 -> return cstdintReqs - TWord64 -> return cstdintReqs - TPtrdiff -> return cstddefReqs - TSize -> return cstddefReqs - TSSize -> return cstddefReqs - TEnum e -> return $ enumReqs e - TBitspace b -> typeReqs $ bitspaceType b - TPtr t' -> typeReqs t' - TRef t' -> typeReqs t' - TFn paramTypes retType -> + Internal_TVoid -> return mempty + Internal_TBool -> return mempty + Internal_TChar -> return mempty + Internal_TUChar -> return mempty + Internal_TShort -> return mempty + Internal_TUShort -> return mempty + Internal_TInt -> return mempty + Internal_TUInt -> return mempty + Internal_TLong -> return mempty + Internal_TULong -> return mempty + Internal_TLLong -> return mempty + Internal_TULLong -> return mempty + Internal_TFloat -> return mempty + Internal_TDouble -> return mempty + Internal_TInt8 -> return cstdintReqs + Internal_TInt16 -> return cstdintReqs + Internal_TInt32 -> return cstdintReqs + Internal_TInt64 -> return cstdintReqs + Internal_TWord8 -> return cstdintReqs + Internal_TWord16 -> return cstdintReqs + Internal_TWord32 -> return cstdintReqs + Internal_TWord64 -> return cstdintReqs + Internal_TPtrdiff -> return cstddefReqs + Internal_TSize -> return cstddefReqs + Internal_TSSize -> return cstddefReqs + Internal_TEnum e -> return $ enumReqs e + Internal_TBitspace b -> typeReqs $ bitspaceType b + Internal_TPtr t' -> typeReqs t' + Internal_TRef t' -> typeReqs t' + Internal_TFn paramTypes retType -> -- TODO Is the right 'ReqsType' being used recursively here? mconcat <$> mapM typeReqs (retType:paramTypes) - TCallback cb -> do + Internal_TCallback cb -> do cbClassReqs <- reqInclude . includeLocal . moduleHppPath <$> findExportModule (callbackExtName cb) -- TODO Is the right 'ReqsType' being used recursively here? fnTypeReqs <- typeReqs $ callbackToTFn cb return $ cbClassReqs `mappend` fnTypeReqs - TObj cls -> return $ classReqs cls - TObjToHeap cls -> return $ classReqs cls - TConst t' -> typeReqs t' + Internal_TObj cls -> return $ classReqs cls + Internal_TObjToHeap cls -> return $ classReqs cls + Internal_TToGc t' -> typeReqs t' + Internal_TConst t' -> typeReqs t' cstddefReqs :: Reqs cstddefReqs = reqInclude $ includeStd "cstddef" diff --git a/src/Foreign/Hoppy/Generator/Language/Haskell.hs b/src/Foreign/Hoppy/Generator/Language/Haskell.hs --- a/src/Foreign/Hoppy/Generator/Language/Haskell.hs +++ b/src/Foreign/Hoppy/Generator/Language/Haskell.hs @@ -20,6 +20,7 @@ -- | Shared portion of the Haskell code generator. Usable by binding -- definitions. module Foreign.Hoppy.Generator.Language.Haskell ( + Managed (..), getModuleName, toModuleName, -- * Code generators @@ -62,7 +63,9 @@ toHsCastPrimitiveName, toHsConstCastFnName, toHsDataTypeName, + toHsDataCtorName, toHsClassDeleteFnName, + toHsClassDeleteFnPtrName, toHsMethodName, toHsMethodName', toHsCallbackCtorName, @@ -70,6 +73,7 @@ toArgName, HsTypeSide (..), cppTypeToHsTypeAndUse, + getClassHaskellConversion, prettyPrint, ) where @@ -98,6 +102,7 @@ import Data.Tuple (swap) import Foreign.Hoppy.Generator.Common (capitalize, lowerFirst) import Foreign.Hoppy.Generator.Spec +import Foreign.Hoppy.Generator.Types import qualified Language.Haskell.Pretty as P import Language.Haskell.Syntax ( HsName (HsIdent), @@ -106,6 +111,15 @@ HsType (HsTyApp, HsTyCon, HsTyFun), ) +-- | Indicates who is managing the lifetime of an object via an object pointer. +data Managed = + Unmanaged + -- ^ The object's lifetime is being managed manually. + | Managed + -- ^ The object's lifetime is being managed by the Haskell garbage + -- collector. + deriving (Bounded, Enum, Eq, Ord) + -- | Returns the complete Haskell module name for a 'Module' in an 'Interface', -- taking into account the 'interfaceHaskellModuleBase' and the -- 'moduleHaskellName'. @@ -533,12 +547,26 @@ toHsDataTypeName :: Constness -> Class -> String toHsDataTypeName cst cls = toHsTypeName cst $ classExtName cls +-- | The name of a data constructor for one of the object pointer types. +toHsDataCtorName :: Managed -> Constness -> Class -> String +toHsDataCtorName m cst cls = case m of + Unmanaged -> base + Managed -> base ++ "Gc" + where base = toHsDataTypeName cst cls + -- | The name of the foreign function import wrapping @delete@ for the given -- class type. This is in internal to the binding; normal users should use -- 'Foreign.Hoppy.Runtime.delete'. toHsClassDeleteFnName :: Class -> String toHsClassDeleteFnName cls = 'd':'e':'l':'e':'t':'e':'\'':toHsDataTypeName Nonconst cls +-- | The name of the foreign import that imports the same function as +-- 'toHsClassDeleteFnName', but as a 'Foreign.Ptr.FunPtr' rather than an actual +-- function. +toHsClassDeleteFnPtrName :: Class -> String +toHsClassDeleteFnPtrName cls = + 'd':'e':'l':'e':'t':'e':'P':'t':'r':'\'':toHsDataTypeName Nonconst cls + -- | Returns the name of the Haskell function that invokes the given method. -- -- See also 'getClassyExtName'. @@ -584,48 +612,70 @@ cppTypeToHsTypeAndUse side t = withErrorContext (concat ["converting ", show t, " to ", show side, " type"]) $ case t of - TVoid -> return $ HsTyCon $ Special HsUnitCon + Internal_TVoid -> return $ HsTyCon $ Special HsUnitCon -- C++ has sizeof(bool) == 1, whereas Haskell can > 1, so we have to convert. - TBool -> case side of + Internal_TBool -> case side of HsCSide -> addImports hsImportForRuntime $> HsTyCon (UnQual $ HsIdent "HoppyFHR.CBool") HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Bool") - TChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CChar") - TUChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUChar") - TShort -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CShort") - TUShort -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUShort") - TInt -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CInt") - TUInt -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUInt") - TLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLong") - TULong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULong") - TLLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLLong") - TULLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULLong") - TFloat -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CFloat") - TDouble -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CDouble") - TInt8 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int8") - TInt16 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int16") - TInt32 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int32") - TInt64 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int64") - TWord8 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word8") - TWord16 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word16") - TWord32 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word32") - TWord64 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word64") - TPtrdiff -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CPtrdiff") - TSize -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CSize") - TSSize -> addImports hsImportForSystemPosixTypes $> HsTyCon (UnQual $ HsIdent "HoppySPT.CSsize") - TEnum e -> HsTyCon . UnQual . HsIdent <$> case side of + Internal_TChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CChar") + Internal_TUChar -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUChar") + Internal_TShort -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CShort") + Internal_TUShort -> + addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUShort") + Internal_TInt -> case side of + HsCSide -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CInt") + HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Int") + Internal_TUInt -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CUInt") + Internal_TLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLong") + Internal_TULong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULong") + Internal_TLLong -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CLLong") + Internal_TULLong -> + addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CULLong") + Internal_TFloat -> case side of + HsCSide -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CFloat") + HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Float") + Internal_TDouble -> case side of + HsCSide -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CDouble") + HsHsSide -> addImports hsImportForPrelude $> HsTyCon (UnQual $ HsIdent "HoppyP.Double") + Internal_TInt8 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int8") + Internal_TInt16 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int16") + Internal_TInt32 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int32") + Internal_TInt64 -> addImports hsImportForInt $> HsTyCon (UnQual $ HsIdent "HoppyDI.Int64") + Internal_TWord8 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word8") + Internal_TWord16 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word16") + Internal_TWord32 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word32") + Internal_TWord64 -> addImports hsImportForWord $> HsTyCon (UnQual $ HsIdent "HoppyDW.Word64") + Internal_TPtrdiff -> + addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CPtrdiff") + Internal_TSize -> addImports hsImportForForeignC $> HsTyCon (UnQual $ HsIdent "HoppyFC.CSize") + Internal_TSSize -> + addImports hsImportForSystemPosixTypes $> HsTyCon (UnQual $ HsIdent "HoppySPT.CSsize") + Internal_TEnum e -> HsTyCon . UnQual . HsIdent <$> case side of HsCSide -> addImports hsImportForForeignC $> "HoppyFC.CInt" HsHsSide -> importHsModuleForExtName (enumExtName e) $> toHsEnumTypeName e - TBitspace b -> case side of + Internal_TBitspace b -> case side of HsCSide -> cppTypeToHsTypeAndUse side $ bitspaceType b HsHsSide -> importHsModuleForExtName (bitspaceExtName b) $> HsTyCon (UnQual $ HsIdent $ toHsBitspaceTypeName b) - TPtr (TObj cls) -> - importHsModuleForExtName (classExtName cls) $> - HsTyCon (UnQual $ HsIdent $ toHsTypeName Nonconst $ classExtName cls) - TPtr (TConst (TObj cls)) -> - importHsModuleForExtName (classExtName cls) $> - HsTyCon (UnQual $ HsIdent $ toHsTypeName Const $ classExtName cls) - TPtr (TFn paramTypes retType) -> do + Internal_TPtr (Internal_TObj cls) -> do + -- Same as TPtr (TConst (TObj cls)), but nonconst. + importHsModuleForExtName (classExtName cls) + let dataType = HsTyCon $ UnQual $ HsIdent $ toHsTypeName Nonconst $ classExtName cls + case side of + HsCSide -> do + addImports hsImportForForeign + return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") dataType + HsHsSide -> return dataType + Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> do + -- Same as TPtr (TObj cls), but const. + importHsModuleForExtName (classExtName cls) + let dataType = HsTyCon $ UnQual $ HsIdent $ toHsTypeName Const $ classExtName cls + case side of + HsCSide -> do + addImports hsImportForForeign + return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") dataType + HsHsSide -> return dataType + Internal_TPtr (Internal_TFn paramTypes retType) -> do paramHsTypes <- mapM (cppTypeToHsTypeAndUse side) paramTypes retHsType <- cppTypeToHsTypeAndUse side retType sideFn <- case side of @@ -635,36 +685,47 @@ addImports hsImportForPrelude return $ sideFn $ foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes - TPtr t' -> do + Internal_TPtr t' -> do addImports hsImportForForeign - -- Pointers to other types (i.e. primitive number types) point to the raw - -- C++ value, so we need to use the C-side type of the pointer target - -- here. + -- Pointers to types not covered above point to raw C++ values, so we need + -- to use the C-side type of the pointer target here. HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") <$> cppTypeToHsTypeAndUse HsCSide t' - TRef t' -> cppTypeToHsTypeAndUse side $ TPtr t' - TFn paramTypes retType -> do + Internal_TRef t' -> cppTypeToHsTypeAndUse side $ ptrT t' + Internal_TFn paramTypes retType -> do paramHsTypes <- mapM (cppTypeToHsTypeAndUse side) paramTypes retHsType <- cppTypeToHsTypeAndUse side retType addImports hsImportForPrelude return $ foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes - TCallback cb -> do + Internal_TCallback cb -> do hsType <- cppTypeToHsTypeAndUse side $ callbackToTFn cb case side of HsHsSide -> return hsType HsCSide -> do addImports hsImportForRuntime return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsType - TObj cls -> case side of - HsCSide -> cppTypeToHsTypeAndUse side $ TPtr $ TConst t - HsHsSide -> - case classHaskellConversionType <$> classHaskellConversion (classConversion cls) of - Nothing -> - throwError $ concat - ["Expected a Haskell type for ", show cls, " but there isn't one"] - Just t' -> t' - TObjToHeap cls -> cppTypeToHsTypeAndUse side $ TPtr $ TObj cls - TConst t' -> cppTypeToHsTypeAndUse side t' + Internal_TObj cls -> case side of + HsCSide -> cppTypeToHsTypeAndUse side $ ptrT $ constT t + HsHsSide -> case getClassHaskellConversion cls of + Nothing -> + throwError $ concat + ["Expected a Haskell type for ", show cls, " but there isn't one"] + Just c -> classHaskellConversionType c + Internal_TObjToHeap cls -> cppTypeToHsTypeAndUse side $ ptrT $ objT cls + Internal_TToGc t' -> case t' of + Internal_TRef _ -> cppTypeToHsTypeAndUse side t' -- References behave the same as pointers. + Internal_TPtr _ -> cppTypeToHsTypeAndUse side t' + Internal_TObj cls -> cppTypeToHsTypeAndUse side $ ptrT $ objT cls + _ -> throwError $ tToGcInvalidFormErrorMessage Nothing t' + Internal_TConst t' -> cppTypeToHsTypeAndUse side t' + +-- | Returns the 'ClassHaskellConversion' of a class, if it has one. +getClassHaskellConversion :: Class -> Maybe ClassHaskellConversion +getClassHaskellConversion cls = case classHaskellConversion $ classConversion cls of + ClassConversionNone -> Nothing + ClassConversionManual c -> Just c + ClassConversionToHeap -> Nothing + ClassConversionToGc -> Nothing -- | Prints a value like 'P.prettyPrint', but removes newlines so that they -- don't cause problems with this module's textual generation. Should be mainly diff --git a/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs b/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs --- a/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs +++ b/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs @@ -40,13 +40,14 @@ import Data.Graph (SCC (AcyclicSCC, CyclicSCC), stronglyConnComp) import Data.List (intersperse) import qualified Data.Map as M -import Data.Maybe (catMaybes, isJust, mapMaybe) +import Data.Maybe (isJust, mapMaybe) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mconcat) #endif import qualified Data.Set as S import Foreign.Hoppy.Generator.Common import Foreign.Hoppy.Generator.Spec +import Foreign.Hoppy.Generator.Types import Foreign.Hoppy.Generator.Language.Cpp ( classCastFnCppName, classDeleteFnCppName, @@ -152,8 +153,7 @@ -- compatibility using overlapping instances with both GHC 7.8 and 7.10. -- -- GeneralizedNewtypeDeriving is to enable automatic deriving of - -- Data.Bits.Bits instances for bitspace newtypes and Storable instances for - -- object pointer newtypes. + -- Data.Bits.Bits instances for bitspace newtypes. concat [ "{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving" , ", MultiParamTypeClasses, TypeSynonymInstances, UndecidableInstances #-}\n" @@ -192,11 +192,11 @@ sayExportVar mode v = do withErrorContext ("generating variable " ++ show (varExtName v)) $ do let (isConst, deconstType) = case varType v of - TConst t -> (True, t) + Internal_TConst t -> (True, t) t -> (False, t) sayExportFn mode (varGetterExtName v) Nothing Nonpure [] deconstType unless isConst $ - sayExportFn mode (varSetterExtName v) Nothing Nonpure [deconstType] TVoid + sayExportFn mode (varSetterExtName v) Nothing Nonpure [deconstType] voidT sayExportEnum :: SayExportMode -> CppEnum -> Generator () sayExportEnum mode enum = @@ -229,10 +229,9 @@ ln forM_ values $ \(num, hsCtorName) -> saysLn ["toEnum (", show num, ") = ", hsCtorName] - -- TODO Fix the potential name collision of 'n'. - saysLn ["toEnum n = HoppyP.error $ ", + saysLn ["toEnum n' = HoppyP.error $ ", show (concat ["Unknown ", hsTypeName, " numeric value: "]), - " ++ HoppyP.show n"] + " ++ HoppyP.show n'"] SayExportBoot -> do let hsTypeName = toHsEnumTypeName enum @@ -262,15 +261,16 @@ let values :: [(Int, String)] values = map (second $ toHsBitspaceValueName bitspace) $ bitspaceValueNames bitspace - hsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace + hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace + hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace -- Print out the data declaration and conversion functions. - addImports $ mconcat [hsImportForBits, hsImportForPrelude] + addImports $ mconcat [hsImportForBits, hsImportForPrelude, hsImportForRuntime] addExport' hsTypeName addExport' className ln saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ", - fromFnName, " :: ", prettyPrint hsNumType, " }"] + fromFnName, " :: ", prettyPrint hsCNumType, " }"] indent $ sayLn "deriving (HoppyDB.Bits, HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)" ln saysLn ["class ", className, " a where"] @@ -278,8 +278,12 @@ let tyVar = HsTyVar $ HsIdent "a" saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType] ln - saysLn ["instance ", className, " (", prettyPrint hsNumType, ") where"] + saysLn ["instance ", className, " (", prettyPrint hsCNumType, ") where"] indent $ saysLn [toFnName, " = ", hsTypeName] + saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ") where"] + indent $ saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral"] + saysLn ["instance ", className, " ", hsTypeName, " where"] + indent $ saysLn [toFnName, " = HoppyP.id"] -- If the bitspace has an associated enum, then print out a conversion -- instance for it as well. @@ -299,14 +303,15 @@ saysLn [valueName, " = ", hsTypeName, " ", show num] SayExportBoot -> do - hsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace + hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace + hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace addImports $ mconcat [hsImportForBits, hsImportForPrelude] addExport' hsTypeName addExport' className ln saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ", - fromFnName, " :: ", prettyPrint hsNumType, " }"] + fromFnName, " :: ", prettyPrint hsCNumType, " }"] ln saysLn ["instance HoppyDB.Bits ", hsTypeName] saysLn ["instance HoppyP.Bounded ", hsTypeName] @@ -319,7 +324,9 @@ let tyVar = HsTyVar $ HsIdent "a" saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType] ln - saysLn ["instance ", className, " (", prettyPrint hsNumType, ")"] + saysLn ["instance ", className, " (", prettyPrint hsCNumType, ")"] + saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ")"] + saysLn ["instance ", className, " ", hsTypeName] forM_ (bitspaceEnum bitspace) $ \enum -> do let enumTypeName = toHsEnumTypeName enum importHsModuleForExtName $ enumExtName enum @@ -387,17 +394,17 @@ -- bindings: -- -- > foreign import ccall "wrapper" name'newFunPtr --- > :: (CInt -> TPtr TChar -> IO CInt) --- > -> IO (FunPtr (CInt -> TPtr TChar -> IO CInt)) +-- > :: (CInt -> Ptr CChar -> IO CInt) +-- > -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt)) -- > -- > -- (This is an ad-hoc generated binding for C++ callback impl class constructor.) -- > foreign import ccall "genpop__name_impl" name'newCallback --- > :: FunPtr (CInt -> TPtr TChar -> IO CInt) +-- > :: FunPtr (CInt -> Ptr CChar -> IO CInt) -- > -> FunPtr (FunPtr (IO ()) -> IO ()) -- > -> Bool --- > -> IO (CCallback (CInt -> TPtr TChar -> IO CInt)) +-- > -> IO (CCallback (CInt -> Ptr CChar -> IO CInt)) -- > --- > name :: (CInt -> String -> IO CInt) -> IO (CCallback (CInt -> TPtr TChar -> IO CInt)) +-- > name :: (CInt -> String -> IO CInt) -> IO (CCallback (CInt -> Ptr CChar -> IO CInt)) -- > name f = do -- > let cf arg1' arg2' = do -- > arg1 <- return arg1' @@ -488,35 +495,35 @@ sayArgProcessing dir t fromVar toVar = withErrorContext ("processing argument of type " ++ show t) $ case t of - TVoid -> throwError $ "TVoid is not a valid argument type" - TBool -> case dir of + Internal_TVoid -> throwError $ "TVoid is not a valid argument type" + Internal_TBool -> case dir of ToCpp -> saysLn ["let ", toVar, " = if ", fromVar, " then 1 else 0 in"] FromCpp -> do addImports $ hsImport1 "Prelude" "(/=)" saysLn ["let ", toVar, " = ", fromVar, " /= 0 in"] - TChar -> noConversion - TUChar -> noConversion - TShort -> noConversion - TUShort -> noConversion - TInt -> noConversion - TUInt -> noConversion - TLong -> noConversion - TULong -> noConversion - TLLong -> noConversion - TULLong -> noConversion - TFloat -> noConversion - TDouble -> noConversion - TInt8 -> noConversion - TInt16 -> noConversion - TInt32 -> noConversion - TInt64 -> noConversion - TWord8 -> noConversion - TWord16 -> noConversion - TWord32 -> noConversion - TWord64 -> noConversion - TPtrdiff -> noConversion - TSize -> noConversion - TSSize -> noConversion - TEnum _ -> do + Internal_TChar -> noConversion + Internal_TUChar -> noConversion + Internal_TShort -> noConversion + Internal_TUShort -> noConversion + Internal_TInt -> sayCoerceIntegral + Internal_TUInt -> noConversion + Internal_TLong -> noConversion + Internal_TULong -> noConversion + Internal_TLLong -> noConversion + Internal_TULLong -> noConversion + Internal_TFloat -> sayCoerceFloating + Internal_TDouble -> sayCoerceFloating + Internal_TInt8 -> noConversion + Internal_TInt16 -> noConversion + Internal_TInt32 -> noConversion + Internal_TInt64 -> noConversion + Internal_TWord8 -> noConversion + Internal_TWord16 -> noConversion + Internal_TWord32 -> noConversion + Internal_TWord64 -> noConversion + Internal_TPtrdiff -> noConversion + Internal_TSize -> noConversion + Internal_TSSize -> noConversion + Internal_TEnum _ -> do addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForPrelude, hsImportForRuntime] saysLn ["let ", toVar, -- TODO The coersion here is unnecssary if we replace the C numeric @@ -526,47 +533,87 @@ ToCpp -> " = HoppyFHR.coerceIntegral $ HoppyP.fromEnum " FromCpp -> " = HoppyP.toEnum $ HoppyFHR.coerceIntegral ", fromVar, " in"] - TBitspace b -> do + Internal_TBitspace b -> do importHsModuleForExtName $ bitspaceExtName b - saysLn ["let ", toVar, " = ", bitspaceConvFn dir b, " ", fromVar, " in"] + saysLn $ concat [ ["let ", toVar, " = "] + , case dir of + ToCpp -> [toHsBitspaceToNumName b, " $ ", toHsBitspaceFromValueName b] + FromCpp -> [toHsBitspaceTypeName b], + [" ", fromVar, " in"] + ] -- References and pointers are handled equivalently. - TPtr (TObj cls) -> do + Internal_TPtr (Internal_TObj cls) -> do addImportForClass cls - saysLn $ case dir of - ToCpp -> ["let ", toVar, " = ", toHsCastMethodName Nonconst cls, " ", fromVar, " in"] - FromCpp -> ["let ", toVar, " = ", fromVar, " in"] - TPtr (TConst (TObj cls)) -> case dir of - ToCpp -> do - addImports $ mconcat [hsImport1 "Prelude" "($)"] - addImportForClass cls - saysLn [toHsWithValuePtrName cls, " ", fromVar, " $ \\", toVar, " ->"] - FromCpp -> - saysLn ["let ", toVar, " = ", fromVar, " in"] - TPtr _ -> noConversion - TRef t' -> sayArgProcessing dir (TPtr t') fromVar toVar - TFn {} -> throwError "TFn unimplemented" - TCallback cb -> case dir of + case dir of + ToCpp -> do + addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForRuntime] + saysLn ["HoppyFHR.withCppPtr (", toHsCastMethodName Nonconst cls, " ", fromVar, + ") $ \\", toVar, " ->"] + FromCpp -> + saysLn ["let ", toVar, " = ", toHsDataCtorName Unmanaged Nonconst cls, + " ", fromVar, " in"] + Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> do + addImportForClass cls + case dir of + ToCpp -> do + -- Same as the (TObj _), ToCpp case. + addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForPrelude, + hsImportForRuntime] + saysLn [toHsWithValuePtrName cls, " ", fromVar, + " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"] + FromCpp -> + saysLn ["let ", toVar, " = ", toHsDataCtorName Unmanaged Const cls, + " ", fromVar, " in"] + Internal_TPtr _ -> noConversion + Internal_TRef t' -> sayArgProcessing dir (ptrT t') fromVar toVar + Internal_TFn {} -> throwError "TFn unimplemented" + Internal_TCallback cb -> case dir of ToCpp -> do addImports $ hsImport1 "Prelude" "(>>=)" importHsModuleForExtName $ callbackExtName cb saysLn [toHsCallbackCtorName cb, " ", fromVar, " >>= \\", toVar, " ->"] FromCpp -> throwError "Can't receive a callback from C++" - TObj cls -> case dir of + Internal_TObj cls -> case dir of ToCpp -> do - addImports $ mconcat [hsImport1 "Prelude" "($)"] + -- Same as the (TPtr (TConst (TObj _))), ToPtr case. addImportForClass cls - saysLn [toHsWithValuePtrName cls, " ", fromVar, " $ \\", toVar, " ->"] + addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForPrelude, + hsImportForRuntime] + saysLn [toHsWithValuePtrName cls, " ", fromVar, + " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"] + FromCpp -> case classHaskellConversion $ classConversion cls of + ClassConversionNone -> + throwError $ concat + ["Can't pass a TObj of ", show cls, + " from C++ to Haskell because no class conversion is defined"] + ClassConversionManual _ -> do + addImportForClass cls + addImports $ mconcat [hsImport1 "Prelude" "(>>=)", + hsImportForRuntime] + saysLn ["HoppyFHR.decode (", toHsDataCtorName Unmanaged Const cls, " ", + fromVar, ") >>= \\", toVar, " ->"] + ClassConversionToHeap -> sayArgProcessing dir (objToHeapT cls) fromVar toVar + ClassConversionToGc -> sayArgProcessing dir (toGcT t) fromVar toVar + Internal_TObjToHeap cls -> case dir of + ToCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls + FromCpp -> sayArgProcessing dir (ptrT $ objT cls) fromVar toVar + Internal_TToGc t' -> case dir of + ToCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t' FromCpp -> do - addImports $ mconcat [hsImport1 "Prelude" "(>>=)", hsImportForRuntime] - saysLn ["HoppyFHR.decode ", fromVar, " >>= \\", toVar, " ->"] - TObjToHeap cls -> case dir of - ToCpp -> throwError $ tObjToHeapWrongDirectionErrorMsg Nothing cls - FromCpp -> noConversion - TConst t' -> sayArgProcessing dir t' fromVar toVar + addImports $ mconcat [hsImport1 "Prelude" "(>>=)", + hsImportForRuntime] + saysLn ["HoppyFHR.toGc ", fromVar, " >>= \\", toVar, " ->"] + Internal_TConst t' -> sayArgProcessing dir t' fromVar toVar where noConversion = saysLn ["let ", toVar, " = ", fromVar, " in"] - bitspaceConvFn dir = case dir of - ToCpp -> toHsBitspaceToNumName - FromCpp -> toHsBitspaceFromValueName + sayCoerceIntegral = do + addImports hsImportForRuntime + saysLn ["let ", toVar, " = HoppyFHR.coerceIntegral ", fromVar, " in"] + sayCoerceFloating = do + addImports hsImportForPrelude + saysLn ["let ", toVar, " = HoppyP.realToFrac ", fromVar, " in"] -- | Note that the 'CallDirection' is the direction of the call, not the -- direction of the return. 'ToCpp' means we're returning to the foreign @@ -575,37 +622,37 @@ sayCallAndProcessReturn dir t callWords = withErrorContext ("processing return value of type " ++ show t) $ case t of - TVoid -> sayCall - TBool -> do + Internal_TVoid -> sayCall + Internal_TBool -> do case dir of ToCpp -> do addImports $ mconcat [hsImport1 "Prelude" "(/=)", hsImportForPrelude] sayLn "HoppyP.fmap (/= 0)" FromCpp -> sayLn "HoppyP.fmap (\\x -> if x then 1 else 0)" sayCall - TChar -> sayCall - TUChar -> sayCall - TShort -> sayCall - TUShort -> sayCall - TInt -> sayCall - TUInt -> sayCall - TLong -> sayCall - TULong -> sayCall - TLLong -> sayCall - TULLong -> sayCall - TFloat -> sayCall - TDouble -> sayCall - TInt8 -> sayCall - TInt16 -> sayCall - TInt32 -> sayCall - TInt64 -> sayCall - TWord8 -> sayCall - TWord16 -> sayCall - TWord32 -> sayCall - TWord64 -> sayCall - TPtrdiff -> sayCall - TSize -> sayCall - TSSize -> sayCall - TEnum _ -> do + Internal_TChar -> sayCall + Internal_TUChar -> sayCall + Internal_TShort -> sayCall + Internal_TUShort -> sayCall + Internal_TInt -> sayCoerceIntegral >> sayCall + Internal_TUInt -> sayCall + Internal_TLong -> sayCall + Internal_TULong -> sayCall + Internal_TLLong -> sayCall + Internal_TULLong -> sayCall + Internal_TFloat -> sayCoerceFloating >> sayCall + Internal_TDouble -> sayCoerceFloating >> sayCall + Internal_TInt8 -> sayCall + Internal_TInt16 -> sayCall + Internal_TInt32 -> sayCall + Internal_TInt64 -> sayCall + Internal_TWord8 -> sayCall + Internal_TWord16 -> sayCall + Internal_TWord32 -> sayCall + Internal_TWord64 -> sayCall + Internal_TPtrdiff -> sayCall + Internal_TSize -> sayCall + Internal_TSSize -> sayCall + Internal_TEnum _ -> do addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime] case dir of -- TODO The coersion here is unnecssary if we replace the C numeric types @@ -613,34 +660,88 @@ ToCpp -> saysLn ["HoppyP.fmap (HoppyP.toEnum . HoppyFHR.coerceIntegral)"] FromCpp -> saysLn ["HoppyP.fmap (HoppyFHR.coerceIntegral . HoppyP.fromEnum)"] sayCall - TBitspace b -> do + Internal_TBitspace b -> do addImports hsImportForPrelude importHsModuleForExtName $ bitspaceExtName b saysLn ["HoppyP.fmap ", bitspaceConvFn dir b] sayCall - TPtr _ -> sayCall - TRef _ -> sayCall - TFn {} -> throwError "TFn unimplemented" - TCallback cb -> case dir of + -- The same as TPtr (TConst (TObj _)), but nonconst. + Internal_TPtr (Internal_TObj cls) -> do + addImportForClass cls + case dir of + ToCpp -> do + addImports hsImportForPrelude + saysLn ["HoppyP.fmap ", toHsDataCtorName Unmanaged Nonconst cls] + sayCall + FromCpp -> do + addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] + sayLn "HoppyP.fmap HoppyFHR.toPtr" + sayCall + -- The same as TPtr (TConst (TObj _)), but nonconst. + Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> do + addImportForClass cls + case dir of + ToCpp -> do + addImports hsImportForPrelude + saysLn ["HoppyP.fmap ", toHsDataCtorName Unmanaged Const cls] + sayCall + FromCpp -> do + addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] + sayLn "HoppyP.fmap HoppyFHR.toPtr" + sayCall + Internal_TPtr _ -> sayCall + Internal_TRef t' -> sayCallAndProcessReturn dir (ptrT t') callWords + Internal_TFn {} -> throwError "TFn unimplemented" + Internal_TCallback cb -> case dir of ToCpp -> throwError "Can't receive a callback from C++" FromCpp -> do addImports $ hsImport1 "Prelude" "(=<<)" importHsModuleForExtName $ callbackExtName cb saysLn [toHsCallbackCtorName cb, "=<<"] sayCall - TObj _ -> do - addImports $ mconcat [hsImport1 "Prelude" "(=<<)", hsImportForRuntime] - case dir of - ToCpp -> sayLn "HoppyFHR.decodeAndDelete =<<" - FromCpp -> sayLn "HoppyFHR.encode =<<" - sayCall - TObjToHeap cls -> case dir of - ToCpp -> sayCall - FromCpp -> throwError $ tObjToHeapWrongDirectionErrorMsg Nothing cls - TConst t' -> sayCallAndProcessReturn dir t' callWords + Internal_TObj cls -> case dir of + ToCpp -> case classHaskellConversion $ classConversion cls of + ClassConversionNone -> + throwError $ concat + ["Can't return a TObj of ", show cls, + " from C++ to Haskell because no class conversion is defined"] + ClassConversionManual _ -> do + addImportForClass cls + addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"], + hsImportForRuntime] + saysLn ["(HoppyFHR.decodeAndDelete . ", toHsDataCtorName Unmanaged Const cls, ") =<<"] + sayCall + ClassConversionToHeap -> sayCallAndProcessReturn dir (objToHeapT cls) callWords + ClassConversionToGc -> sayCallAndProcessReturn dir (toGcT t) callWords + FromCpp -> do + addImportForClass cls + addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"], + hsImportForPrelude, + hsImportForRuntime] + sayLn "(HoppyP.fmap (HoppyFHR.toPtr) . HoppyFHR.encode) =<<" + sayCall + Internal_TObjToHeap cls -> case dir of + ToCpp -> sayCallAndProcessReturn dir (ptrT $ objT cls) callWords + FromCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls + Internal_TToGc t' -> case dir of + ToCpp -> do + addImports $ mconcat [hsImport1 "Prelude" "(=<<)", + hsImportForRuntime] + sayLn "HoppyFHR.toGc =<<" + -- TToGc (TObj _) should create a pointer rather than decoding, so we + -- change the TObj _ into a TPtr (TObj _). + case t' of + Internal_TObj _ -> sayCallAndProcessReturn dir (ptrT t') callWords + _ -> sayCallAndProcessReturn dir t' callWords + FromCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t' + Internal_TConst t' -> sayCallAndProcessReturn dir t' callWords where sayCall = saysLn $ "(" : callWords ++ [")"] + sayCoerceIntegral = do addImports $ mconcat [hsImportForPrelude, hsImportForRuntime] + sayLn "HoppyP.fmap HoppyFHR.coerceIntegral" + sayCoerceFloating = do addImports hsImportForPrelude + sayLn "HoppyP.fmap HoppyP.realToFrac" bitspaceConvFn dir = case dir of - ToCpp -> toHsBitspaceFromValueName + ToCpp -> toHsBitspaceTypeName FromCpp -> toHsBitspaceToNumName sayExportClass :: SayExportMode -> Class -> Generator () @@ -721,7 +822,7 @@ indent $ saysLn [hsWithValuePtrName, " = HoppyP.flip ($) . ", hsCastMethodName] -- When the class has a native Haskell type, also print an instance for it. - forM_ (classHaskellConversion $ classConversion cls) $ \conv -> do + forM_ (getClassHaskellConversion cls) $ \conv -> do hsType <- classHaskellConversionType conv ln saysLn ["#if MIN_VERSION_base(4,8,0)"] @@ -767,10 +868,19 @@ -- it in foreign calls in other modules. addExport' hsTypeName ln - saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " (HoppyF.Ptr ", hsTypeName, ")"] - if doDecls - then indent $ sayLn "deriving (HoppyP.Eq, HoppyP.Ord, HoppyP.Show, HoppyF.Storable)" - else saysLn ["instance HoppyF.Storable ", hsTypeName] + saysLn ["data ", hsTypeName, " ="] + indent $ do + saysLn [" ", hsCtor, " (HoppyF.Ptr ", hsTypeName, ")"] + saysLn ["| ", hsCtorGc, " (HoppyF.ForeignPtr ()) (HoppyF.Ptr ", hsTypeName, ")"] + when doDecls $ do + addImports $ hsImport1 "Prelude" "(==)" + indent $ sayLn "deriving (HoppyP.Show)" + ln + saysLn ["instance HoppyP.Eq ", hsTypeName, " where"] + indent $ saysLn ["x == y = HoppyFHR.toPtr x == HoppyFHR.toPtr y"] + ln + saysLn ["instance HoppyP.Ord ", hsTypeName, " where"] + indent $ saysLn ["compare x y = HoppyP.compare (HoppyFHR.toPtr x) (HoppyFHR.toPtr y)"] -- Generate const_cast functions: -- castFooToConst :: Foo -> FooConst @@ -780,25 +890,58 @@ addExport constCastFnName saysLn [constCastFnName, " :: ", toHsDataTypeName (constNegate cst) cls, " -> ", hsTypeName] when doDecls $ do - addImports $ hsImport1 "Prelude" "(.)" - saysLn [constCastFnName, " = ", hsTypeName, " . HoppyF.castPtr . HoppyFHR.toPtr"] + addImports $ hsImport1 "Prelude" "($)" + saysLn [constCastFnName, " (", toHsDataCtorName Unmanaged (constNegate cst) cls, + " ptr') = ", hsCtor, " $ HoppyF.castPtr ptr'"] + saysLn [constCastFnName, " (", toHsDataCtorName Managed (constNegate cst) cls, + " fptr' ptr') = ", hsCtorGc, " fptr' $ HoppyF.castPtr ptr'"] -- Generate an instance of CppPtr. ln if doDecls - then do addImports hsImportForForeign + then do addImports $ hsImport1 "Prelude" "($)" saysLn ["instance HoppyFHR.CppPtr ", hsTypeName, " where"] indent $ do - saysLn ["nullptr = ", toHsDataTypeName cst cls, " HoppyF.nullPtr"] - saysLn ["toPtr (", hsTypeName, " ptr) = ptr"] + saysLn ["nullptr = ", toHsDataCtorName Unmanaged cst cls, " HoppyF.nullPtr"] + ln + saysLn ["withCppPtr (", hsCtor, " ptr') f' = f' ptr'"] + saysLn ["withCppPtr (", hsCtorGc, + " fptr' ptr') f' = HoppyF.withForeignPtr fptr' $ \\_ -> f' ptr'"] + ln + saysLn ["toPtr (", hsCtor, " ptr') = ptr'"] + saysLn ["toPtr (", hsCtorGc, " _ ptr') = ptr'"] + ln + saysLn ["touchCppPtr (", hsCtor, " _) = HoppyP.return ()"] + saysLn ["touchCppPtr (", hsCtorGc, " fptr' _) = HoppyF.touchForeignPtr fptr'"] when (classDtorIsPublic cls) $ do + addImports $ hsImport1 "Prelude" "(==)" ln - deleteTail <- case cst of - Const -> return [] - Nonconst -> do addImports $ hsImport1 "Prelude" "(.)" - return [" . ", toHsCastMethodName Const cls] saysLn ["instance HoppyFHR.Deletable ", hsTypeName, " where"] - indent $ saysLn $ "delete = " : toHsClassDeleteFnName cls : deleteTail + indent $ do + saysLn $ + "delete (" : toHsDataCtorName Unmanaged cst cls : " ptr') = " : + toHsClassDeleteFnName cls : + case cst of + Const -> [" ptr'"] + Nonconst -> [" $ (HoppyF.castPtr ptr' :: HoppyF.Ptr ", + toHsDataTypeName Const cls, ")"] + saysLn ["delete (", toHsDataCtorName Managed cst cls, + " _ _) = HoppyP.fail $ HoppyP.concat ", + "[\"Deletable.delete: Asked to delete a GC-managed \", ", + show hsTypeName, ", \" object.\"]"] + ln + saysLn ["toGc this'@(", hsCtor, " ptr') = ", + -- No sense in creating a ForeignPtr for a null pointer. + "if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ", + "(HoppyP.flip ", hsCtorGc, " ptr') $ ", + "HoppyF.newForeignPtr ", + -- The foreign delete function takes a const pointer; we cast it to + -- take a Ptr () to match up with the ForeignPtr () we're creating, + -- assuming that data pointers have the same representation. + "(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName cls, + " :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ", + "(HoppyF.castPtr ptr' :: HoppyF.Ptr ())"] + saysLn ["toGc this'@(", hsCtorGc, " {}) = HoppyP.return this'"] else do saysLn ["instance HoppyFHR.CppPtr ", hsTypeName] saysLn ["instance HoppyFHR.Deletable ", hsTypeName] @@ -808,57 +951,97 @@ where hsTypeName :: String hsTypeName = toHsDataTypeName cst cls + hsCtor :: String + hsCtor = toHsDataCtorName Unmanaged cst cls + + hsCtorGc :: String + hsCtorGc = toHsDataCtorName Managed cst cls + genInstances :: [Class] -> Class -> Generator () genInstances path ancestorCls = do - let path' = ancestorCls : path + -- In this example Bar inherits from Foo. We are generating instances + -- either for BarConst or Bar, depending on 'cst'. + -- + -- BarConst's instances: + -- instance FooConstPtr BarConst where + -- toFooConst (BarConst ptr') = FooConst $ castBarToFoo ptr' + -- toFooConst (BarConstGc fptr' ptr') = FooConstGc fptr' $ castBarToFoo ptr' + -- + -- instance BarConstPtr BarConst where + -- toFooConst = id + -- + -- Bar's instances: + -- instance FooConstPtr Bar + -- toFooConst (Bar ptr') = + -- FooConst $ castBarToFoo $ castBarToConst ptr' + -- toFooConst (BarGc fptr' ptr') = + -- FooConstGc fptr' $ castBarToFoo $ castBarToConst ptr' + -- + -- instance FooPtr Bar + -- toFoo (Bar ptr') = + -- Foo $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr' + -- toFoo (BarGc fptr' ptr') = + -- FooGc fptr' $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr' + -- + -- instance BarConstPtr Bar + -- toBarConst (Bar ptr') = Bar $ castBarToConst ptr' + -- toBarConst (BarGc fptr' ptr') = BarGc fptr' $ castBarToConst ptr' + -- + -- instance BarPtr Bar + -- toBar = id + -- + -- In all cases, we unwrap the pointer, maybe add const, maybe do an + -- upcast, maybe remove const, then rewrap the pointer. The identity + -- cases are where we just unwrap and wrap again. - -- Unconditionally generate an instance of the const typeclass. - when (null path) $ addImports $ hsImportForPrelude addImportForClass ancestorCls - -- Use the fact that we've imported all of the classes from cls to - -- ancestorCls. - saysLn ["instance ", toHsPtrClassName Const ancestorCls, " ", hsTypeName, - if doDecls then " where" else ""] - when doDecls $ indent $ do - let convertToConst = cst == Nonconst - castToSelf = null path - fns <- (\x -> if null x - then do addImports $ hsImportForPrelude - return ["HoppyP.id"] - else return x) $ - catMaybes - [ if castToSelf then Nothing else Just $ toHsCastPrimitiveName cls ancestorCls - , if convertToConst then Just $ toHsConstCastFnName Const cls else Nothing - ] - case fns of - _:_:_ -> addImports $ hsImport1 "Prelude" "(.)" - _ -> return () - saysLn $ toHsCastMethodName Const ancestorCls : " = " : - intersperse " . " fns - - -- Generate an instance of the nonconst typeclass if we're working on - -- a nonconst pointer type. - when (cst == Nonconst) $ do - saysLn ["instance ", toHsPtrClassName Nonconst ancestorCls, " ", hsTypeName, + forM_ (case cst of + Const -> [Const] + Nonconst -> [Const, Nonconst]) $ \typeclassCst -> do + saysLn ["instance ", toHsPtrClassName typeclassCst ancestorCls, " ", hsTypeName, if doDecls then " where" else ""] - let name = toHsCastMethodName Nonconst ancestorCls - when doDecls $ indent $ - if null path - then do addImports hsImportForPrelude - saysLn [name, " = HoppyP.id"] - else do addImports $ hsImport1 "Prelude" "(.)" - saysLn [name, " = ", - toHsConstCastFnName Nonconst ancestorCls, " . ", - toHsCastPrimitiveName cls ancestorCls, " . ", - toHsConstCastFnName Const cls] + when doDecls $ indent $ do + let castMethodName = toHsCastMethodName typeclassCst ancestorCls + if null path && cst == typeclassCst + then do addImports hsImportForPrelude + saysLn [castMethodName, " = HoppyP.id"] + else do let addConst = cst == Nonconst + removeConst = typeclassCst == Nonconst + when (addConst || removeConst) $ + addImports hsImportForForeign + forM_ ([minBound..] :: [Managed]) $ \managed -> do + let ancestorCtor = case managed of + Unmanaged -> [toHsDataCtorName Unmanaged typeclassCst ancestorCls] + Managed -> [toHsDataCtorName Managed typeclassCst ancestorCls, + " fptr'"] + ptrPattern = case managed of + Unmanaged -> [toHsDataCtorName Unmanaged cst cls, " ptr'"] + Managed -> [toHsDataCtorName Managed cst cls, " fptr' ptr'"] + saysLn $ concat + [ [castMethodName, " ("], ptrPattern, [") = "], ancestorCtor + , if removeConst + then [" $ (HoppyF.castPtr :: HoppyF.Ptr ", + toHsDataTypeName Const ancestorCls, " -> HoppyF.Ptr ", + toHsDataTypeName Nonconst ancestorCls, ")"] + else [] + , if not $ null path + then [" $ ", toHsCastPrimitiveName cls ancestorCls] + else [] + , if addConst + then [" $ (HoppyF.castPtr :: HoppyF.Ptr ", + toHsDataTypeName Nonconst cls, " -> HoppyF.Ptr ", + toHsDataTypeName Const cls, ")"] + else [] + , [" ptr'"] + ] - forM_ (classSuperclasses ancestorCls) $ genInstances path' + forM_ (classSuperclasses ancestorCls) $ genInstances $ ancestorCls : path sayExportClassHsCtors :: SayExportMode -> Class -> Generator () sayExportClassHsCtors mode cls = forM_ (classCtors cls) $ \ctor -> (sayExportFn mode <$> getClassyExtName cls <*> pure Nothing <*> - pure Nonpure <*> ctorParams <*> pure (TPtr $ TObj cls)) ctor + pure Nonpure <*> ctorParams <*> pure (ptrT $ objT cls)) ctor sayExportClassHsSpecialFns :: SayExportMode -> Class -> Generator () sayExportClassHsSpecialFns mode cls = do @@ -868,20 +1051,35 @@ -- Say the delete function. case mode of SayExportForeignImports -> when (classDtorIsPublic cls) $ do - addImports hsImportForPrelude + addImports $ mconcat [hsImportForForeign, hsImportForPrelude] saysLn ["foreign import ccall \"", classDeleteFnCppName cls, "\" ", - toHsClassDeleteFnName cls, " :: ", toHsDataTypeName Const cls, - " -> HoppyP.IO ()"] + toHsClassDeleteFnName cls, " :: HoppyF.Ptr ", + toHsDataTypeName Const cls, " -> HoppyP.IO ()"] + saysLn ["foreign import ccall \"&", classDeleteFnCppName cls, "\" ", + toHsClassDeleteFnPtrName cls, " :: HoppyF.FunPtr (HoppyF.Ptr ", + toHsDataTypeName Const cls, " -> HoppyP.IO ())"] -- The user interface to this is the generic 'delete' function, rendered -- elsewhere. SayExportDecls -> return () SayExportBoot -> return () + case mode of + SayExportForeignImports -> return () + SayExportDecls -> do + addImports $ mconcat [hsImport1 "Prelude" "($)", + hsImportForForeign, + hsImportForRuntime] + ln + saysLn ["instance HoppyFHR.Assignable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ", + typeName, " where"] + indent $ sayLn "assign ptr' value' = HoppyF.poke ptr' $ HoppyFHR.toPtr value'" + SayExportBoot -> return () + -- If the class has an assignment operator that takes its own type, then -- generate an instance of Assignable. let assignmentMethods = flip filter (classMethods cls) $ \m -> methodApplicability m == MNormal && - (methodParams m == [TObj cls] || methodParams m == [TRef $ TConst $ TObj cls]) && + (methodParams m == [objT cls] || methodParams m == [refT $ constT $ objT cls]) && (case methodImpl m of RealMethod name -> name == FnOp OpAssign FnMethod name -> name == FnOp OpAssign) @@ -909,20 +1107,26 @@ SayExportForeignImports -> return () SayExportDecls -> do - addImports $ mconcat [hsImportForForeign, hsImportForRuntime] + addImports $ mconcat [hsImport1 "Prelude" "(.)", + hsImportForForeign, + hsImportForPrelude, + hsImportForRuntime] ln - saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr ", typeName, ") ", typeName, " where"] - indent $ sayLn "decode = HoppyF.peek" + saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", + typeName, ")) ", typeName, " where"] + indent $ + saysLn ["decode = HoppyP.fmap ", + toHsDataCtorName Unmanaged Nonconst cls, " . HoppyF.peek"] SayExportBoot -> do addImports $ mconcat [hsImportForForeign, hsImportForRuntime] ln -- TODO Encodable. - saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr ", typeName, ") ", typeName] + saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ", typeName] -- Say Encodable and Decodable instances, if the class is encodable and -- decodable. - forM_ (classHaskellConversion $ classConversion cls) $ \conv -> do + forM_ (getClassHaskellConversion cls) $ \conv -> do hsType <- classHaskellConversionType conv let hsTypeStr = concat ["(", prettyPrint hsType, ")"] case mode of @@ -971,14 +1175,15 @@ let hsCastFnName = toHsCastPrimitiveName cls super hsDownCastFnName = toHsCastPrimitiveName super cls superType = toHsDataTypeName Const super + addImports hsImportForForeign addExport hsCastFnName saysLn [ "foreign import ccall \"", classCastFnCppName cls super - , "\" ", hsCastFnName, " :: ", clsType, " -> ", superType + , "\" ", hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType ] unless (classIsSubclassOfMonomorphic cls || classIsMonomorphicSuperclass super) $ do addExport hsDownCastFnName saysLn [ "foreign import ccall \"", classCastFnCppName super cls - , "\" ", hsDownCastFnName, " :: ", superType, " -> ", clsType + , "\" ", hsDownCastFnName, " :: HoppyF.Ptr ", superType, " -> HoppyF.Ptr ", clsType ] return True @@ -1002,29 +1207,47 @@ False -> do let superTypeName = toHsDataTypeName cst super primitiveCastFn = toHsCastPrimitiveName super cls + addImportForClass super saysLn ["instance ", downCastClassName, " ", superTypeName, " where"] + -- If Foo is a superclass of Bar: -- -- instance BarSuper Foo where - -- downToBar = castFooToNonconst . castFooToBar . castFooToConst + -- downToBar castFooToNonconst . downcast' . castFooToConst + -- where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr' + -- downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr' -- -- instance BarSuperConst FooConst where - -- downToBarConst = constFooToBar - indent $ saysLn $ - downCastMethodName : " = " : - case cst of - Const -> [primitiveCastFn] - Nonconst -> [toHsConstCastFnName Nonconst cls, " . ", - primitiveCastFn, " . ", - toHsConstCastFnName Const super] + -- downToBarConst = downcast' + -- where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr' + -- downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr' + + indent $ do + saysLn $ + downCastMethodName : " = " : + case cst of + Const -> ["cast'"] + Nonconst -> [toHsConstCastFnName Nonconst cls, + " . cast' . ", + toHsConstCastFnName Const super] + indent $ do + sayLn "where" + indent $ do + saysLn ["cast' (", toHsDataCtorName Unmanaged Const super, " ptr') = ", + toHsDataCtorName Unmanaged Const cls, " $ ", + primitiveCastFn, " ptr'"] + saysLn ["cast' (", toHsDataCtorName Managed Const super, " fptr' ptr') = ", + toHsDataCtorName Managed Const cls, " fptr' $ ", + primitiveCastFn, " ptr'"] return True SayExportBoot -> do forAncestors cls $ \super -> do let hsCastFnName = toHsCastPrimitiveName cls super superType = toHsDataTypeName Const super + addImports $ hsImportForForeign addExport hsCastFnName - saysLn [hsCastFnName, " :: ", clsType, " -> ", superType] + saysLn [hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType] return True where forAncestors :: Class -> (Class -> Generator Bool) -> Generator () @@ -1032,6 +1255,9 @@ recur <- f super when recur $ forAncestors super f +-- | Implements special logic on top of 'cppTypeToHsTypeAndUse', that computes +-- the Haskell __qualified__ type for a function, including typeclass +-- constraints. fnToHsTypeAndUse :: HsTypeSide -> Maybe (Constness, Class) -> Purity @@ -1042,28 +1268,44 @@ params <- mapM contextForParam $ (case methodInfo of Just (cst, cls) -> [("this", case cst of - Nonconst -> TPtr $ TObj cls - Const -> TPtr $ TConst $ TObj cls)] + Nonconst -> ptrT $ objT cls + Const -> ptrT $ constT $ objT cls)] Nothing -> []) ++ zip (map toArgName [1..]) paramTypes let context = mapMaybe fst params :: HsContext hsParams = map snd params - hsReturn <- cppTypeToHsTypeAndUse side returnType + + -- Determine the 'HsHsSide' return type for the function. If the function is + -- returning a 'TObj' of a class that uses 'ClassConversionToHeap' or + -- 'ClassConversionToGc', then first we wrap the return type. Then we do the + -- conversion to a Haskell type, and wrap the result in 'IO' if the function + -- is impure. (HsCSide types always get wrapped in IO.) + returnForGc <- case returnType of + Internal_TObj cls -> case classHaskellConversion $ classConversion cls of + ClassConversionNone -> + throwError $ concat ["Expected ", show cls, " to be returnable from a C++ function"] + ClassConversionManual _ -> return returnType + ClassConversionToHeap -> return $ objToHeapT cls + ClassConversionToGc -> return $ toGcT returnType + _ -> return returnType + hsReturnForGc <- cppTypeToHsTypeAndUse side returnForGc hsReturnForPurity <- case (purity, side) of - (Pure, HsHsSide) -> return hsReturn + (Pure, HsHsSide) -> return hsReturnForGc _ -> do addImports hsImportForPrelude - return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsReturn + return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsReturnForGc + return $ HsQualType context $ foldr HsTyFun hsReturnForPurity hsParams where contextForParam :: (String, Type) -> Generator (Maybe HsAsst, HsType) contextForParam (s, t) = case t of - TPtr (TObj cls) -> receivePtr s cls Nonconst - TPtr (TConst (TObj cls)) -> receiveValue s t cls - TRef (TObj cls) -> receivePtr s cls Nonconst - TRef (TConst (TObj cls)) -> receiveValue s t cls - TObj cls -> receiveValue s t cls - TConst t' -> contextForParam (s, t') + Internal_TBitspace b -> receiveBitspace s t b + Internal_TPtr (Internal_TObj cls) -> receivePtr s cls Nonconst + Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls + Internal_TRef (Internal_TObj cls) -> receivePtr s cls Nonconst + Internal_TRef (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls + Internal_TObj cls -> receiveValue s t cls + Internal_TConst t' -> contextForParam (s, t') _ -> handoff side t -- Use whatever type 'cppTypeToHsTypeAndUse' suggests, with no typeclass @@ -1071,17 +1313,30 @@ handoff :: HsTypeSide -> Type -> Generator (Maybe HsAsst, HsType) handoff side t = (,) Nothing <$> cppTypeToHsTypeAndUse side t - -- Receive a @FooPtr this => this@. + -- Receives a @IsFooBitspace a => a@. + receiveBitspace s t b = case side of + HsCSide -> handoff side t + HsHsSide -> do + importHsModuleForExtName $ bitspaceExtName b + let t' = HsTyVar $ HsIdent s + return (Just (UnQual $ HsIdent $ toHsBitspaceClassName b, [t']), + t') + + -- Receives a @FooPtr this => this@. receivePtr :: String -> Class -> Constness -> Generator (Maybe HsAsst, HsType) receivePtr s cls cst = do addImportForClass cls - return $ case side of - HsHsSide -> let t' = HsTyVar $ HsIdent s - in (Just (UnQual $ HsIdent $ toHsPtrClassName cst cls, [t']), - t') - HsCSide -> (Nothing, HsTyVar $ HsIdent $ toHsDataTypeName cst cls) + case side of + HsHsSide -> do + let t' = HsTyVar $ HsIdent s + return (Just (UnQual $ HsIdent $ toHsPtrClassName cst cls, [t']), + t') + HsCSide -> do + addImports $ hsImportForForeign + return (Nothing, HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") $ + HsTyVar $ HsIdent $ toHsDataTypeName cst cls) - -- Receive a @FooValue a => a@. + -- Receives a @FooValue a => a@. receiveValue :: String -> Type -> Class -> Generator (Maybe HsAsst, HsType) receiveValue s t cls = case side of HsCSide -> handoff side t @@ -1096,8 +1351,8 @@ getMethodEffectiveParams cls method = (case methodImpl method of RealMethod {} -> case methodApplicability method of - MNormal -> (TPtr (TObj cls):) - MConst -> (TPtr (TConst $ TObj cls):) + MNormal -> (ptrT (objT cls):) + MConst -> (ptrT (constT $ objT cls):) MStatic -> id FnMethod {} -> id) $ methodParams method diff --git a/src/Foreign/Hoppy/Generator/Spec.hs b/src/Foreign/Hoppy/Generator/Spec.hs --- a/src/Foreign/Hoppy/Generator/Spec.hs +++ b/src/Foreign/Hoppy/Generator/Spec.hs @@ -118,12 +118,16 @@ methodReturn, methodConst, methodStatic, -- *** Conversion to and from foreign values ClassConversion (..), + ClassConversionMode (..), classConversionNone, classModifyConversion, + classSetConversion, + classSetConversionToHeap, + classSetConversionToGc, + classSetHaskellConversion, ClassHaskellConversion (..), -- ** Callbacks Callback, makeCallback, callbackExtName, callbackParams, callbackReturn, callbackReqs, - callbackToTFn, -- * Addenda Addendum (..), HasAddendum, @@ -134,6 +138,7 @@ hsImportSetMakeSource, -- * Internal to Hoppy stringOrIdentifier, + callbackToTFn, -- ** Haskell imports makeHsImportSet, getHsImportSet, @@ -147,7 +152,9 @@ hsImportForSystemPosixTypes, hsImportForUnsafeIO, -- ** Error messages - tObjToHeapWrongDirectionErrorMsg, + objToHeapTWrongDirectionErrorMsg, + tToGcInvalidFormErrorMessage, + toGcTWrongDirectionErrorMsg, ) where #if !MIN_VERSION_base(4,8,0) @@ -759,97 +766,93 @@ Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing, IdPart d Nothing, IdPart e Nothing, IdPart f $ Just ts] --- | Concrete C++ types. It is possible to represent invalid C++ types with --- this, but we try to catch these and fail cleanly as much as possible. +-- | A concrete C++ type. Use the bindings in "Foreign.Hoppy.Generator.Types" +-- for values of this type; these data constructors are subject to change +-- without notice. data Type = - TVoid -- ^ C++ @void@, Haskell @()@. - | TBool -- ^ C++ @bool@, Haskell 'Bool'. - | TChar -- ^ C++ @char@, Haskell 'Foreign.C.CChar'. - | TUChar -- ^ C++ @unsigned char@, Haskell 'Foreign.C.CUChar'. - | TShort -- ^ C++ @short int@, Haskell 'Foreign.C.CShort'. - | TUShort -- ^ C++ @unsigned short int@, Haskell 'Foreign.C.CUShort'. - | TInt -- ^ C++ @int@, Haskell 'Foreign.C.CInt'. - | TUInt -- ^ C++ @unsigned int@, Haskell 'Foreign.C.CUInt'. - | TLong -- ^ C++ @long int@, Haskell 'Foreign.C.CLong'. - | TULong -- ^ C++ @unsigned long int@, Haskell 'Foreign.C.CULong'. - | TLLong -- ^ C++ @long long int@, Haskell 'Foreign.C.CLLong'. - | TULLong -- ^ C++ @unsigned long long int@, Haskell 'Foreign.C.CULLong'. - | TFloat -- ^ C++ @float@, Haskell 'Foreign.C.CFloat'. - | TDouble -- ^ C++ @double@, Haskell 'Foreign.C.CDouble'. - | TInt8 -- ^ C++ @int8_t@, Haskell 'Data.Int.Int8'. - | TInt16 -- ^ C++ @int16_t@, Haskell 'Data.Int.Int16'. - | TInt32 -- ^ C++ @int32_t@, Haskell 'Data.Int.Int32'. - | TInt64 -- ^ C++ @int64_t@, Haskell 'Data.Int.Int64'. - | TWord8 -- ^ C++ @uint8_t@, Haskell 'Data.Word.Word8'. - | TWord16 -- ^ C++ @uint16_t@, Haskell 'Data.Word.Word16'. - | TWord32 -- ^ C++ @uint32_t@, Haskell 'Data.Word.Word32'. - | TWord64 -- ^ C++ @uint64_t@, Haskell 'Data.Word.Word64'. - | TPtrdiff -- ^ C++ @ptrdiff_t@, Haskell 'Foreign.C.CPtrdiff'. - | TSize -- ^ C++ @size_t@, Haskell 'Foreign.C.CSize'. - | TSSize -- ^ C++ @ssize_t@, Haskell 'System.Posix.Types.CSsize'. - | TEnum CppEnum -- ^ A C++ @enum@ value. - | TBitspace Bitspace -- ^ A C++ bitspace value. - | TPtr Type -- ^ A poiner to another type. - | TRef Type -- ^ A reference to another type. - | TFn [Type] Type - -- ^ A function taking parameters and returning a value (or 'TVoid'). - -- Function pointers must wrap a 'TFn' in a 'TPtr'. - | TCallback Callback -- ^ A handle for calling foreign code from C++. - | TObj Class -- ^ An instance of a class. - | TObjToHeap Class - -- ^ A special case of 'TObj' that is only allowed when passing values from - -- C++ to a foreign language. Rather than looking at the object's - -- 'ClassConversion', the object will be copied to the heap, and a pointer - -- to the new object will be passed. The object must be copy-constructable. - -- - -- __The foreign language owns the pointer, even for callback arguments.__ - | TConst Type -- ^ A @const@ version of another type. + Internal_TVoid + | Internal_TBool + | Internal_TChar + | Internal_TUChar + | Internal_TShort + | Internal_TUShort + | Internal_TInt + | Internal_TUInt + | Internal_TLong + | Internal_TULong + | Internal_TLLong + | Internal_TULLong + | Internal_TFloat + | Internal_TDouble + | Internal_TInt8 + | Internal_TInt16 + | Internal_TInt32 + | Internal_TInt64 + | Internal_TWord8 + | Internal_TWord16 + | Internal_TWord32 + | Internal_TWord64 + | Internal_TPtrdiff + | Internal_TSize + | Internal_TSSize + | Internal_TEnum CppEnum + | Internal_TBitspace Bitspace + | Internal_TPtr Type + | Internal_TRef Type + | Internal_TFn [Type] Type + | Internal_TCallback Callback + | Internal_TObj Class + | Internal_TObjToHeap Class + | Internal_TToGc Type + | Internal_TConst Type deriving (Eq, Show) -- | Canonicalizes a 'Type' without changing its meaning. Multiple nested --- 'TConst's are collapsed into a single one. +-- 'Internal_TConst's are collapsed into a single one. normalizeType :: Type -> Type normalizeType t = case t of - TVoid -> t - TBool -> t - TChar -> t - TUChar -> t - TShort -> t - TUShort -> t - TInt -> t - TUInt -> t - TLong -> t - TULong -> t - TLLong -> t - TULLong -> t - TFloat -> t - TDouble -> t - TInt8 -> t - TInt16 -> t - TInt32 -> t - TInt64 -> t - TWord8 -> t - TWord16 -> t - TWord32 -> t - TWord64 -> t - TPtrdiff -> t - TSize -> t - TSSize -> t - TEnum _ -> t - TBitspace _ -> t - TPtr t' -> TPtr $ normalizeType t' - TRef t' -> TRef $ normalizeType t' - TFn paramTypes retType -> TFn (map normalizeType paramTypes) $ normalizeType retType - TCallback _ -> t - TObj _ -> t - TObjToHeap _ -> t - TConst (TConst t') -> normalizeType $ TConst t' - TConst _ -> t + Internal_TVoid -> t + Internal_TBool -> t + Internal_TChar -> t + Internal_TUChar -> t + Internal_TShort -> t + Internal_TUShort -> t + Internal_TInt -> t + Internal_TUInt -> t + Internal_TLong -> t + Internal_TULong -> t + Internal_TLLong -> t + Internal_TULLong -> t + Internal_TFloat -> t + Internal_TDouble -> t + Internal_TInt8 -> t + Internal_TInt16 -> t + Internal_TInt32 -> t + Internal_TInt64 -> t + Internal_TWord8 -> t + Internal_TWord16 -> t + Internal_TWord32 -> t + Internal_TWord64 -> t + Internal_TPtrdiff -> t + Internal_TSize -> t + Internal_TSSize -> t + Internal_TEnum _ -> t + Internal_TBitspace _ -> t + Internal_TPtr t' -> Internal_TPtr $ normalizeType t' + Internal_TRef t' -> Internal_TRef $ normalizeType t' + Internal_TFn paramTypes retType -> + Internal_TFn (map normalizeType paramTypes) $ normalizeType retType + Internal_TCallback _ -> t + Internal_TObj _ -> t + Internal_TObjToHeap _ -> t + Internal_TToGc _ -> t + Internal_TConst (Internal_TConst t') -> normalizeType $ Internal_TConst t' + Internal_TConst _ -> t --- | Strips leading 'TConst's off of a type. +-- | Strips leading 'Internal_TConst's off of a type. stripConst :: Type -> Type stripConst t = case t of - TConst t' -> stripConst t' + Internal_TConst t' -> stripConst t' _ -> t -- | A C++ variable. @@ -859,8 +862,9 @@ , varExtName :: ExtName -- ^ The variable's external name. , varType :: Type - -- ^ The type of the variable. This may be 'TConst' to indicate that the - -- variable is read-only. + -- ^ The type of the variable. This may be + -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is + -- read-only. , varReqs :: Reqs -- ^ Requirements for bindings to use this variable. , varAddendum :: Addendum @@ -887,10 +891,10 @@ Variable identifier (extNameOrIdentifier identifier maybeExtName) t mempty mempty -- | Returns whether the variable is constant, i.e. whether its type is --- @'TConst' ...@. +-- @'Foreign.Hoppy.Generator.Types.constT' ...@. varIsConst :: Variable -> Bool varIsConst v = case varType v of - TConst _ -> True + Internal_TConst _ -> True _ -> False -- | Returns the external name of the getter function for the variable. @@ -962,7 +966,7 @@ -- ^ The bitspace's external name. , bitspaceType :: Type -- ^ The C++ type used for bits values. This should be a primitive numeric - -- type. + -- type, usually 'Foreign.Hoppy.Generator.Types.intT'. , bitspaceValueNames :: [(Int, [String])] -- ^ The numeric values and names of the bitspace values. See -- 'enumValueNames'. @@ -1201,11 +1205,12 @@ if null methods then cls else cls { classMethods = classMethods cls ++ methods } -- | When a class object is returned from a function or taken as a parameter by --- value (i.e. with 'TObj'), it will be converted to or from a foreign (non-C++) --- object. Conversion may also be performed explicitly. This data type --- describes how to perform those conversions. A class may or may not support --- conversion, for any particular foreign language; what is said below only --- applies to classes that are convertible for a language. +-- value (i.e. with 'Foreign.Hoppy.Generator.Types.objT'), it will be converted +-- to or from a foreign (non-C++) object. Conversion may also be performed +-- explicitly. This data type describes how to perform those conversions. A +-- class may or may not support conversion, for any particular foreign language; +-- what is said below only applies to classes that are convertible for a +-- language. -- -- When converting between a C++ value and a foreign value, a pointer to the -- object is passed between C++ and the foreign language. Then, for each @@ -1222,18 +1227,74 @@ -- objects, and C++ object pointers can be explicitly converted to foreign -- values, via special functions generated for the class. data ClassConversion = ClassConversion - { classHaskellConversion :: Maybe ClassHaskellConversion + { classHaskellConversion :: ClassConversionMode ClassHaskellConversion -- ^ Conversions to and from Haskell. + + -- NOTE! When adding new languages here, add the language to + -- 'classSetConversionToHeap', and 'classSetConversionToGc' as well if the + -- language supports garbage collection. } +-- | Specifies whether (and if so, how) objects of a class get converted to and +-- from values in a specific foreign language. +data ClassConversionMode a = + ClassConversionNone + -- ^ Indicates that a class __is not__ convertible for a language. Passing + -- raw 'Foreign.Hoppy.Generator.Types.objT' values into and out of C++ is + -- not allowed. + | ClassConversionManual a + -- ^ Indicates that a class __is__ convertible for a language. Passing raw + -- 'Foreign.Hoppy.Generator.Types.objT' values into and out of C++ is + -- allowed, and the attached structure describes how to perform the + -- conversions. + | ClassConversionToHeap + -- ^ Indicates that a class __is not__ convertible for a language. + -- Nevertheless, passing an object from C++ to the foreign language via a + -- type of @'Foreign.Hoppy.Generator.Types.objT' cls@ is allowed, and + -- behaves as though the type were + -- @'Foreign.Hoppy.Generator.Types.objToHeapT' cls@ instead. + | ClassConversionToGc + -- ^ Indicates that a class __is not__ convertible for a language. + -- Nevertheless, passing an object from C++ to the foreign language via a + -- type of @'Foreign.Hoppy.Generator.Types.objT' cls@ is allowed, and + -- behaves as though the type were @'Foreign.Hoppy.Generator.Types.toGcT' + -- ('Foreign.Hoppy.Generator.Types.objT' cls)@ instead. + -- + -- This should be used for value objects so that you can simply use + -- @'Foreign.Hoppy.Generator.Types.objT' cls@ in return types, and also + -- write on @'mkProp' "..." ('Foreign.Hoppy.Generator.Types.objT' cls)@. + -- | Encoding parameters for a class that is not encodable or decodable. classConversionNone :: ClassConversion -classConversionNone = ClassConversion Nothing +classConversionNone = ClassConversion ClassConversionNone --- | Modifies classes' 'ClassEncoding' structures with a given function. +-- | Modifies a class's 'ClassConversion' structure with a given function. classModifyConversion :: (ClassConversion -> ClassConversion) -> Class -> Class classModifyConversion f cls = cls { classConversion = f $ classConversion cls } +-- | Replaces a class's 'ClassConversion' structure. +classSetConversion :: ClassConversion -> Class -> Class +classSetConversion c cls = cls { classConversion = c } + +-- | Modifies a class's 'ClassConversion' structure by setting all languages +-- to use 'ClassConversionToHeap'. +classSetConversionToHeap :: Class -> Class +classSetConversionToHeap cls = flip classModifyConversion cls $ \c -> + c { classHaskellConversion = ClassConversionToHeap + } + +-- | Modifies a class's 'ClassConversion' structure by setting all languages +-- that support garbage collection to use 'ClassConversionToGc'. +classSetConversionToGc :: Class -> Class +classSetConversionToGc cls = flip classModifyConversion cls $ \c -> + c { classHaskellConversion = ClassConversionToGc + } + +-- | Replaces a class's 'classHaskellConversion' with a given value. +classSetHaskellConversion :: ClassHaskellConversion -> Class -> Class +classSetHaskellConversion conv = classModifyConversion $ \c -> + c { classHaskellConversion = ClassConversionManual conv } + -- | Controls how conversions between C++ objects and Haskell values happen in -- Haskell bindings. data ClassHaskellConversion = ClassHaskellConversion @@ -1503,7 +1564,7 @@ -- > [ methods... ] ++ -- > mkProps -- > [ mkBoolIsProp myClass "adjustable" --- > , mkProp myClass "maxWidth" TInt +-- > , mkProp myClass "maxWidth" intT -- > ] mkProps :: [[Method]] -> [Method] mkProps = concat @@ -1517,7 +1578,7 @@ let c:cs = name setName = 's' : 'e' : 't' : toUpper c : cs in [ mkConstMethod name [] t - , mkMethod setName [t] TVoid + , mkMethod setName [t] Internal_TVoid ] -- | Creates a getter/setter binding pair for static methods: @@ -1529,7 +1590,7 @@ let c:cs = name setName = 's' : 'e' : 't' : toUpper c : cs in [ mkStaticMethod name [] t - , mkStaticMethod setName [t] TVoid + , mkStaticMethod setName [t] Internal_TVoid ] -- | Creates a getter/setter binding pair for boolean methods, where the getter @@ -1543,8 +1604,8 @@ name' = toUpper c : cs isName = 'i':'s':name' setName = 's':'e':'t':name' - in [ mkConstMethod isName [] TBool - , mkMethod setName [TBool] TVoid + in [ mkConstMethod isName [] Internal_TBool + , mkMethod setName [Internal_TBool] Internal_TVoid ] -- | Creates a getter/setter binding pair for boolean methods, where the getter @@ -1558,8 +1619,8 @@ name' = toUpper c : cs hasName = 'h':'a':'s':name' setName = 's':'e':'t':name' - in [ mkConstMethod hasName [] TBool - , mkMethod setName [TBool] TVoid + in [ mkConstMethod hasName [] Internal_TBool + , mkMethod setName [Internal_TBool] Internal_TVoid ] -- | A non-C++ function that can be invoked via a C++ functor. @@ -1599,9 +1660,10 @@ -> Callback makeCallback extName paramTypes retType = Callback extName paramTypes retType mempty mempty --- | Creates a 'TFn' from a callback's parameter and return types. +-- | Creates a 'Foreign.Hoppy.Generator.Types.fnT' from a callback's parameter +-- and return types. callbackToTFn :: Callback -> Type -callbackToTFn = TFn <$> callbackParams <*> callbackReturn +callbackToTFn = Internal_TFn <$> callbackParams <*> callbackReturn -- | A collection of imports for a Haskell module. This is a monoid: import -- Statements are merged to give the union of imported bindings. @@ -1787,10 +1849,29 @@ hsImportForUnsafeIO :: HsImportSet hsImportForUnsafeIO = hsQualifiedImport "System.IO.Unsafe" "HoppySIU" --- | Returns an error message indicating that 'TObjToHeap' is used where data is --- going from a foreign langauge into C++. -tObjToHeapWrongDirectionErrorMsg :: Maybe String -> Class -> String -tObjToHeapWrongDirectionErrorMsg maybeCaller cls = +-- | Returns an error message indicating that +-- 'Foreign.Hoppy.Generator.Types.objToHeapT' is used where data is going from a +-- foreign language into C++. +objToHeapTWrongDirectionErrorMsg :: Maybe String -> Class -> String +objToHeapTWrongDirectionErrorMsg maybeCaller cls = concat [maybe "" (++ ": ") maybeCaller, "(TObjToHeap ", show cls, ") cannot be passed into C++", + maybe "" (const ".") maybeCaller] + +-- | Returns an error message indicating that +-- 'Foreign.Hoppy.Generator.Types.objToHeapT' is used where data is going from a +-- foreign language into C++. +tToGcInvalidFormErrorMessage :: Maybe String -> Type -> String +tToGcInvalidFormErrorMessage maybeCaller typeArg = + concat [maybe "" (++ ": ") maybeCaller, + "(", show (Internal_TToGc typeArg), ") is an invalid form for TToGc.", + maybe "" (const ".") maybeCaller] + +-- | Returns an error message indicating that +-- 'Foreign.Hoppy.Generator.Types.toGcT' is used where data is going from a +-- foreign language into C++. +toGcTWrongDirectionErrorMsg :: Maybe String -> Type -> String +toGcTWrongDirectionErrorMsg maybeCaller typeArg = + concat [maybe "" (++ ": ") maybeCaller, + "(", show (Internal_TToGc typeArg), ") cannot be passed into C++", maybe "" (const ".") maybeCaller] diff --git a/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs b/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs --- a/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs +++ b/src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs @@ -27,6 +27,7 @@ import Data.Monoid (mempty) #endif import Foreign.Hoppy.Generator.Spec +import Foreign.Hoppy.Generator.Types -- | Sets of functionality that can be stamped onto a class with -- 'classAddFeatures'. @@ -54,23 +55,23 @@ assignableContents :: Class -> ([Ctor], [Method], Reqs) assignableContents cls = ([], - [ mkMethod OpAssign [TRef $ TConst $ TObj cls] $ TRef $ TObj cls + [ mkMethod OpAssign [refT $ constT $ objT cls] $ refT $ objT cls ], mempty) comparableContents :: Class -> ([Ctor], [Method], Reqs) comparableContents cls = ([], - [ mkConstMethod OpLt [TRef $ TConst $ TObj cls] TBool - , mkConstMethod OpLe [TRef $ TConst $ TObj cls] TBool - , mkConstMethod OpGt [TRef $ TConst $ TObj cls] TBool - , mkConstMethod OpGe [TRef $ TConst $ TObj cls] TBool + [ mkConstMethod OpLt [refT $ constT $ objT cls] boolT + , mkConstMethod OpLe [refT $ constT $ objT cls] boolT + , mkConstMethod OpGt [refT $ constT $ objT cls] boolT + , mkConstMethod OpGe [refT $ constT $ objT cls] boolT ], mempty) copyableContents :: Class -> ([Ctor], [Method], Reqs) copyableContents cls = - ([ mkCtor "newCopy" [TObj cls] + ([ mkCtor "newCopy" [objT cls] ], [], mempty) @@ -78,8 +79,8 @@ equatableContents :: Class -> ([Ctor], [Method], Reqs) equatableContents cls = ([], - [ mkConstMethod OpEq [TObj cls] TBool - , mkConstMethod OpNe [TObj cls] TBool + [ mkConstMethod OpEq [objT cls] boolT + , mkConstMethod OpNe [objT cls] boolT ], mempty) diff --git a/src/Foreign/Hoppy/Generator/Types.hs b/src/Foreign/Hoppy/Generator/Types.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Hoppy/Generator/Types.hs @@ -0,0 +1,184 @@ +-- This file is part of Hoppy. +-- +-- Copyright 2016 Bryan Gardiner +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +-- | Concrete C++ types. It is possible to represent invalid C++ types with +-- these functions, but we try to catch these and fail cleanly as much as +-- possible. +module Foreign.Hoppy.Generator.Types ( + -- * Primitive types + voidT, + boolT, + charT, + ucharT, + shortT, + ushortT, + intT, + uintT, + longT, + ulongT, + llongT, + ullongT, + floatT, + doubleT, + int8T, + int16T, + int32T, + int64T, + word8T, + word16T, + word32T, + word64T, + ptrdiffT, + sizeT, + ssizeT, + -- * Complex types + enumT, + bitspaceT, + ptrT, + refT, + fnT, + callbackT, + objT, + objToHeapT, + toGcT, + constT, + ) where + +import Foreign.Hoppy.Generator.Spec + +-- | C++ @void@, Haskell @()@. +voidT = Internal_TVoid + +-- | C++ @bool@, Haskell 'Bool'. +boolT = Internal_TBool + +-- | C++ @char@, Haskell 'Foreign.C.CChar'. +charT = Internal_TChar + +-- | C++ @unsigned char@, Haskell 'Foreign.C.CUChar'. +ucharT = Internal_TUChar + +-- | C++ @short int@, Haskell 'Foreign.C.CShort'. +shortT = Internal_TShort + +-- | C++ @unsigned short int@, Haskell 'Foreign.C.CUShort'. +ushortT = Internal_TUShort + +-- | C++ @int@, Haskell 'Foreign.C.CInt'. +intT = Internal_TInt + +-- | C++ @unsigned int@, Haskell 'Foreign.C.CUInt'. +uintT = Internal_TUInt + +-- | C++ @long int@, Haskell 'Foreign.C.CLong'. +longT = Internal_TLong + +-- | C++ @unsigned long int@, Haskell 'Foreign.C.CULong'. +ulongT = Internal_TULong + +-- | C++ @long long int@, Haskell 'Foreign.C.CLLong'. +llongT = Internal_TLLong + +-- | C++ @unsigned long long int@, Haskell 'Foreign.C.CULLong'. +ullongT = Internal_TULLong + +-- | C++ @float@, Haskell 'Foreign.C.CFloat'. +floatT = Internal_TFloat + +-- | C++ @double@, Haskell 'Foreign.C.CDouble'. +doubleT = Internal_TDouble + +-- | C++ @int8_t@, Haskell 'Data.Int.Int8'. +int8T = Internal_TInt8 + +-- | C++ @int16_t@, Haskell 'Data.Int.Int16'. +int16T = Internal_TInt16 + +-- | C++ @int32_t@, Haskell 'Data.Int.Int32'. +int32T = Internal_TInt32 + +-- | C++ @int64_t@, Haskell 'Data.Int.Int64'. +int64T = Internal_TInt64 + +-- | C++ @uint8_t@, Haskell 'Data.Word.Word8'. +word8T = Internal_TWord8 + +-- | C++ @uint16_t@, Haskell 'Data.Word.Word16'. +word16T = Internal_TWord16 + +-- | C++ @uint32_t@, Haskell 'Data.Word.Word32'. +word32T = Internal_TWord32 + +-- | C++ @uint64_t@, Haskell 'Data.Word.Word64'. +word64T = Internal_TWord64 + +-- | C++ @ptrdiff_t@, Haskell 'Foreign.C.CPtrdiff'. +ptrdiffT = Internal_TPtrdiff + +-- | C++ @size_t@, Haskell 'Foreign.C.CSize'. +sizeT = Internal_TSize + +-- | C++ @ssize_t@, Haskell 'System.Posix.Types.CSsize'. +ssizeT = Internal_TSSize + +-- | A C++ @enum@ value. +enumT = Internal_TEnum + +-- | A C++ bitspace value. +bitspaceT = Internal_TBitspace + +-- | A pointer to another type. +ptrT = Internal_TPtr + +-- | A reference to another type. +refT = Internal_TRef + +-- | A function taking parameters and returning a value (or 'voidT'). Function +-- pointers must wrap a 'fnT' in a 'ptrT'. +fnT = Internal_TFn + +-- | A handle for calling foreign code from C++. +callbackT = Internal_TCallback + +-- | An instance of a class. +objT = Internal_TObj + +-- | A special case of 'objT' that is only allowed when passing objects from +-- C++ to a foreign language. Rather than looking at the object's +-- 'ClassConversion', the object will be copied to the heap, and a pointer to +-- the heap object will be passed. The object must be copy-constructable. +-- +-- __The foreign language owns the pointer, even for callback arguments.__ +objToHeapT = Internal_TObjToHeap + +-- | This type transfers ownership of the object to the foreign language's +-- garbage collector, and results in a managed pointer in the foreign language. +-- This may only be used in one of the forms below, when passing data from C++ +-- to a foreign language (i.e. in a C++ function return type or in a callback +-- argument). In the first case, the temporary object is copied to the heap, +-- and the result is a managed pointer to the heap object instead of the +-- temporary. +-- +-- - @'toGcT' ('objT' cls)@ +-- - @'toGcT' ('refT' ('constT' ('objT' cls)))@ +-- - @'toGcT' ('refT' ('objT' cls))@ +-- - @'toGcT' ('ptrT' ('constT' ('objT' cls)))@ +-- - @'toGcT' ('ptrT' ('objT' cls))@ +toGcT = Internal_TToGc + +-- | A @const@ version of another type. +constT = Internal_TConst