{-# LANGUAGE CPP #-}
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 ((&&&))
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 (mapMaybe)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mconcat, mempty)
#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)
data Generation = Generation
{ generatedFiles :: M.Map FilePath String
}
generate :: Interface -> Either ErrorMsg Generation
generate iface = do
modPartials <- forM (M.elems $ interfaceModules iface) $ \m ->
(,) m <$> execGenerator iface m (generateSource m)
let partialsByHsName :: M.Map HsModuleName Partial
partialsByHsName = M.fromList $ map ((partialModuleHsName &&& id) . snd) modPartials
sccInput :: [((Module, Partial), Partial, [Partial])]
sccInput = for 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
pBoot <- lift $ execGenerator iface m (generateBootSource m)
let p' = setSourceImports cycleModNames p
pBoot' = setSourceImports cycleModNames pBoot
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 =
concat $ "{-# LANGUAGE " : intersperse ", " extensions ++ [" #-}\n"]
where extensions =
[ "FlexibleContexts"
, "FlexibleInstances"
, "ForeignFunctionInterface"
, "GeneralizedNewtypeDeriving"
, "MonoLocalBinds"
, "MultiParamTypeClasses"
, "ScopedTypeVariables"
, "TypeSynonymInstances"
, "UndecidableInstances"
]
generateSource :: Module -> Generator ()
generateSource m = do
forM_ (moduleExports m) $ sayExport SayExportForeignImports
forM_ (moduleExports m) $ sayExport SayExportDecls
iface <- askInterface
when (interfaceExceptionSupportModule iface == Just m) $
sayExceptionSupport True
addendumHaskell $ getAddendum m
generateBootSource :: Module -> Generator ()
generateBootSource m = do
forM_ (moduleExports m) $ sayExport SayExportBoot
iface <- askInterface
when (interfaceExceptionSupportModule iface == Just m) $
sayExceptionSupport False
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 <*> fnExtName <*> fnPurity <*>
fnParams <*> fnReturn <*> fnExceptionHandlers) fn
ExportClass cls -> sayExportClass mode cls
ExportCallback cb -> sayExportCallback mode cb
when (mode == SayExportDecls) $
addendumHaskell $ exportAddendum export
sayExportVar :: SayExportMode -> Variable -> Generator ()
sayExportVar mode v = withErrorContext ("generating variable " ++ show (varExtName v)) $ do
let getterName = varGetterExtName v
setterName = varSetterExtName v
sayExportVar' mode (varType v) Nothing True getterName getterName setterName setterName
sayExportClassVar :: SayExportMode -> Class -> ClassVariable -> Generator ()
sayExportClassVar mode cls v =
withErrorContext ("generating variable " ++ show (classVarExtName v)) $
sayExportVar' mode
(classVarType v)
(case classVarStatic v of
Nonstatic -> Just cls
Static -> Nothing)
(classVarGettable v)
(classVarGetterExtName cls v)
(classVarGetterForeignName cls v)
(classVarSetterExtName cls v)
(classVarSetterForeignName cls v)
sayExportVar' :: SayExportMode
-> Type
-> Maybe Class
-> Bool
-> ExtName
-> ExtName
-> ExtName
-> ExtName
-> Generator ()
sayExportVar' mode
t
classIfNonstatic
gettable
getterExtName
getterForeignName
setterExtName
setterForeignName = do
let (isConst, deconstType) = case t of
Internal_TConst t -> (True, t)
t -> (False, t)
when gettable $
sayExportFn mode
getterExtName
getterForeignName
Nonpure
(maybe [] (\cls -> [ptrT $ constT $ objT cls]) classIfNonstatic)
deconstType
mempty
unless isConst $
sayExportFn mode
setterExtName
setterForeignName
Nonpure
(maybe [deconstType] (\cls -> [ptrT $ objT cls, deconstType])
classIfNonstatic)
voidT
mempty
sayExportEnum :: SayExportMode -> CppEnum -> Generator ()
sayExportEnum mode enum =
withErrorContext ("generating enum " ++ show (enumExtName enum)) $
case mode of
SayExportForeignImports -> return ()
SayExportDecls -> do
hsTypeName <- toHsEnumTypeName enum
values <- forM (enumValueNames enum) $ \(value, name) -> do
ctorName <- toHsEnumCtorName enum name
return (value, ctorName)
addImports $ mconcat [hsImports "Prelude" ["($)", "(++)"], hsImportForPrelude]
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)"
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
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)) $ do
hsTypeName <- toHsBitspaceTypeName bitspace
fromFnName <- toHsBitspaceToNumName bitspace
className <- toHsBitspaceClassName bitspace
toFnName <- toHsBitspaceFromValueName bitspace
let hsType = HsTyCon $ UnQual $ HsIdent hsTypeName
case mode of
SayExportForeignImports -> return ()
SayExportDecls -> do
values <- forM (bitspaceValueNames bitspace) $ \(value, name) -> do
bindingName <- toHsBitspaceValueName bitspace name
return (value, bindingName)
hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace
hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace
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]
when (hsHsNumType /= hsCNumType) $ do
saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ") where"]
indent $ saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral"]
saysLn ["instance ", className, " ", hsTypeName, " where"]
indent $ saysLn [toFnName, " = HoppyP.id"]
forM_ (bitspaceEnum bitspace) $ \enum -> do
enumTypeName <- toHsEnumTypeName enum
addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime]
ln
saysLn ["instance ", className, " ", enumTypeName, " where"]
indent $
saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral . HoppyP.fromEnum"]
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, ")"]
when (hsHsNumType /= hsCNumType) $
saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ")"]
saysLn ["instance ", className, " ", hsTypeName]
forM_ (bitspaceEnum bitspace) $ \enum -> do
enumTypeName <- toHsEnumTypeName enum
saysLn ["instance ", className, " ", enumTypeName]
sayExportFn :: SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Type]
-> Type
-> ExceptionHandlers
-> Generator ()
sayExportFn mode extName foreignName purity paramTypes retType exceptionHandlers = do
effectiveHandlers <- getEffectiveExceptionHandlers exceptionHandlers
let handlerList = exceptionHandlersList effectiveHandlers
catches = not $ null handlerList
let hsFnName = toHsFnName' foreignName
hsFnImportedName = hsFnName ++ "'"
case mode of
SayExportForeignImports ->
withErrorContext ("generating imports for function " ++ show extName) $ do
hsCType <- fnToHsTypeAndUse HsCSide purity paramTypes retType effectiveHandlers
saysLn ["foreign import ccall \"", externalNameToCpp extName, "\" ", hsFnImportedName,
" :: ", prettyPrint hsCType]
SayExportDecls -> withErrorContext ("generating function " ++ show extName) $ do
ln
addExport hsFnName
hsHsType <- fnToHsTypeAndUse HsHsSide purity paramTypes retType effectiveHandlers
saysLn [hsFnName, " :: ", prettyPrint hsHsType]
case purity of
Nonpure -> return ()
Pure -> saysLn ["{-# NOINLINE ", hsFnName, " #-}"]
let argNames = map toArgName [1..length paramTypes]
convertedArgNames = map (++ "'") argNames
lineEnd <- case purity of
Nonpure -> return [" ="]
Pure -> do addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForUnsafeIO]
return [" = HoppySIU.unsafePerformIO $"]
saysLn $ hsFnName : map (' ':) argNames ++ lineEnd
indent $ do
forM_ (zip3 paramTypes argNames convertedArgNames) $ \(t, argName, argName') ->
sayArgProcessing ToCpp t argName argName'
exceptionHandling <-
if catches
then do iface <- askInterface
currentModule <- askModule
let exceptionSupportModule = interfaceExceptionSupportModule iface
when (exceptionSupportModule /= Just currentModule) $
addImports . hsWholeModuleImport . getModuleName iface =<<
fromMaybeM (throwError
"Internal error, an exception support module is not available")
exceptionSupportModule
addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForRuntime]
return "HoppyFHR.internalHandleExceptions exceptionDb' $"
else return ""
let callWords = exceptionHandling : hsFnImportedName : map (' ':) convertedArgNames
sayCallAndProcessReturn ToCpp retType callWords
SayExportBoot ->
return ()
sayExportCallback :: SayExportMode -> Callback -> Generator ()
sayExportCallback mode cb =
withErrorContext ("generating callback " ++ show (callbackExtName cb)) $ do
let name = callbackExtName cb
paramTypes = callbackParams cb
retType = callbackReturn cb
hsNewFunPtrFnName <- toHsCallbackNewFunPtrFnName cb
hsCtorName <- toHsCallbackCtorName cb
let hsCtorName'newCallback = hsCtorName ++ "'newCallback"
hsCtorName'newFunPtr = hsCtorName ++ "'newFunPtr"
hsFnCType <- cppTypeToHsTypeAndUse HsCSide =<< callbackToTFn HsCSide cb
hsFnHsType <- cppTypeToHsTypeAndUse HsHsSide =<< callbackToTFn HsHsSide cb
let getWholeNewFunPtrFnType = do
addImports $ mconcat [hsImportForForeign, hsImportForPrelude]
return $
HsTyFun hsFnHsType $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType
getWholeCtorType = 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\" ", hsCtorName'newFunPtr, " :: ",
prettyPrint hsFunPtrImportType]
saysLn ["foreign import ccall \"", externalNameToCpp name, "\" ",
hsCtorName'newCallback, " :: ", prettyPrint hsCallbackCtorImportType]
SayExportDecls -> do
addExports [hsNewFunPtrFnName, hsCtorName]
wholeNewFunPtrFnType <- getWholeNewFunPtrFnType
let paramCount = length paramTypes
argNames = map toArgName [1..paramCount]
argNames' = map (++ "'") argNames
throws <- getEffectiveCallbackThrows cb
addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForRuntime]
ln
saysLn [hsNewFunPtrFnName, " :: ", prettyPrint wholeNewFunPtrFnType]
saysLn $ hsNewFunPtrFnName : " f'hs = " : hsCtorName'newFunPtr : " $" :
case (if throws then (++ ["excIdPtr", "excPtrPtr"]) else id) argNames of
[] -> []
argNames' -> [" \\", unwords argNames', " ->"]
indent $ do
when throws $ sayLn "HoppyFHR.internalHandleCallbackExceptions excIdPtr excPtrPtr $"
forM_ (zip3 paramTypes argNames argNames') $ \(t, argName, argName') ->
sayArgProcessing FromCpp t argName argName'
sayCallAndProcessReturn FromCpp retType $
"f'hs" : map (' ':) argNames'
wholeCtorType <- getWholeCtorType
ln
saysLn [hsCtorName, " :: ", prettyPrint wholeCtorType]
saysLn [hsCtorName, " f'hs = do"]
indent $ do
saysLn ["f'p <- ", hsNewFunPtrFnName, " f'hs"]
saysLn [hsCtorName'newCallback, " f'p HoppyFHR.freeHaskellFunPtrFunPtr HoppyP.False"]
SayExportBoot -> do
addExports [hsNewFunPtrFnName, hsCtorName]
wholeNewFunPtrFnType <- getWholeNewFunPtrFnType
wholeCtorType <- getWholeCtorType
ln
saysLn [hsNewFunPtrFnName, " :: ", prettyPrint wholeNewFunPtrFnType]
ln
saysLn [hsCtorName, " :: ", prettyPrint wholeCtorType]
data CallDirection =
ToCpp
| FromCpp
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,
case dir of
ToCpp -> " = HoppyFHR.coerceIntegral $ HoppyP.fromEnum "
FromCpp -> " = HoppyP.toEnum $ HoppyFHR.coerceIntegral ",
fromVar, " in"]
Internal_TBitspace b -> case dir of
ToCpp -> do
toNumName <- toHsBitspaceToNumName b
fromValueName <- toHsBitspaceFromValueName b
saysLn ["let ", toVar, " = ", toNumName, " $ ", fromValueName, " ", fromVar, " in"]
FromCpp -> do
typeName <- toHsBitspaceTypeName b
saysLn ["let ", toVar, " = " , typeName, " ", fromVar, " in"]
Internal_TPtr (Internal_TObj cls) -> case dir of
ToCpp -> do
addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForRuntime]
castMethodName <- toHsCastMethodName Nonconst cls
saysLn ["HoppyFHR.withCppPtr (", castMethodName, " ", fromVar,
") $ \\", toVar, " ->"]
FromCpp -> do
ctorName <- toHsDataCtorName Unmanaged Nonconst cls
saysLn ["let ", toVar, " = ", ctorName, " ", fromVar, " in"]
Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of
ToCpp -> do
addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForPrelude,
hsImportForRuntime]
withValuePtrName <- toHsWithValuePtrName cls
saysLn [withValuePtrName, " ", fromVar,
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"]
FromCpp -> do
ctorName <- toHsDataCtorName Unmanaged Const cls
saysLn ["let ", toVar, " = ", ctorName, " ", 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" "(>>=)"
callbackCtorName <- toHsCallbackCtorName cb
saysLn [callbackCtorName, " ", fromVar, " >>= \\", toVar, " ->"]
FromCpp -> throwError "Can't receive a callback from C++"
Internal_TObj cls -> case dir of
ToCpp -> do
addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForPrelude,
hsImportForRuntime]
withValuePtrName <- toHsWithValuePtrName cls
saysLn [withValuePtrName, " ", fromVar,
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"]
FromCpp -> case classHaskellConversionFromCppFn $ getClassHaskellConversion cls of
Just _ -> do
addImports $ mconcat [hsImport1 "Prelude" "(>>=)",
hsImportForRuntime]
ctorName <- toHsDataCtorName Unmanaged Const cls
saysLn ["HoppyFHR.decode (", ctorName, " ", fromVar, ") >>= \\", toVar, " ->"]
Nothing ->
throwError $ concat
["Can't pass a TObj of ", show cls,
" from C++ to Haskell because no class decode conversion is defined"]
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]
ctorName <-
maybe (throwError $ tToGcInvalidFormErrorMessage Nothing t')
(toHsDataCtorName Unmanaged Nonconst) $
case stripConst t' of
Internal_TObj cls -> Just cls
Internal_TRef (Internal_TConst (Internal_TObj cls)) -> Just cls
Internal_TRef (Internal_TObj cls) -> Just cls
Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> Just cls
Internal_TPtr (Internal_TObj cls) -> Just cls
_ -> Nothing
saysLn ["HoppyFHR.toGc (", ctorName, " ", 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"]
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
ToCpp -> saysLn ["HoppyP.fmap (HoppyP.toEnum . HoppyFHR.coerceIntegral)"]
FromCpp -> saysLn ["HoppyP.fmap (HoppyFHR.coerceIntegral . HoppyP.fromEnum)"]
sayCall
Internal_TBitspace b -> do
addImports hsImportForPrelude
convFn <- bitspaceConvFn dir b
saysLn ["HoppyP.fmap ", convFn]
sayCall
Internal_TPtr (Internal_TObj cls) -> do
case dir of
ToCpp -> do
addImports hsImportForPrelude
ctorName <- toHsDataCtorName Unmanaged Nonconst cls
saysLn ["HoppyP.fmap ", ctorName]
sayCall
FromCpp -> do
addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]
sayLn "HoppyP.fmap HoppyFHR.toPtr"
sayCall
Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of
ToCpp -> do
addImports hsImportForPrelude
ctorName <- toHsDataCtorName Unmanaged Const cls
saysLn ["HoppyP.fmap ", ctorName]
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" "(=<<)"
ctorName <- toHsCallbackCtorName cb
saysLn [ctorName, "=<<"]
sayCall
Internal_TObj cls -> case dir of
ToCpp -> case classHaskellConversionFromCppFn $ getClassHaskellConversion cls of
Just _ -> do
addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"],
hsImportForRuntime]
ctorName <- toHsDataCtorName Unmanaged Const cls
saysLn ["(HoppyFHR.decodeAndDelete . ", ctorName, ") =<<"]
sayCall
Nothing ->
throwError $ concat
["Can't return a TObj of ", show cls,
" from C++ to Haskell because no class decode conversion is defined"]
FromCpp -> do
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 =<<"
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 = withErrorContext ("generating class " ++ show (classExtName cls)) $ do
case mode of
SayExportForeignImports -> do
sayExportClassHsVars mode cls
sayExportClassHsCtors mode cls
forM_ (classMethods cls) $ \method ->
(sayExportFn mode <$> classEntityExtName cls <*> classEntityForeignName cls <*>
methodPurity <*> pure (getMethodEffectiveParams cls method) <*>
methodReturn <*> methodExceptionHandlers)
method
SayExportDecls -> do
sayExportClassHsClass True cls Const
sayExportClassHsClass True cls Nonconst
sayExportClassHsStaticMethods cls
sayExportClassHsType True cls Const
sayExportClassHsType True cls Nonconst
sayExportClassExceptionSupport True cls
sayExportClassHsVars mode cls
sayExportClassHsCtors mode cls
SayExportBoot -> do
sayExportClassHsClass False cls Const
sayExportClassHsClass False cls Nonconst
sayExportClassHsType False cls Const
sayExportClassHsType False cls Nonconst
sayExportClassExceptionSupport False cls
sayExportClassHsVars mode cls
sayExportClassCastPrimitives mode cls
sayExportClassHsSpecialFns mode cls
sayExportClassHsClass :: Bool -> Class -> Constness -> Generator ()
sayExportClassHsClass doDecls cls cst = withErrorContext "generating Haskell typeclass" $ do
hsTypeName <- toHsDataTypeName cst cls
hsValueClassName <- toHsValueClassName cls
hsWithValuePtrName <- toHsWithValuePtrName cls
hsPtrClassName <- toHsPtrClassName cst cls
hsCastMethodName <- toHsCastMethodName cst cls
let supers = classSuperclasses cls
hsSupers <-
(\x -> if null x
then do addImports hsImportForRuntime
return ["HoppyFHR.CppPtr"]
else return x) =<<
case cst of
Const -> mapM (toHsPtrClassName Const) supers
Nonconst ->
(:) <$> toHsPtrClassName Const cls <*> mapM (toHsPtrClassName Nonconst) supers
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"]
ln
saysLn ["instance {-# OVERLAPPABLE #-} ", hsPtrClassName, " a => ", hsValueClassName, " a",
if doDecls then " where" else ""]
when doDecls $ do
addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"],
hsImportForPrelude]
indent $ saysLn [hsWithValuePtrName, " = HoppyP.flip ($) . ", hsCastMethodName]
let conv = getClassHaskellConversion cls
case (classHaskellConversionType conv,
classHaskellConversionToCppFn conv) of
(Just hsTypeGen, Just _) -> do
hsType <- hsTypeGen
ln
saysLn ["instance {-# OVERLAPPING #-} ", hsValueClassName, " (", prettyPrint hsType, ")",
if doDecls then " where" else ""]
when doDecls $ do
addImports hsImportForRuntime
indent $ saysLn [hsWithValuePtrName, " = HoppyFHR.withCppObj"]
_ -> return ()
addExport' hsPtrClassName
ln
saysLn $
"class (" :
intersperse ", " (map (++ " this") hsSupers) ++
[") => ", hsPtrClassName, " this where"]
indent $ saysLn [hsCastMethodName, " :: this -> ", hsTypeName]
when doDecls $ do
let methods = filter ((cst ==) . methodConst) $ classMethods cls
forM_ methods $ \method ->
when (methodStatic method == Nonstatic) $
(sayExportFn SayExportDecls <$> classEntityExtName cls <*> classEntityForeignName cls <*>
methodPurity <*> pure (getMethodEffectiveParams cls method) <*>
methodReturn <*> methodExceptionHandlers) method
sayExportClassHsStaticMethods :: Class -> Generator ()
sayExportClassHsStaticMethods cls =
forM_ (classMethods cls) $ \method ->
when (methodStatic method == Static) $
(sayExportFn SayExportDecls <$> classEntityExtName cls <*> classEntityForeignName cls <*>
methodPurity <*> methodParams <*> methodReturn <*> methodExceptionHandlers) method
sayExportClassHsType :: Bool -> Class -> Constness -> Generator ()
sayExportClassHsType doDecls cls cst = withErrorContext "generating Haskell data types" $ do
hsTypeName <- toHsDataTypeName cst cls
hsCtor <- toHsDataCtorName Unmanaged cst cls
hsCtorGc <- toHsDataCtorName Managed cst cls
constCastFnName <- toHsConstCastFnName cst cls
addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]
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)"]
hsTypeNameOppConst <- toHsDataTypeName (constNegate cst) cls
ln
addExport constCastFnName
saysLn [constCastFnName, " :: ", hsTypeNameOppConst, " -> ", hsTypeName]
when doDecls $ do
addImports $ hsImport1 "Prelude" "($)"
hsCtorOppConst <- toHsDataCtorName Unmanaged (constNegate cst) cls
hsCtorGcOppConst <- toHsDataCtorName Managed (constNegate cst) cls
saysLn [constCastFnName, " (", hsCtorOppConst,
" ptr') = ", hsCtor, " $ HoppyF.castPtr ptr'"]
saysLn [constCastFnName, " (", hsCtorGcOppConst,
" fptr' ptr') = ", hsCtorGc, " fptr' $ HoppyF.castPtr ptr'"]
ln
if doDecls
then do addImports $ hsImport1 "Prelude" "($)"
saysLn ["instance HoppyFHR.CppPtr ", hsTypeName, " where"]
indent $ do
saysLn ["nullptr = ", hsCtor, " 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
case cst of
Const ->
saysLn ["delete (", hsCtor, " ptr') = ", toHsClassDeleteFnName' cls, " ptr'"]
Nonconst -> do
constTypeName <- toHsDataTypeName Const cls
saysLn ["delete (",hsCtor, " ptr') = ", toHsClassDeleteFnName' cls,
" $ (HoppyF.castPtr ptr' :: HoppyF.Ptr ", constTypeName, ")"]
saysLn ["delete (", hsCtorGc,
" _ _) = HoppyP.fail $ HoppyP.concat ",
"[\"Deletable.delete: Asked to delete a GC-managed \", ",
show hsTypeName, ", \" object.\"]"]
ln
saysLn ["toGc this'@(", hsCtor, " ptr') = ",
"if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ",
"(HoppyP.flip ", hsCtorGc, " ptr') $ ",
"HoppyF.newForeignPtr ",
"(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls,
" :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",
"(HoppyF.castPtr ptr' :: HoppyF.Ptr ())"]
saysLn ["toGc this'@(", hsCtorGc, " {}) = HoppyP.return this'"]
forM_ (classFindCopyCtor cls) $ \copyCtor -> do
copyCtorName <- toHsCtorName cls copyCtor
ln
saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ",
case cst of
Nonconst -> hsTypeName
Const -> hsTypeNameOppConst,
" where copy = ", copyCtorName]
else do saysLn ["instance HoppyFHR.CppPtr ", hsTypeName]
when (classDtorIsPublic cls) $
saysLn ["instance HoppyFHR.Deletable ", hsTypeName]
forM_ (classFindCopyCtor cls) $ \_ ->
saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ",
case cst of
Nonconst -> hsTypeName
Const -> hsTypeNameOppConst]
genInstances hsTypeName [] cls
where genInstances :: String -> [Class] -> Class -> Generator ()
genInstances hsTypeName path ancestorCls = do
forM_ (case cst of
Const -> [Const]
Nonconst -> [Const, Nonconst]) $ \ancestorCst -> do
ln
ancestorPtrClassName <- toHsPtrClassName ancestorCst ancestorCls
saysLn ["instance ", ancestorPtrClassName, " ", hsTypeName,
if doDecls then " where" else ""]
when doDecls $ indent $ do
let castMethodName = toHsCastMethodName' ancestorCst ancestorCls
if null path && cst == ancestorCst
then do addImports hsImportForPrelude
saysLn [castMethodName, " = HoppyP.id"]
else do let addConst = cst == Nonconst
removeConst = ancestorCst == Nonconst
when (addConst || removeConst) $
addImports hsImportForForeign
forM_ ([minBound..] :: [Managed]) $ \managed -> do
ancestorCtor <- case managed of
Unmanaged -> (\x -> [x]) <$>
toHsDataCtorName Unmanaged ancestorCst ancestorCls
Managed -> (\x -> [x, " fptr'"]) <$>
toHsDataCtorName Managed ancestorCst ancestorCls
ptrPattern <- case managed of
Unmanaged -> (\x -> [x, " ptr'"]) <$>
toHsDataCtorName Unmanaged cst cls
Managed -> (\x -> [x, " fptr' ptr'"]) <$>
toHsDataCtorName Managed cst cls
saysLn . concat =<< sequence
[ return $
[castMethodName, " ("] ++ ptrPattern ++ [") = "] ++ ancestorCtor
, if removeConst
then do ancestorConstType <- toHsDataTypeName Const ancestorCls
ancestorNonconstType <- toHsDataTypeName Nonconst ancestorCls
return [" $ (HoppyF.castPtr :: HoppyF.Ptr ",
ancestorConstType, " -> HoppyF.Ptr ",
ancestorNonconstType, ")"]
else return []
, if not $ null path
then do addImports $ hsImport1 "Prelude" "($)"
castPrimitiveName <- toHsCastPrimitiveName cls cls ancestorCls
return [" $ ", castPrimitiveName]
else return []
, if addConst
then do addImports $ hsImport1 "Prelude" "($)"
nonconstTypeName <- toHsDataTypeName Nonconst cls
constTypeName <- toHsDataTypeName Const cls
return [" $ (HoppyF.castPtr :: HoppyF.Ptr ",
nonconstTypeName, " -> HoppyF.Ptr ",
constTypeName, ")"]
else return []
, return [" ptr'"]
]
forM_ (classSuperclasses ancestorCls) $
genInstances hsTypeName $
ancestorCls : path
sayExportClassHsVars :: SayExportMode -> Class -> Generator ()
sayExportClassHsVars mode cls =
forM_ (classVariables cls) $ sayExportClassVar mode cls
sayExportClassHsCtors :: SayExportMode -> Class -> Generator ()
sayExportClassHsCtors mode cls =
withErrorContext "generating constructors" $
forM_ (classCtors cls) $ \ctor ->
(sayExportFn mode <$> classEntityExtName cls <*> classEntityForeignName cls <*>
pure Nonpure <*> ctorParams <*> pure (ptrT $ objT cls) <*>
ctorExceptionHandlers) ctor
sayExportClassHsSpecialFns :: SayExportMode -> Class -> Generator ()
sayExportClassHsSpecialFns mode cls = do
typeName <- toHsDataTypeName Nonconst cls
typeNameConst <- toHsDataTypeName Const cls
withErrorContext "generating delete bindings" $
case mode of
SayExportForeignImports -> when (classDtorIsPublic cls) $ do
addImports $ mconcat [hsImportForForeign, hsImportForPrelude]
saysLn ["foreign import ccall \"", classDeleteFnCppName cls, "\" ",
toHsClassDeleteFnName' cls, " :: HoppyF.Ptr ",
typeNameConst, " -> HoppyP.IO ()"]
saysLn ["foreign import ccall \"&", classDeleteFnCppName cls, "\" ",
toHsClassDeleteFnPtrName' cls, " :: HoppyF.FunPtr (HoppyF.Ptr ",
typeNameConst, " -> HoppyP.IO ())"]
SayExportDecls -> return ()
SayExportBoot -> return ()
withErrorContext "generating pointer Assignable instance" $
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 ()
withErrorContext "generating Assignable instance" $ do
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]
valueClassName <- toHsValueClassName cls
assignmentMethodName <- toHsMethodName cls m
ln
saysLn ["instance ", valueClassName, " a => HoppyFHR.Assignable ", typeName, " a where"]
indent $
saysLn ["assign x' y' = ", assignmentMethodName, " x' y' >> HoppyP.return ()"]
withErrorContext "generating pointer Decodable instance" $ do
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 $ do
ctorName <- toHsDataCtorName Unmanaged Nonconst cls
saysLn ["decode = HoppyP.fmap ", ctorName, " . HoppyF.peek"]
SayExportBoot -> do
addImports $ mconcat [hsImportForForeign, hsImportForRuntime]
ln
saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ", typeName]
withErrorContext "generating Encodable/Decodable instances" $ do
let conv = getClassHaskellConversion cls
forM_ (classHaskellConversionType conv) $ \hsTypeGen -> do
let hsTypeStrGen = hsTypeGen >>= \hsType -> return $ "(" ++ prettyPrint hsType ++ ")"
case mode of
SayExportForeignImports -> return ()
SayExportDecls -> do
forM_ (classHaskellConversionToCppFn conv) $ \toCppFnGen -> do
hsTypeStr <- hsTypeStrGen
addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]
castMethodName <- toHsCastMethodName Const cls
ln
saysLn ["instance HoppyFHR.Encodable ", typeName, " ", hsTypeStr, " where"]
indent $ do
sayLn "encode ="
indent toCppFnGen
ln
saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " ", hsTypeStr, " where"]
indent $
saysLn ["encode = HoppyP.fmap (", castMethodName,
") . HoppyFHR.encodeAs (HoppyP.undefined :: ", typeName, ")"]
forM_ (classHaskellConversionFromCppFn conv) $ \fromCppFnGen -> do
hsTypeStr <- hsTypeStrGen
addImports hsImportForRuntime
castMethodName <- toHsCastMethodName Const cls
ln
saysLn ["instance HoppyFHR.Decodable ", typeName, " ", hsTypeStr, " where"]
indent $
saysLn ["decode = HoppyFHR.decode . ", castMethodName]
ln
saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " ", hsTypeStr, " where"]
indent $ do
sayLn "decode ="
indent fromCppFnGen
SayExportBoot -> do
forM_ (classHaskellConversionToCppFn conv) $ \_ -> do
hsTypeStr <- hsTypeStrGen
addImports hsImportForRuntime
ln
saysLn ["instance HoppyFHR.Encodable ", typeName, " (", hsTypeStr, ")"]
saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " (", hsTypeStr, ")"]
forM_ (classHaskellConversionFromCppFn conv) $ \_ -> do
hsTypeStr <- hsTypeStrGen
addImports hsImportForRuntime
ln
saysLn ["instance HoppyFHR.Decodable ", typeName, " (", hsTypeStr, ")"]
saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " (", hsTypeStr, ")"]
sayExportClassExceptionSupport :: Bool -> Class -> Generator ()
sayExportClassExceptionSupport doDecls cls =
when (classIsException cls) $
withErrorContext "generating exception support" $ do
typeName <- toHsDataTypeName Nonconst cls
typeNameConst <- toHsDataTypeName Const cls
exceptionId <- getClassExceptionId cls
addImports hsImportForRuntime
ln
saysLn ["instance HoppyFHR.CppException ", typeName,
if doDecls then " where" else ""]
when doDecls $ indent $ do
ctorName <- toHsDataCtorName Unmanaged Nonconst cls
ctorGcName <- toHsDataCtorName Managed Nonconst cls
addImports $ mconcat [hsImports "Prelude" ["($)", "(.)", "(=<<)"],
hsImportForForeign,
hsImportForMap,
hsImportForPrelude]
sayLn "cppExceptionInfo _ ="
indent $ do
saysLn ["HoppyFHR.ExceptionClassInfo (HoppyFHR.ExceptionId ",
show $ getExceptionId exceptionId, ") ", show typeName,
" upcasts' delete' copy' toGc'"]
saysLn ["where delete' ptr' = ", toHsClassDeleteFnName' cls,
" (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeNameConst, ")"]
indentSpaces 6 $ do
ctorName <- toHsDataCtorName Unmanaged Nonconst cls
ln
saysLn ["copy' = HoppyP.fmap (HoppyF.castPtr . HoppyFHR.toPtr) . HoppyFHR.copy . ",
ctorName, " . HoppyF.castPtr"]
ln
saysLn ["toGc' ptr' = HoppyF.newForeignPtr ",
"(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls,
" :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",
"ptr'"]
sayLn "upcasts' = HoppyDM.fromList"
indent $ case classSuperclasses cls of
[] -> sayLn "[]"
_ -> do
let genCast :: Bool -> [Class] -> Class -> Generator ()
genCast first path ancestorCls =
when (classIsException ancestorCls) $ do
let path' = ancestorCls : path
ancestorId <- getClassExceptionId ancestorCls
ancestorCastChain <- forM (zip path' $ drop 1 path') $ \(to, from) ->
toHsCastPrimitiveName from from to
saysLn $ concat [ [if first then "[" else ",",
" ( HoppyFHR.ExceptionId ",
show $ getExceptionId ancestorId,
", \\(e' :: HoppyF.Ptr ()) -> "]
, intersperse " $ " $
"HoppyF.castPtr" :
ancestorCastChain ++
["HoppyF.castPtr e' :: HoppyF.Ptr ()"]
, [")"]
]
forM_ (classSuperclasses ancestorCls) $ genCast False path'
forM_ (zip (classSuperclasses cls) (True : repeat False)) $
\(ancestorCls, first) -> genCast first [cls] ancestorCls
sayLn "]"
ln
saysLn ["cppExceptionBuild fptr' ptr' = ", ctorGcName,
" fptr' (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"]
ln
saysLn ["cppExceptionBuildToGc ptr' = HoppyFHR.toGc $ ", ctorName,
" (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"]
ln
saysLn ["instance HoppyFHR.CppException ", typeNameConst,
if doDecls then " where" else ""]
when doDecls $ indent $ do
addImports $ mconcat [hsImport1 "Prelude" "(.)",
hsImportForPrelude]
constCastFnName <- toHsConstCastFnName Const cls
saysLn ["cppExceptionInfo _ = HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ",
typeName, ")"]
saysLn ["cppExceptionBuild = (", constCastFnName,
" .) . HoppyFHR.cppExceptionBuild"]
saysLn ["cppExceptionBuildToGc = HoppyP.fmap ", constCastFnName,
" . HoppyFHR.cppExceptionBuildToGc"]
ln
saysLn ["instance HoppyFHR.CppThrowable ", typeName,
if doDecls then " where" else ""]
when doDecls $ indent $ do
ctorName <- toHsDataCtorName Unmanaged Nonconst cls
ctorGcName <- toHsDataCtorName Managed Nonconst cls
addImports $ mconcat [hsImportForForeign,
hsImportForPrelude]
saysLn ["toSomeCppException this'@(", ctorName, " ptr') = HoppyFHR.SomeCppException ",
"(HoppyFHR.cppExceptionInfo this') HoppyP.Nothing (HoppyF.castPtr ptr')"]
saysLn ["toSomeCppException this'@(", ctorGcName, " fptr' ptr') = HoppyFHR.SomeCppException ",
"(HoppyFHR.cppExceptionInfo this') (HoppyP.Just fptr') (HoppyF.castPtr ptr')"]
sayExportClassCastPrimitives :: SayExportMode -> Class -> Generator ()
sayExportClassCastPrimitives mode cls = withErrorContext "generating cast primitives" $ do
clsType <- toHsDataTypeName Const cls
case mode of
SayExportForeignImports ->
forAncestors cls $ \super -> do
hsCastFnName <- toHsCastPrimitiveName cls cls super
hsDownCastFnName <- toHsCastPrimitiveName cls 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 ->
unless (classIsSubclassOfMonomorphic cls) $
forM_ [minBound..] $ \cst -> do
downCastClassName <- toHsDownCastClassName cst cls
downCastMethodName <- toHsDownCastMethodName cst cls
typeName <- toHsDataTypeName cst cls
addExport' downCastClassName
ln
saysLn ["class ", downCastClassName, " a where"]
indent $ saysLn [downCastMethodName, " :: ",
prettyPrint $ HsTyFun (HsTyVar $ HsIdent "a") $
HsTyCon $ UnQual $ HsIdent typeName]
ln
forAncestors cls $ \super -> case classIsMonomorphicSuperclass super of
True -> return False
False -> do
superTypeName <- toHsDataTypeName cst super
primitiveCastFn <- toHsCastPrimitiveName cls super cls
saysLn ["instance ", downCastClassName, " ", superTypeName, " where"]
indent $ do
case cst of
Const -> saysLn [downCastMethodName, " = cast'"]
Nonconst -> do
addImports $ hsImport1 "Prelude" "(.)"
castClsToNonconst <- toHsConstCastFnName Nonconst cls
castSuperToConst <- toHsConstCastFnName Const super
saysLn [downCastMethodName, " = ", castClsToNonconst, " . cast' . ",
castSuperToConst]
indent $ do
sayLn "where"
indent $ do
clsCtorName <- toHsDataCtorName Unmanaged Const cls
clsCtorGcName <- toHsDataCtorName Managed Const cls
superCtorName <- toHsDataCtorName Unmanaged Const super
superCtorGcName <- toHsDataCtorName Managed Const super
saysLn ["cast' (", superCtorName, " ptr') = ",
clsCtorName, " $ ", primitiveCastFn, " ptr'"]
saysLn ["cast' (", superCtorGcName, " fptr' ptr') = ",
clsCtorGcName , " fptr' $ ", primitiveCastFn, " ptr'"]
return True
SayExportBoot -> do
forAncestors cls $ \super -> do
hsCastFnName <- toHsCastPrimitiveName cls 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
sayExceptionSupport :: Bool -> Generator ()
sayExceptionSupport doDecls = do
iface <- askInterface
addExport "exceptionDb'"
addImports hsImportForRuntime
ln
sayLn "exceptionDb' :: HoppyFHR.ExceptionDb"
when doDecls $ do
addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForMap]
sayLn "exceptionDb' = HoppyFHR.ExceptionDb $ HoppyDM.fromList"
indent $ do
let classes = interfaceAllExceptionClasses iface
case classes of
[] -> sayLn "[]"
_ -> do
addImports hsImportForPrelude
forM_ (zip classes (True : repeat False)) $ \(cls, first) -> do
exceptionId <-
fromMaybeM (throwError $ "sayExceptionSupport: Internal error, " ++ show cls ++
" has no exception ID.") $
interfaceExceptionClassId iface cls
typeName <- toHsDataTypeName Nonconst cls
saysLn [if first then "[ (" else ", (",
"HoppyFHR.ExceptionId ", show $ getExceptionId exceptionId,
", HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ",
typeName, "))"]
sayLn "]"
fnToHsTypeAndUse :: HsTypeSide
-> Purity
-> [Type]
-> Type
-> ExceptionHandlers
-> Generator HsQualType
fnToHsTypeAndUse side purity paramTypes returnType exceptionHandlers = do
let catches = not $ null $ exceptionHandlersList exceptionHandlers
params <- mapM contextForParam $
(if catches && side == HsCSide
then (++ [("excId", ptrT intT), ("excPtr", ptrT $ ptrT voidT)])
else id) $
zip (map toArgName [1..]) paramTypes
let context = mapMaybe fst params :: HsContext
hsParams = map snd params
hsReturnInitial <- cppTypeToHsTypeAndUse side returnType
hsReturnForPurity <- case (purity, side) of
(Pure, HsHsSide) -> return hsReturnInitial
_ -> do
addImports hsImportForPrelude
return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsReturnInitial
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
handoff :: HsTypeSide -> Type -> Generator (Maybe HsAsst, HsType)
handoff side t = (,) Nothing <$> cppTypeToHsTypeAndUse side t
receiveBitspace s t b = case side of
HsCSide -> handoff side t
HsHsSide -> do
bitspaceClassName <- toHsBitspaceClassName b
let t' = HsTyVar $ HsIdent s
return (Just (UnQual $ HsIdent bitspaceClassName, [t']),
t')
receivePtr :: String -> Class -> Constness -> Generator (Maybe HsAsst, HsType)
receivePtr s cls cst = case side of
HsHsSide -> do
ptrClassName <- toHsPtrClassName cst cls
let t' = HsTyVar $ HsIdent s
return (Just (UnQual $ HsIdent ptrClassName, [t']),
t')
HsCSide -> do
addImports $ hsImportForForeign
typeName <- toHsDataTypeName cst cls
return (Nothing, HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") $
HsTyVar $ HsIdent typeName)
receiveValue :: String -> Type -> Class -> Generator (Maybe HsAsst, HsType)
receiveValue s t cls = case side of
HsCSide -> handoff side t
HsHsSide -> do
addImports hsImportForRuntime
valueClassName <- toHsValueClassName cls
let t' = HsTyVar $ HsIdent s
return (Just (UnQual $ HsIdent valueClassName, [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
getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers
getEffectiveExceptionHandlers handlers = do
ifaceHandlers <- interfaceExceptionHandlers <$> askInterface
moduleHandlers <- getExceptionHandlers <$> askModule
return $ mconcat [handlers, moduleHandlers, ifaceHandlers]
getEffectiveCallbackThrows :: Callback -> Generator Bool
getEffectiveCallbackThrows cb = case callbackThrows cb of
Just b -> return b
Nothing -> moduleCallbacksThrow <$> askModule >>= \case
Just b -> return b
Nothing -> interfaceCallbacksThrow <$> askInterface
getClassExceptionId :: Class -> Generator ExceptionId
getClassExceptionId cls = do
iface <- askInterface
fromMaybeM (throwError $ concat
["Internal error, exception class ", show cls, " doesn't have an exception ID"]) $
interfaceExceptionClassId iface cls