hoppy-generator-0.2.0: src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs
-- This file is part of Hoppy.
--
-- Copyright 2015-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/>.
{-# LANGUAGE CPP #-}
-- | Internal portion of the Haskell code generator.
module Foreign.Hoppy.Generator.Language.Haskell.Internal (
Generation,
generate,
generatedFiles,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>), pure)
#endif
import Control.Arrow ((&&&), second)
import Control.Monad (forM, unless, when)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except (throwError)
#else
import Control.Monad.Error (throwError)
#endif
import Control.Monad.Trans (lift)
import Control.Monad.Writer (execWriterT, tell)
import Data.Foldable (forM_)
import Data.Graph (SCC (AcyclicSCC, CyclicSCC), stronglyConnComp)
import Data.List (intersperse)
import qualified Data.Map as M
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,
externalNameToCpp,
)
import Foreign.Hoppy.Generator.Language.Haskell
import Language.Haskell.Syntax (
HsAsst,
HsContext,
HsName (HsIdent),
HsQName (Special, UnQual),
HsQualType (HsQualType),
HsSpecialCon (HsUnitCon),
HsType (HsTyApp, HsTyCon, HsTyFun, HsTyVar),
)
import System.FilePath ((<.>), pathSeparator)
-- | The in-memory result of generating Haskell code for an interface.
data Generation = Generation
{ generatedFiles :: M.Map FilePath String
-- ^ A map from paths of generated files to the contents of those files.
-- The file paths are relative paths below the Haskell generation root.
}
-- | Runs the C++ code generator against an interface.
generate :: Interface -> Either ErrorMsg Generation
generate iface = do
-- Build the partial generation of each module.
modPartials <- forM (M.elems $ interfaceModules iface) $ \m ->
(,) m <$> execGenerator iface (getModuleName iface m) (generateSource m)
-- Compute the strongly connected components. If there is a nontrivial SCC,
-- then there is a module import cycle that we'll have to break with hs-boot
-- files.
let partialsByHsName :: M.Map HsModuleName Partial
partialsByHsName = M.fromList $ map ((partialModuleHsName &&& id) . snd) modPartials
sccInput :: [((Module, Partial), Partial, [Partial])]
sccInput = flip map modPartials $ \x@(_, p) ->
(x, p,
mapMaybe (flip M.lookup partialsByHsName . hsImportModule) $
M.keys $ getHsImportSet $ outputImports $ partialOutput p)
sccs :: [SCC (Module, Partial)]
sccs = stronglyConnComp sccInput
fileContents <- execWriterT $ forM_ sccs $ \scc -> case scc of
AcyclicSCC (_, p) -> tell [finishPartial p "hs"]
CyclicSCC mps -> do
let cycleModNames = S.fromList $ map (partialModuleHsName . snd) mps
forM_ mps $ \(m, p) -> do
-- Create a boot partial.
pBoot <- lift $ execGenerator iface (partialModuleHsName p) (generateBootSource m)
-- Change the source and boot partials so that all imports of modules in
-- this cycle are {-# SOURCE #-} imports.
let p' = setSourceImports cycleModNames p
pBoot' = setSourceImports cycleModNames pBoot
-- Emit the completed partials.
tell [finishPartial p' "hs", finishPartial pBoot' "hs-boot"]
return $ Generation $ M.fromList fileContents
where finishPartial :: Partial -> String -> (FilePath, String)
finishPartial p fileExt =
(listSubst '.' pathSeparator (partialModuleHsName p) <.> fileExt,
prependExtensions $ renderPartial p)
setSourceImports :: S.Set HsModuleName -> Partial -> Partial
setSourceImports modulesToSourceImport p =
let output = partialOutput p
imports = outputImports output
imports' = makeHsImportSet $
M.mapWithKey (setSourceImportIfIn modulesToSourceImport) $
getHsImportSet imports
output' = output { outputImports = imports' }
in p { partialOutput = output' }
setSourceImportIfIn :: S.Set HsModuleName -> HsImportKey -> HsImportSpecs -> HsImportSpecs
setSourceImportIfIn modulesToSourceImport key specs =
if hsImportModule key `S.member` modulesToSourceImport
then specs { hsImportSource = True }
else specs
prependExtensions :: String -> String
prependExtensions = (prependExtensionsPrefix ++)
prependExtensionsPrefix :: String
prependExtensionsPrefix =
-- MultiParamTypeClasses is necessary for instances of Decodable and
-- Encodable. FlexibleContexts is needed for the type signature of the
-- function that wraps the actual callback function in callback creation
-- functions.
--
-- FlexibleInstances and TypeSynonymInstances are enabled to allow conversions
-- to and from String, which is really [Char].
--
-- UndecidableInstances is needed for instances of the form "SomeClassConstPtr
-- a => SomeClassValue a", and overlapping instances are used for the overlap
-- between these instances and instances of SomeClassValue for the class's
-- native Haskell type, when it's convertible. CPP is used for warning-free
-- 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.
concat
[ "{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving"
, ", MultiParamTypeClasses, TypeSynonymInstances, UndecidableInstances #-}\n"
, "#if !MIN_VERSION_base(4,8,0)\n"
, "{-# LANGUAGE OverlappingInstances #-}\n"
, "#endif\n\n"
]
generateSource :: Module -> Generator ()
generateSource m = do
forM_ (moduleExports m) $ sayExport SayExportForeignImports
forM_ (moduleExports m) $ sayExport SayExportDecls
generateBootSource :: Module -> Generator ()
generateBootSource m =
forM_ (moduleExports m) $ sayExport SayExportBoot
data SayExportMode = SayExportForeignImports | SayExportDecls | SayExportBoot
deriving (Eq, Show)
sayExport :: SayExportMode -> Export -> Generator ()
sayExport mode export = do
case export of
ExportVariable v -> sayExportVar mode v
ExportEnum enum -> sayExportEnum mode enum
ExportBitspace bitspace -> sayExportBitspace mode bitspace
ExportFn fn ->
(sayExportFn mode <$> fnExtName <*> pure Nothing <*> fnPurity <*> fnParams <*> fnReturn) fn
ExportClass cls -> sayExportClass mode cls
ExportCallback cb -> sayExportCallback mode cb
when (mode == SayExportDecls) $
addendumHaskell $ exportAddendum export
sayExportVar :: SayExportMode -> Variable -> Generator ()
sayExportVar mode v = do
withErrorContext ("generating variable " ++ show (varExtName v)) $ do
let (isConst, deconstType) = case varType v of
Internal_TConst t -> (True, t)
t -> (False, t)
sayExportFn mode (varGetterExtName v) Nothing Nonpure [] deconstType
unless isConst $
sayExportFn mode (varSetterExtName v) Nothing Nonpure [deconstType] voidT
sayExportEnum :: SayExportMode -> CppEnum -> Generator ()
sayExportEnum mode enum =
withErrorContext ("generating enum " ++ show (enumExtName enum)) $
case mode of
-- Nothing to import from the C++ side of an enum.
SayExportForeignImports -> return ()
SayExportDecls -> do
let hsTypeName = toHsEnumTypeName enum
values :: [(Int, String)]
values = map (second $ toHsEnumCtorName enum) $ enumValueNames enum
addImports $ mconcat [hsImports "Prelude" ["($)", "(++)"], hsImportForPrelude]
-- Print out the data declaration.
ln
addExport' hsTypeName
saysLn ["data ", hsTypeName, " ="]
indent $ do
forM_ (zip (False:repeat True) values) $ \(cont, (_, hsCtorName)) ->
saysLn [if cont then "| " else "", hsCtorName]
sayLn "deriving (HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)"
-- Print out the Enum instance.
ln
saysLn ["instance HoppyP.Enum ", hsTypeName, " where"]
indent $ do
forM_ values $ \(num, hsCtorName) ->
saysLn ["fromEnum ", hsCtorName, " = ", show num]
ln
forM_ values $ \(num, hsCtorName) ->
saysLn ["toEnum (", show num, ") = ", hsCtorName]
saysLn ["toEnum n' = HoppyP.error $ ",
show (concat ["Unknown ", hsTypeName, " numeric value: "]),
" ++ HoppyP.show n'"]
SayExportBoot -> do
let hsTypeName = toHsEnumTypeName enum
addImports hsImportForPrelude
addExport hsTypeName
ln
saysLn ["data ", hsTypeName]
saysLn ["instance HoppyP.Bounded ", hsTypeName]
saysLn ["instance HoppyP.Enum ", hsTypeName]
saysLn ["instance HoppyP.Eq ", hsTypeName]
saysLn ["instance HoppyP.Ord ", hsTypeName]
saysLn ["instance HoppyP.Show ", hsTypeName]
sayExportBitspace :: SayExportMode -> Bitspace -> Generator ()
sayExportBitspace mode bitspace =
withErrorContext ("generating bitspace " ++ show (bitspaceExtName bitspace)) $
let hsTypeName = toHsBitspaceTypeName bitspace
fromFnName = toHsBitspaceToNumName bitspace
className = toHsBitspaceClassName bitspace
toFnName = toHsBitspaceFromValueName bitspace
hsType = HsTyCon $ UnQual $ HsIdent hsTypeName
in case mode of
-- Nothing to import from the C++ side of a bitspace.
SayExportForeignImports -> return ()
SayExportDecls -> do
let values :: [(Int, String)]
values = map (second $ toHsBitspaceValueName bitspace) $ bitspaceValueNames bitspace
hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace
hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace
-- Print out the data declaration and conversion functions.
addImports $ mconcat [hsImportForBits, hsImportForPrelude, hsImportForRuntime]
addExport' hsTypeName
addExport' className
ln
saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ",
fromFnName, " :: ", prettyPrint hsCNumType, " }"]
indent $ sayLn "deriving (HoppyDB.Bits, HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)"
ln
saysLn ["class ", className, " a where"]
indent $ do
let tyVar = HsTyVar $ HsIdent "a"
saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType]
ln
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.
forM_ (bitspaceEnum bitspace) $ \enum -> do
let enumTypeName = toHsEnumTypeName enum
importHsModuleForExtName $ enumExtName enum
addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime]
ln
saysLn ["instance ", className, " ", enumTypeName, " where"]
indent $
saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral . HoppyP.fromEnum"]
-- Print out the constants.
ln
forM_ values $ \(num, valueName) -> do
addExport valueName
saysLn [valueName, " = ", hsTypeName, " ", show num]
SayExportBoot -> do
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 hsCNumType, " }"]
ln
saysLn ["instance HoppyDB.Bits ", hsTypeName]
saysLn ["instance HoppyP.Bounded ", hsTypeName]
saysLn ["instance HoppyP.Eq ", hsTypeName]
saysLn ["instance HoppyP.Ord ", hsTypeName]
saysLn ["instance HoppyP.Show ", hsTypeName]
ln
saysLn ["class ", className, " a where"]
indent $ do
let tyVar = HsTyVar $ HsIdent "a"
saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType]
ln
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
saysLn ["instance ", className, " ", enumTypeName]
sayExportFn :: SayExportMode
-> ExtName
-> Maybe (Constness, Class)
-> Purity
-> [Type]
-> Type
-> Generator ()
sayExportFn mode name methodInfo purity paramTypes retType =
let hsFnName = toHsFnName name
hsFnImportedName = hsFnName ++ "'"
in case mode of
SayExportForeignImports ->
withErrorContext ("generating imports for function " ++ show name) $ do
-- Print a "foreign import" statement.
hsCType <- fnToHsTypeAndUse HsCSide methodInfo purity paramTypes retType
saysLn ["foreign import ccall \"", externalNameToCpp name, "\" ", hsFnImportedName, " :: ",
prettyPrint hsCType]
SayExportDecls -> withErrorContext ("generating function " ++ show name) $ do
-- Print the type signature.
ln
addExport hsFnName
hsHsType <- fnToHsTypeAndUse HsHsSide methodInfo purity paramTypes retType
saysLn [hsFnName, " :: ", prettyPrint hsHsType]
case purity of
Nonpure -> return ()
Pure -> saysLn ["{-# NOINLINE ", hsFnName, " #-}"]
-- Print the function body.
let argNames = map toArgName [1..length paramTypes]
argNamesWithThis = (if isJust methodInfo then ("this":) else id) argNames
convertedArgNames = map (++ "'") argNames
-- Operators on this line must bind more weakly than operators used below,
-- namely ($) and (>>=). (So finish the line with ($).)
lineEnd <- case purity of
Nonpure -> return [" ="]
Pure -> do addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForUnsafeIO]
return [" = HoppySIU.unsafePerformIO $"]
saysLn $ hsFnName : map (' ':) argNamesWithThis ++ lineEnd
indent $ do
forM_ (zip3 paramTypes argNames convertedArgNames) $ \(t, argName, argName') ->
sayArgProcessing ToCpp t argName argName'
sayCallAndProcessReturn ToCpp retType $
hsFnImportedName :
(case methodInfo of
Just (cst, cls) -> " (" ++ toHsCastMethodName cst cls ++ " this)"
Nothing -> "") :
map (' ':) convertedArgNames
SayExportBoot ->
-- Functions (methods included) cannot be referenced from other exports,
-- so we don't need to emit anything.
return ()
-- | Prints \"foreign import\" statements and an internal callback construction
-- function for a given 'Callback' specification. For example, for a callback
-- of 'HsHsSide' type @Int -> String -> IO Int@, we will generate the following
-- bindings:
--
-- > foreign import ccall "wrapper" name'newFunPtr
-- > :: (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 -> Ptr CChar -> IO CInt)
-- > -> FunPtr (FunPtr (IO ()) -> IO ())
-- > -> Bool
-- > -> IO (CCallback (CInt -> Ptr CChar -> 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'
-- > arg2 <- ...decode the string...
-- > f arg1 arg2 >>= return
-- > cfp <- name'newFunPtr cf
-- > name'newCallback cfp freeHaskellFunPtrFunPtr False
--
-- Only the implementation of bindings that take a callback of this type will
-- make use of this @name@ binding; @name@ is not useful to users of bindings.
sayExportCallback :: SayExportMode -> Callback -> Generator ()
sayExportCallback mode cb =
withErrorContext ("generating callback " ++ show (callbackExtName cb)) $ do
let name = callbackExtName cb
paramTypes = callbackParams cb
retType = callbackReturn cb
fnType = callbackToTFn cb
hsFnName = toHsCallbackCtorName cb
hsFnName'newCallback = hsFnName ++ "'newCallback"
hsFnName'newFunPtr = hsFnName ++ "'newFunPtr"
hsFnCType <- cppTypeToHsTypeAndUse HsCSide fnType
hsFnHsType <- cppTypeToHsTypeAndUse HsHsSide fnType
let getWholeFnType = do
addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]
return $
HsTyFun hsFnHsType $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType
case mode of
SayExportForeignImports -> do
addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]
let hsFunPtrType = HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType
hsFunPtrImportType =
HsTyFun hsFnCType $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsFunPtrType
hsCallbackCtorImportType =
HsTyFun hsFunPtrType $
HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $
HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyCon $ Special HsUnitCon) $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyCon $ Special HsUnitCon) $
HsTyFun (HsTyCon $ UnQual $ HsIdent "HoppyP.Bool") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType
saysLn ["foreign import ccall \"wrapper\" ", hsFnName'newFunPtr, " :: ",
prettyPrint hsFunPtrImportType]
saysLn ["foreign import ccall \"", externalNameToCpp name, "\" ",
hsFnName'newCallback, " :: ", prettyPrint hsCallbackCtorImportType]
SayExportDecls -> do
addExport hsFnName
wholeFnType <- getWholeFnType
let paramCount = length paramTypes
argNames = map toArgName [1..paramCount]
argNames' = map (++ "'") argNames
ln
saysLn [hsFnName, " :: ", prettyPrint wholeFnType]
saysLn [hsFnName, " f'hs = do"]
indent $ do
sayLet
[do saysLn ["f'c ", unwords argNames, " ="]
indent $ do
forM_ (zip3 paramTypes argNames argNames') $ \(t, argName, argName') ->
sayArgProcessing FromCpp t argName argName'
sayCallAndProcessReturn FromCpp retType $
"f'hs" : map (' ':) argNames']
Nothing
saysLn ["f'p <- ", hsFnName'newFunPtr, " f'c"]
saysLn [hsFnName'newCallback, " f'p HoppyFHR.freeHaskellFunPtrFunPtr HoppyP.False"]
SayExportBoot -> do
addExport hsFnName
wholeFnType <- getWholeFnType
ln
saysLn [hsFnName, " :: ", prettyPrint wholeFnType]
data CallDirection =
ToCpp -- ^ Haskell code is calling out to C++.
| FromCpp -- ^ C++ is invoking a callback.
sayArgProcessing :: CallDirection -> Type -> String -> String -> Generator ()
sayArgProcessing dir t fromVar toVar =
withErrorContext ("processing argument of type " ++ show t) $
case t 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"]
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
-- types with their Haskell ones across the board (e.g. CInt ->
-- Int).
case dir of
ToCpp -> " = HoppyFHR.coerceIntegral $ HoppyP.fromEnum "
FromCpp -> " = HoppyP.toEnum $ HoppyFHR.coerceIntegral ",
fromVar, " in"]
Internal_TBitspace b -> do
importHsModuleForExtName $ bitspaceExtName b
saysLn $ concat [ ["let ", toVar, " = "]
, case dir of
ToCpp -> [toHsBitspaceToNumName b, " $ ", toHsBitspaceFromValueName b]
FromCpp -> [toHsBitspaceTypeName b],
[" ", fromVar, " in"]
]
-- References and pointers are handled equivalently.
Internal_TPtr (Internal_TObj cls) -> do
addImportForClass cls
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++"
Internal_TObj cls -> case dir of
ToCpp -> do
-- Same as the (TPtr (TConst (TObj _))), ToPtr case.
addImportForClass cls
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.toGc ", fromVar, " >>= \\", toVar, " ->"]
Internal_TConst t' -> sayArgProcessing dir t' fromVar toVar
where noConversion = saysLn ["let ", toVar, " = ", fromVar, " in"]
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
-- language, 'FromCpp' means we're returning from it.
sayCallAndProcessReturn :: CallDirection -> Type -> [String] -> Generator ()
sayCallAndProcessReturn dir t callWords =
withErrorContext ("processing return value of type " ++ show t) $
case t of
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
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
-- with their Haskell ones across the board (e.g. CInt -> Int).
ToCpp -> saysLn ["HoppyP.fmap (HoppyP.toEnum . HoppyFHR.coerceIntegral)"]
FromCpp -> saysLn ["HoppyP.fmap (HoppyFHR.coerceIntegral . HoppyP.fromEnum)"]
sayCall
Internal_TBitspace b -> do
addImports hsImportForPrelude
importHsModuleForExtName $ bitspaceExtName b
saysLn ["HoppyP.fmap ", bitspaceConvFn dir b]
sayCall
-- 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
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 -> toHsBitspaceTypeName
FromCpp -> toHsBitspaceToNumName
sayExportClass :: SayExportMode -> Class -> Generator ()
sayExportClass mode cls = do
case mode of
SayExportForeignImports -> do
sayExportClassHsCtors mode cls
forM_ (classMethods cls) $ \method ->
(sayExportFn mode <$> getClassyExtName cls <*> pure Nothing <*> methodPurity <*>
pure (getMethodEffectiveParams cls method) <*> methodReturn) method
SayExportDecls -> do
sayExportClassHsClass True cls Const
sayExportClassHsClass True cls Nonconst
sayExportClassHsStaticMethods cls
-- Create a newtype for referencing foreign objects with pointers. The
-- newtype is not used with encodings of value objects.
sayExportClassHsType True cls Const
sayExportClassHsType True cls Nonconst
sayExportClassHsCtors mode cls
SayExportBoot -> do
sayExportClassHsClass False cls Const
sayExportClassHsClass False cls Nonconst
sayExportClassHsType False cls Const
sayExportClassHsType False cls Nonconst
sayExportClassCastPrimitives mode cls
sayExportClassHsSpecialFns mode cls
sayExportClassHsClass :: Bool -> Class -> Constness -> Generator ()
sayExportClassHsClass doDecls cls cst = do
let hsTypeName = toHsDataTypeName cst cls
hsValueClassName = toHsValueClassName cls
hsWithValuePtrName = toHsWithValuePtrName cls
hsPtrClassName = toHsPtrClassName cst cls
hsCastMethodName = toHsCastMethodName cst cls
supers = classSuperclasses cls
forM_ supers $ importHsModuleForExtName . classExtName
hsSupers <-
(\x -> if null x
then do addImports hsImportForRuntime
return ["HoppyFHR.CppPtr"]
else return x) $
case cst of
Const -> map (toHsPtrClassName Const) supers
Nonconst -> toHsPtrClassName Const cls : map (toHsPtrClassName Nonconst) supers
-- Print the value class definition. There is only one of these, and it is
-- spiritually closer to the const version of the pointers for this class, so
-- we emit for the const case only.
when (cst == Const) $ do
addImports hsImportForPrelude
addExport' hsValueClassName
ln
saysLn ["class ", hsValueClassName, " a where"]
indent $
saysLn [hsWithValuePtrName, " :: a -> (", hsTypeName, " -> HoppyP.IO b) -> HoppyP.IO b"]
-- Generate instances for all pointer subtypes.
ln
saysLn ["#if MIN_VERSION_base(4,8,0)"]
saysLn ["instance {-# OVERLAPPABLE #-} ", hsPtrClassName, " a => ", hsValueClassName, " a",
if doDecls then " where" else ""]
saysLn ["#else"]
saysLn ["instance ", hsPtrClassName, " a => ", hsValueClassName, " a",
if doDecls then " where" else ""]
saysLn ["#endif"]
when doDecls $ do
addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"],
hsImportForPrelude]
indent $ saysLn [hsWithValuePtrName, " = HoppyP.flip ($) . ", hsCastMethodName]
-- When the class has a native Haskell type, also print an instance for it.
forM_ (getClassHaskellConversion cls) $ \conv -> do
hsType <- classHaskellConversionType conv
ln
saysLn ["#if MIN_VERSION_base(4,8,0)"]
saysLn ["instance {-# OVERLAPPING #-} ", hsValueClassName, " (", prettyPrint hsType, ")",
if doDecls then " where" else ""]
saysLn ["#else"]
saysLn ["instance ", hsValueClassName, " (", prettyPrint hsType, ")",
if doDecls then " where" else ""]
saysLn ["#endif"]
when doDecls $ do
addImports hsImportForRuntime
indent $ saysLn [hsWithValuePtrName, " = HoppyFHR.withCppObj"]
-- Print the pointer class definition.
addExport' hsPtrClassName
ln
saysLn $
"class (" :
intersperse ", " (map (++ " this") hsSupers) ++
[") => ", hsPtrClassName, " this where"]
indent $ saysLn [hsCastMethodName, " :: this -> ", hsTypeName]
-- Print the non-static methods.
when doDecls $ do
let methods = filter ((cst ==) . methodConst) $ classMethods cls
forM_ methods $ \method ->
when (methodStatic method == Nonstatic) $
(sayExportFn SayExportDecls <$> getClassyExtName cls <*> pure Nothing <*>
methodPurity <*> pure (getMethodEffectiveParams cls method) <*>
methodReturn) method
sayExportClassHsStaticMethods :: Class -> Generator ()
sayExportClassHsStaticMethods cls =
forM_ (classMethods cls) $ \method ->
when (methodStatic method == Static) $
(sayExportFn SayExportDecls <$> getClassyExtName cls <*> pure Nothing <*> methodPurity <*>
methodParams <*> methodReturn) method
sayExportClassHsType :: Bool -> Class -> Constness -> Generator ()
sayExportClassHsType doDecls cls cst = do
addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]
-- Unfortunately, we must export the data constructor, so that GHC can marshal
-- it in foreign calls in other modules.
addExport' hsTypeName
ln
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
-- castFooToNonconst :: FooConst -> Foo
ln
let constCastFnName = toHsConstCastFnName cst cls
addExport constCastFnName
saysLn [constCastFnName, " :: ", toHsDataTypeName (constNegate cst) cls, " -> ", hsTypeName]
when doDecls $ do
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 $ hsImport1 "Prelude" "($)"
saysLn ["instance HoppyFHR.CppPtr ", hsTypeName, " where"]
indent $ do
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
saysLn ["instance HoppyFHR.Deletable ", hsTypeName, " where"]
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]
-- Generate instances for all superclasses' typeclasses.
genInstances [] cls
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
-- 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.
addImportForClass ancestorCls
forM_ (case cst of
Const -> [Const]
Nonconst -> [Const, Nonconst]) $ \typeclassCst -> do
saysLn ["instance ", toHsPtrClassName typeclassCst ancestorCls, " ", hsTypeName,
if doDecls then " where" else ""]
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 $ ancestorCls : path
sayExportClassHsCtors :: SayExportMode -> Class -> Generator ()
sayExportClassHsCtors mode cls =
forM_ (classCtors cls) $ \ctor ->
(sayExportFn mode <$> getClassyExtName cls <*> pure Nothing <*>
pure Nonpure <*> ctorParams <*> pure (ptrT $ objT cls)) ctor
sayExportClassHsSpecialFns :: SayExportMode -> Class -> Generator ()
sayExportClassHsSpecialFns mode cls = do
let typeName = toHsDataTypeName Nonconst cls
typeNameConst = toHsDataTypeName Const cls
-- Say the delete function.
case mode of
SayExportForeignImports -> when (classDtorIsPublic cls) $ do
addImports $ mconcat [hsImportForForeign, hsImportForPrelude]
saysLn ["foreign import ccall \"", classDeleteFnCppName cls, "\" ",
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 == [objT cls] || methodParams m == [refT $ constT $ objT cls]) &&
(case methodImpl m of
RealMethod name -> name == FnOp OpAssign
FnMethod name -> name == FnOp OpAssign)
withAssignmentMethod f = case assignmentMethods of
[] -> return ()
[m] -> f m
_ ->
throwError $ concat
["Can't determine an Assignable instance to generator for ", show cls,
" because it has multiple assignment operators ", show assignmentMethods]
when (mode == SayExportDecls) $ withAssignmentMethod $ \m -> do
addImports $ mconcat [hsImport1 "Prelude" "(>>)", hsImportForPrelude]
ln
saysLn ["instance ", toHsValueClassName cls, " a => HoppyFHR.Assignable ", typeName,
" a where"]
indent $
saysLn ["assign x' y' = ", toHsFnName $ getClassyExtName cls m,
" x' y' >> HoppyP.return ()"]
-- A pointer to an object pointer is decodable to an object pointer by peeking
-- at the value, so generate a Decodable instance. You are now a two-star
-- programmer. There is a generic @Ptr (Ptr a)@ to @Ptr a@ instance which
-- handles deeper levels.
case mode of
SayExportForeignImports -> return ()
SayExportDecls -> do
addImports $ mconcat [hsImport1 "Prelude" "(.)",
hsImportForForeign,
hsImportForPrelude,
hsImportForRuntime]
ln
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 (HoppyF.Ptr ", typeName, ")) ", typeName]
-- Say Encodable and Decodable instances, if the class is encodable and
-- decodable.
forM_ (getClassHaskellConversion cls) $ \conv -> do
hsType <- classHaskellConversionType conv
let hsTypeStr = concat ["(", prettyPrint hsType, ")"]
case mode of
SayExportForeignImports -> return ()
SayExportDecls -> do
addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]
-- Say the Encodable instances.
ln
saysLn ["instance HoppyFHR.Encodable ", typeName, " ", hsTypeStr, " where"]
indent $ do
sayLn "encode ="
indent $ classHaskellConversionToCppFn conv
ln
saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " ", hsTypeStr, " where"]
indent $
saysLn ["encode = HoppyP.fmap (", toHsCastMethodName Const cls,
") . HoppyFHR.encodeAs (HoppyP.undefined :: ", typeName, ")"]
-- Say the Decodable instances.
ln
saysLn ["instance HoppyFHR.Decodable ", typeName, " ", hsTypeStr, " where"]
indent $
saysLn ["decode = HoppyFHR.decode . ", toHsCastMethodName Const cls]
ln
saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " ", hsTypeStr, " where"]
indent $ do
sayLn "decode ="
indent $ classHaskellConversionFromCppFn conv
SayExportBoot -> do
addImports hsImportForRuntime
ln
saysLn ["instance HoppyFHR.Encodable ", typeName, " (", hsTypeStr, ")"]
saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " (", hsTypeStr, ")"]
saysLn ["instance HoppyFHR.Decodable ", typeName, " (", hsTypeStr, ")"]
saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " (", hsTypeStr, ")"]
sayExportClassCastPrimitives :: SayExportMode -> Class -> Generator ()
sayExportClassCastPrimitives mode cls = do
let clsType = toHsDataTypeName Const cls
case mode of
SayExportForeignImports ->
forAncestors cls $ \super -> do
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, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType
]
unless (classIsSubclassOfMonomorphic cls || classIsMonomorphicSuperclass super) $ do
addExport hsDownCastFnName
saysLn [ "foreign import ccall \"", classCastFnCppName super cls
, "\" ", hsDownCastFnName, " :: HoppyF.Ptr ", superType, " -> HoppyF.Ptr ", clsType
]
return True
SayExportDecls ->
-- Generate a downcast typeclass and instances for all ancestor classes
-- for the current constness. These don't need to be in the boot file,
-- since they're not used by other generated bindings.
unless (classIsSubclassOfMonomorphic cls) $
forM_ [minBound..] $ \cst -> do
let downCastClassName = toHsDownCastClassName cst cls
downCastMethodName = toHsDownCastMethodName cst cls
addExport' downCastClassName
ln
saysLn ["class ", downCastClassName, " a where"]
indent $ saysLn [downCastMethodName, " :: ",
prettyPrint $ HsTyFun (HsTyVar $ HsIdent "a") $
HsTyCon $ UnQual $ HsIdent $ toHsDataTypeName cst cls]
ln
forAncestors cls $ \super -> case classIsMonomorphicSuperclass super of
True -> return False
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 . downcast' . castFooToConst
-- where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr'
-- downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr'
--
-- instance BarSuperConst FooConst where
-- 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, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType]
return True
where forAncestors :: Class -> (Class -> Generator Bool) -> Generator ()
forAncestors cls' f = forM_ (classSuperclasses cls') $ \super -> do
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
-> [Type]
-> Type
-> Generator HsQualType
fnToHsTypeAndUse side methodInfo purity paramTypes returnType = do
params <- mapM contextForParam $
(case methodInfo of
Just (cst, cls) -> [("this", case cst of
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
-- 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 hsReturnForGc
_ -> do
addImports hsImportForPrelude
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
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
-- constraints.
handoff :: HsTypeSide -> Type -> Generator (Maybe HsAsst, HsType)
handoff side t = (,) Nothing <$> cppTypeToHsTypeAndUse side t
-- 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
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)
-- Receives a @FooValue a => a@.
receiveValue :: String -> Type -> Class -> Generator (Maybe HsAsst, HsType)
receiveValue s t cls = case side of
HsCSide -> handoff side t
HsHsSide -> do
addImports hsImportForRuntime
addImportForClass cls
let t' = HsTyVar $ HsIdent s
return (Just (UnQual $ HsIdent $ toHsValueClassName cls, [t']),
t')
getMethodEffectiveParams :: Class -> Method -> [Type]
getMethodEffectiveParams cls method =
(case methodImpl method of
RealMethod {} -> case methodApplicability method of
MNormal -> (ptrT (objT cls):)
MConst -> (ptrT (constT $ objT cls):)
MStatic -> id
FnMethod {} -> id) $
methodParams method
-- | Imports bindings for the given class into the Haskell module.
addImportForClass :: Class -> Generator ()
addImportForClass = importHsModuleForExtName . classExtName