hoppy-generator 0.1.0 → 0.2.0
raw patch · 8 files changed
+1133/−518 lines, 8 files
Files
- hoppy-generator.cabal +2/−1
- src/Foreign/Hoppy/Generator/Language/Cpp.hs +42/−39
- src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs +125/−96
- src/Foreign/Hoppy/Generator/Language/Haskell.hs +112/−51
- src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs +468/−213
- src/Foreign/Hoppy/Generator/Spec.hs +191/−110
- src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs +9/−8
- src/Foreign/Hoppy/Generator/Types.hs +184/−0
hoppy-generator.cabal view
@@ -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
src/Foreign/Hoppy/Generator/Language/Cpp.hs view
@@ -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
src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs view
@@ -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"
src/Foreign/Hoppy/Generator/Language/Haskell.hs view
@@ -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
src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs view
@@ -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
src/Foreign/Hoppy/Generator/Spec.hs view
@@ -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]
src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs view
@@ -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)
+ src/Foreign/Hoppy/Generator/Types.hs view
@@ -0,0 +1,184 @@+-- This file is part of Hoppy.+--+-- Copyright 2016 Bryan Gardiner <bog@khumba.net>+--+-- 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 <http://www.gnu.org/licenses/>.++-- | 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