{-# LANGUAGE ViewPatterns #-}
module Foreign.Hoppy.Generator.Spec.Function (
Function, fnT, fnT',
makeFn,
fnExtName,
fnCName,
fnPurity,
fnParams,
fnReturn,
fnReqs,
fnAddendum,
fnExceptionHandlers,
CallDirection (..),
CppCallType (..),
sayCppArgRead,
sayCppArgNames,
sayCppExportFn,
sayHsExportFn,
sayHsArgProcessing,
sayHsCallAndProcessReturn,
) where
import Control.Monad (forM_, unless, when)
import Control.Monad.Except (throwError)
import Data.Function (on)
import Data.List (intersperse)
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Foreign.Hoppy.Generator.Common (fromMaybeM)
import qualified Foreign.Hoppy.Generator.Language.Cpp as LC
import qualified Foreign.Hoppy.Generator.Language.Haskell as LH
import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Spec.Class as Class
import Foreign.Hoppy.Generator.Spec.Base
import Foreign.Hoppy.Generator.Types (constT, intT, objT, objToHeapT, ptrT, refT, voidT)
import Language.Haskell.Syntax (
HsContext,
HsName (HsIdent),
HsQName (UnQual),
HsQualType (HsQualType),
HsType (HsTyApp, HsTyCon, HsTyFun, HsTyVar),
)
data Function = Function
{ fnCName :: FnName Identifier
, fnExtName :: ExtName
, fnPurity :: Purity
, fnParams :: [Parameter]
, fnReturn :: Type
, fnReqs :: Reqs
, fnExceptionHandlers :: ExceptionHandlers
, fnAddendum :: Addendum
}
instance Eq Function where
(==) = (==) `on` fnExtName
instance Show Function where
show fn =
concat ["<Function ", show (fnExtName fn), " ", show (fnCName fn),
show (fnParams fn), " ", show (fnReturn fn), ">"]
instance Exportable Function where
sayExportCpp = sayCppExport
sayExportHaskell = sayHsExport
instance HasExtNames Function where
getPrimaryExtName = fnExtName
instance HasReqs Function where
getReqs = fnReqs
setReqs reqs fn = fn { fnReqs = reqs }
instance HasAddendum Function where
getAddendum = fnAddendum
setAddendum addendum fn = fn { fnAddendum = addendum }
instance HandlesExceptions Function where
getExceptionHandlers = fnExceptionHandlers
modifyExceptionHandlers f fn = fn { fnExceptionHandlers = f $ fnExceptionHandlers fn }
makeFn :: (IsFnName Identifier name, IsParameter p)
=> name
-> Maybe ExtName
-> Purity
-> [p]
-> Type
-> Function
makeFn cName maybeExtName purity paramTypes retType =
let fnName = toFnName cName
in Function fnName
(extNameOrFnIdentifier fnName maybeExtName)
purity (toParameters paramTypes) retType mempty mempty mempty
fnT :: [Type] -> Type -> Type
fnT = Internal_TFn . map toParameter
fnT' :: [Parameter] -> Type -> Type
fnT' = Internal_TFn
sayCppExport :: LC.SayExportMode -> Function -> LC.Generator ()
sayCppExport mode fn = case mode of
LC.SayHeader -> return ()
LC.SaySource -> do
LC.addReqsM $ fnReqs fn
sayCppExportFn (fnExtName fn)
(case fnCName fn of
FnName identifier -> CallFn $ LC.sayIdentifier identifier
FnOp op -> CallOp op)
Nothing
(fnParams fn)
(fnReturn fn)
(fnExceptionHandlers fn)
True
data CallDirection =
ToCpp
| FromCpp
deriving (Show)
data CppCallType =
CallOp Operator
| CallFn (LC.Generator ())
| VarRead (LC.Generator ())
| VarWrite (LC.Generator ())
sayCppExportFn ::
ExtName
-> CppCallType
-> Maybe Type
-> [Parameter]
-> Type
-> ExceptionHandlers
-> Bool
-> LC.Generator ()
sayCppExportFn extName callType maybeThisType params retType exceptionHandlers sayBody = do
handlerList <- exceptionHandlersList <$> LC.getEffectiveExceptionHandlers exceptionHandlers
let paramTypes = map parameterType params
catches = not $ null handlerList
addExceptionParamNames =
if catches then (++ [LC.exceptionIdArgName, LC.exceptionPtrArgName]) else id
addExceptionParamTypes = if catches then (++ [ptrT intT, ptrT $ ptrT voidT]) else id
paramCount = length paramTypes
paramCTypeMaybes <- mapM LC.typeToCType paramTypes
let paramCTypes = zipWith fromMaybe paramTypes paramCTypeMaybes
retCTypeMaybe <- LC.typeToCType retType
let retCType = fromMaybe retType retCTypeMaybe
LC.addReqsM . mconcat =<< mapM LC.typeReqs (retType:paramTypes)
LC.sayFunction (LC.externalNameToCpp extName)
(maybe id (const ("self":)) maybeThisType $
addExceptionParamNames $
zipWith3 (\pt ctm ->
let hasConversion = case pt of
Internal_TManual s ->
isJust $ conversionSpecCppConversionToCppExpr $
conversionSpecCpp s
_ -> isJust ctm
in if hasConversion then LC.toArgNameAlt else LC.toArgName)
paramTypes
paramCTypeMaybes
[1..paramCount])
(fnT (addExceptionParamTypes $ maybe id (:) maybeThisType paramCTypes)
retCType) $
if not sayBody
then Nothing
else Just $ do
when catches $ do
LC.say "try {\n"
LC.says ["*", LC.exceptionIdArgName, " = 0;\n"]
mapM_ (sayCppArgRead ToCpp) $ zip3 [1..] paramTypes paramCTypeMaybes
let
sayCall = case callType of
CallOp op -> do
LC.say "("
let effectiveParamCount = paramCount + if isJust maybeThisType then 1 else 0
paramNames@(p1:p2:_) = (if isJust maybeThisType then ("(*self)":) else id) $
map LC.toArgName [1..]
assertParamCount n =
when (effectiveParamCount /= n) $ LC.abort $ concat
["sayCppExportFn: Operator ", show op, " for export ", show extName,
" requires ", show n, " parameter(s), but has ", show effectiveParamCount,
"."]
case operatorType op of
UnaryPrefixOperator symbol -> assertParamCount 1 >> LC.says [symbol, p1]
UnaryPostfixOperator symbol -> assertParamCount 1 >> LC.says [p1, symbol]
BinaryOperator symbol -> assertParamCount 2 >> LC.says [p1, symbol, p2]
CallOperator ->
LC.says $ p1 : "(" : take (effectiveParamCount - 1) (drop 1 paramNames) ++ [")"]
ArrayOperator -> assertParamCount 2 >> LC.says [p1, "[", p2, "]"]
LC.say ")"
CallFn sayCppName -> do
when (isJust maybeThisType) $ LC.say "self->"
sayCppName
LC.say "("
sayCppArgNames paramCount
LC.say ")"
VarRead sayVarName -> do
when (isJust maybeThisType) $ LC.say "self->"
sayVarName
VarWrite sayVarName -> do
when (isJust maybeThisType) $ LC.say "self->"
sayVarName
LC.says [" = ", LC.toArgName 1]
sayCallAndReturn retType' retCTypeMaybe' = case (retType', retCTypeMaybe') of
(Internal_TVoid, Nothing) -> sayCall >> LC.say ";\n"
(Internal_TManual s, _) -> do
case conversionSpecCppConversionToCppExpr $ conversionSpecCpp s of
Just convFn -> LC.say "return " >> convFn sayCall Nothing >> LC.say ";\n"
Nothing -> sayCallAndReturnDirect
(_, Nothing) -> sayCallAndReturnDirect
(Internal_TRef cls, Just (Internal_TPtr cls')) | cls == cls' ->
LC.say "return &(" >> sayCall >> LC.say ");\n"
(Internal_TObj cls,
Just (Internal_TPtr (Internal_TConst (Internal_TObj cls')))) | cls == cls' ->
sayReturnNew cls sayCall
(Internal_TObjToHeap cls, Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' ->
sayReturnNew cls sayCall
(Internal_TToGc (Internal_TObj cls),
Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' ->
sayReturnNew cls sayCall
(Internal_TToGc retType'', _) -> sayCallAndReturn retType'' retCTypeMaybe'
ts -> LC.abort $ concat ["sayCppExportFn: Unexpected return types ", show ts,
" while generating binding for ", show extName, "."]
sayCallAndReturnDirect = LC.say "return " >> sayCall >> LC.say ";\n"
sayCallAndReturn retType retCTypeMaybe
when catches $ do
iface <- LC.askInterface
forM_ handlerList $ \handler -> do
LC.say "} catch ("
case handler of
CatchClass cls -> LC.sayVar LC.exceptionVarName Nothing $ refT $ constT $ objT cls
CatchAll -> LC.say "..."
LC.say ") {\n"
exceptionId <- case handler of
CatchClass cls -> case interfaceExceptionClassId iface cls of
Just exceptionId -> return exceptionId
Nothing -> LC.abort $ concat
["sayCppExportFn: Trying to catch non-exception class ", show cls,
" while generating binding for ", show extName, "."]
CatchAll -> return exceptionCatchAllId
LC.says ["*", LC.exceptionIdArgName, " = ", show $ getExceptionId exceptionId, ";\n"]
case handler of
CatchAll -> LC.says ["*", LC.exceptionPtrArgName, " = 0;\n"]
CatchClass cls -> do
LC.says ["*", LC.exceptionPtrArgName, " = reinterpret_cast<void*>(new "]
LC.sayType Nothing $ objT cls
LC.says ["(", LC.exceptionVarName, "));\n"]
when (retType /= Internal_TVoid) $ LC.say "return 0;\n"
LC.say "}\n"
where sayReturnNew cls sayCall =
LC.say "return new" >> LC.sayIdentifier (Class.classIdentifier cls) >> LC.say "(" >>
sayCall >> LC.say ");\n"
sayCppArgRead :: CallDirection -> (Int, Type, Maybe Type) -> LC.Generator ()
sayCppArgRead dir (n, stripConst . normalizeType -> cppType, maybeCType) = case cppType of
t@(Internal_TPtr (Internal_TFn params retType)) -> do
let paramTypes = map parameterType params
check label t' = ((label ++ " " ++ show t') <$) <$> LC.typeToCType t'
mismatches <-
fmap catMaybes $
(:) <$> check "return type" retType
<*> mapM (\paramType -> check "parameter" paramType) paramTypes
unless (null mismatches) $
LC.abort $ concat $
"sayCppArgRead: Some types within a function pointer type use non-C types, " :
"but only C types may be used. The unsupported types are: " :
intersperse "; " mismatches ++ [". The whole function type is ", show t, "."]
convertDefault
Internal_TRef t -> convertObj t
Internal_TObj _ -> convertObj $ constT cppType
Internal_TObjToHeap cls -> case dir of
ToCpp -> error $ objToHeapTWrongDirectionErrorMsg (Just "sayCppArgRead") cls
FromCpp -> do
LC.sayIdentifier $ Class.classIdentifier cls
LC.says ["* ", LC.toArgName n, " = new "]
LC.sayIdentifier $ Class.classIdentifier cls
LC.says ["(", LC.toArgNameAlt n, ");\n"]
Internal_TToGc t' -> case dir of
ToCpp -> error $ toGcTWrongDirectionErrorMsg (Just "sayCppArgRead") t'
FromCpp -> do
let newCppType = case t' of
Internal_TObj cls -> objToHeapT cls
_ -> t'
cType <- LC.typeToCType newCppType
sayCppArgRead dir (n, newCppType, cType)
Internal_TManual s -> do
let maybeConvExpr =
(case dir of
ToCpp -> conversionSpecCppConversionToCppExpr
FromCpp -> conversionSpecCppConversionFromCppExpr) $
conversionSpecCpp s
forM_ maybeConvExpr $ \gen ->
gen (LC.say $ LC.toArgNameAlt n) (Just $ LC.say $ LC.toArgName n)
_ -> convertDefault
where
convertDefault = forM_ maybeCType $ \cType ->
LC.abort $ concat
["sayCppArgRead: Don't know how to convert ", show dir, " between C-type ", show cType,
" and C++-type ", show cppType, "."]
convertObj cppType' = case dir of
ToCpp -> do
LC.sayVar (LC.toArgName n) Nothing $ refT cppType'
LC.says [" = *", LC.toArgNameAlt n, ";\n"]
FromCpp -> do
LC.sayVar (LC.toArgName n) Nothing $ ptrT cppType'
LC.says [" = &", LC.toArgNameAlt n, ";\n"]
sayCppArgNames :: Int -> LC.Generator ()
sayCppArgNames count =
LC.says $ intersperse ", " $ map LC.toArgName [1..count]
sayHsExport :: LH.SayExportMode -> Function -> LH.Generator ()
sayHsExport mode fn =
(sayHsExportFn mode <$> fnExtName <*> fnExtName <*> fnPurity <*>
fnParams <*> fnReturn <*> fnExceptionHandlers) fn
sayHsExportFn ::
LH.SayExportMode
-> ExtName
-> ExtName
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> LH.Generator ()
sayHsExportFn mode extName foreignName purity params retType exceptionHandlers = do
effectiveHandlers <- LH.getEffectiveExceptionHandlers exceptionHandlers
let handlerList = exceptionHandlersList effectiveHandlers
catches = not $ null handlerList
paramTypes = map parameterType params
let hsFnName = LH.toHsFnName' foreignName
hsFnImportedName = hsFnName ++ "'"
case mode of
LH.SayExportForeignImports ->
LH.withErrorContext ("generating imports for function " ++ show extName) $ do
hsCType <- fnToHsTypeAndUse LH.HsCSide purity params retType effectiveHandlers
LH.saysLn ["foreign import ccall \"", LC.externalNameToCpp extName, "\" ", hsFnImportedName,
" :: ", renderFnHsType hsCType]
LH.SayExportDecls -> LH.withErrorContext ("generating function " ++ show extName) $ do
LH.ln
LH.addExport hsFnName
hsHsType <- fnToHsTypeAndUse LH.HsHsSide purity params retType effectiveHandlers
LH.saysLn [hsFnName, " :: ", renderFnHsTypeWithNames hsHsType]
case purity of
Nonpure -> return ()
Pure -> LH.saysLn ["{-# NOINLINE ", hsFnName, " #-}"]
let argNames = map LH.toArgName [1..length paramTypes]
convertedArgNames = map (++ "'") argNames
lineEnd <- case purity of
Nonpure -> return [" ="]
Pure -> do LH.addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForUnsafeIO]
return [" = HoppySIU.unsafePerformIO $"]
LH.saysLn $ hsFnName : map (' ':) argNames ++ lineEnd
LH.indent $ do
forM_ (zip3 paramTypes argNames convertedArgNames) $ \(t, argName, argName') ->
sayHsArgProcessing ToCpp t argName argName'
exceptionHandling <-
if catches
then do iface <- LH.askInterface
currentModule <- LH.askModule
let exceptionSupportModule = interfaceExceptionSupportModule iface
when (exceptionSupportModule /= Just currentModule) $
LH.addImports . hsWholeModuleImport . LH.getModuleName iface =<<
fromMaybeM (throwError
"Internal error, an exception support module is not available")
exceptionSupportModule
LH.addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForRuntime]
return "HoppyFHR.internalHandleExceptions exceptionDb' $"
else return ""
let callWords = exceptionHandling : hsFnImportedName : map (' ':) convertedArgNames
sayHsCallAndProcessReturn ToCpp retType callWords
LH.SayExportBoot ->
return ()
sayHsArgProcessing ::
CallDirection
-> Type
-> String
-> String
-> LH.Generator ()
sayHsArgProcessing dir t fromVar toVar =
LH.withErrorContext ("processing argument of type " ++ show t) $
case t of
Internal_TVoid -> throwError $ "TVoid is not a valid argument type"
Internal_TPtr (Internal_TObj cls) -> case dir of
ToCpp -> do
LH.addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForRuntime]
castMethodName <- Class.toHsCastMethodName Nonconst cls
LH.saysLn ["HoppyFHR.withCppPtr (", castMethodName, " ", fromVar,
") $ \\", toVar, " ->"]
FromCpp -> do
ctorName <- Class.toHsDataCtorName LH.Unmanaged Nonconst cls
LH.saysLn ["let ", toVar, " = ", ctorName, " ", fromVar, " in"]
Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of
ToCpp -> do
LH.addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForPrelude,
hsImportForRuntime]
withValuePtrName <- Class.toHsWithValuePtrName cls
LH.saysLn [withValuePtrName, " ", fromVar,
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"]
FromCpp -> do
ctorName <- Class.toHsDataCtorName LH.Unmanaged Const cls
LH.saysLn ["let ", toVar, " = ", ctorName, " ", fromVar, " in"]
Internal_TPtr _ -> noConversion
Internal_TRef t' -> sayHsArgProcessing dir (ptrT t') fromVar toVar
Internal_TFn {} -> throwError "TFn unimplemented"
Internal_TObj cls -> case dir of
ToCpp -> do
LH.addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForPrelude,
hsImportForRuntime]
withValuePtrName <- Class.toHsWithValuePtrName cls
LH.saysLn [withValuePtrName, " ", fromVar,
" $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"]
FromCpp -> case Class.classHaskellConversionFromCppFn $ LH.getClassHaskellConversion cls of
Just _ -> do
LH.addImports $ mconcat [hsImport1 "Prelude" "(>>=)",
hsImportForRuntime]
ctorName <- Class.toHsDataCtorName LH.Unmanaged Const cls
LH.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 -> sayHsArgProcessing dir (ptrT $ objT cls) fromVar toVar
Internal_TToGc t' -> case dir of
ToCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t'
FromCpp -> do
LH.addImports $ mconcat [hsImport1 "Prelude" "(>>=)",
hsImportForRuntime]
ctorName <-
maybe (throwError $ tToGcInvalidFormErrorMessage Nothing t')
(Class.toHsDataCtorName LH.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
LH.saysLn ["HoppyFHR.toGc (", ctorName, " ", fromVar, ") >>= \\", toVar, " ->"]
Internal_TConst t' -> sayHsArgProcessing dir t' fromVar toVar
Internal_TManual s -> do
let maybeGen =
fmap (case dir of
ToCpp -> conversionSpecHaskellToCppFn
FromCpp -> conversionSpecHaskellFromCppFn) $
conversionSpecHaskell s
throwForNoConversion =
throwError $ concat
["No conversion defined for ", show s,
case dir of
ToCpp -> " to C++ from Haskell"
FromCpp -> " from C++ to Haskell"]
case maybeGen of
Just (CustomConversion gen) -> do
LH.addImports $ hsImport1 "Prelude" "(>>=)"
LH.sayLn "("
LH.indent gen
LH.saysLn [") ", fromVar, " >>= \\", toVar, " ->"]
Just BinaryCompatible -> LH.saysLn ["let ", toVar, " = ", fromVar, " in"]
Just ConversionUnsupported -> throwForNoConversion
Nothing -> throwForNoConversion
where noConversion = LH.saysLn ["let ", toVar, " = ", fromVar, " in"]
sayHsCallAndProcessReturn :: CallDirection -> Type -> [String] -> LH.Generator ()
sayHsCallAndProcessReturn dir t callWords =
LH.withErrorContext ("processing return value of type " ++ show t) $
case t of
Internal_TVoid -> sayCall
Internal_TPtr (Internal_TObj cls) -> do
case dir of
ToCpp -> do
LH.addImports hsImportForPrelude
ctorName <- Class.toHsDataCtorName LH.Unmanaged Nonconst cls
LH.saysLn ["HoppyP.fmap ", ctorName]
sayCall
FromCpp -> do
LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]
LH.sayLn "HoppyP.fmap HoppyFHR.toPtr"
sayCall
Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of
ToCpp -> do
LH.addImports hsImportForPrelude
ctorName <- Class.toHsDataCtorName LH.Unmanaged Const cls
LH.saysLn ["HoppyP.fmap ", ctorName]
sayCall
FromCpp -> do
LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]
LH.sayLn "HoppyP.fmap HoppyFHR.toPtr"
sayCall
Internal_TPtr _ -> sayCall
Internal_TRef t' -> sayHsCallAndProcessReturn dir (ptrT t') callWords
Internal_TFn {} -> throwError "TFn unimplemented"
Internal_TObj cls -> case dir of
ToCpp -> case Class.classHaskellConversionFromCppFn $ LH.getClassHaskellConversion cls of
Just _ -> do
LH.addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"],
hsImportForRuntime]
ctorName <- Class.toHsDataCtorName LH.Unmanaged Const cls
LH.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
LH.addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"],
hsImportForPrelude,
hsImportForRuntime]
LH.sayLn "(HoppyP.fmap (HoppyFHR.toPtr) . HoppyFHR.encode) =<<"
sayCall
Internal_TObjToHeap cls -> case dir of
ToCpp -> sayHsCallAndProcessReturn dir (ptrT $ objT cls) callWords
FromCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls
Internal_TToGc t' -> case dir of
ToCpp -> do
LH.addImports $ mconcat [hsImport1 "Prelude" "(=<<)",
hsImportForRuntime]
LH.sayLn "HoppyFHR.toGc =<<"
case t' of
Internal_TObj _ -> sayHsCallAndProcessReturn dir (ptrT t') callWords
_ -> sayHsCallAndProcessReturn dir t' callWords
FromCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t'
Internal_TConst t' -> sayHsCallAndProcessReturn dir t' callWords
Internal_TManual s -> do
let maybeGen =
fmap (case dir of
ToCpp -> conversionSpecHaskellFromCppFn
FromCpp -> conversionSpecHaskellToCppFn) $
conversionSpecHaskell s
throwForNoConversion =
throwError $ concat
["No conversion defined for ", show s,
case dir of
ToCpp -> " from C++ to Haskell"
FromCpp -> " to C++ from Haskell"]
case maybeGen of
Just (CustomConversion gen) -> do
LH.addImports $ hsImport1 "Prelude" "(=<<)"
LH.sayLn "("
LH.indent gen
LH.sayLn ") =<<"
Just BinaryCompatible -> return ()
Just ConversionUnsupported -> throwForNoConversion
Nothing -> throwForNoConversion
sayCall
where sayCall = LH.saysLn $ "(" : callWords ++ [")"]
data FnHsType = FnHsType
{ fnHsQualType :: HsQualType
, fnHsParamNameMaybes :: [Maybe String]
}
fnToHsTypeAndUse ::
LH.HsTypeSide
-> Purity
-> [Parameter]
-> Type
-> ExceptionHandlers
-> LH.Generator FnHsType
fnToHsTypeAndUse side purity params returnType exceptionHandlers = do
let catches = not $ null $ exceptionHandlersList exceptionHandlers
getsExcParams = catches && side == LH.HsCSide
paramTypes =
(if getsExcParams then (++ [ptrT intT, ptrT $ ptrT voidT]) else id) $
map parameterType params
paramNameMaybes =
(if getsExcParams then (++ [Just "excId", Just "excPtr"]) else id) $
map parameterName params
defaultParamNames = map LH.toArgName [1..]
defaultedParamNames = zipWith fromMaybe defaultParamNames paramNameMaybes
paramQualTypes <- mapM contextForParam $ zip defaultedParamNames paramTypes
let context = concatMap (\(HsQualType ctx _) -> ctx) paramQualTypes :: HsContext
hsParams = map (\(HsQualType _ t) -> t) paramQualTypes
hsReturnInitial <- LH.cppTypeToHsTypeAndUse side returnType
hsReturnForPurity <- case (purity, side) of
(Pure, LH.HsHsSide) -> return hsReturnInitial
_ -> do
LH.addImports hsImportForPrelude
return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsReturnInitial
return FnHsType
{ fnHsQualType = HsQualType context $ foldr HsTyFun hsReturnForPurity hsParams
, fnHsParamNameMaybes = paramNameMaybes
}
where contextForParam :: (String, Type) -> LH.Generator HsQualType
contextForParam (s, t) = case t of
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_TManual spec ->
case (side, conversionSpecHaskell spec >>= conversionSpecHaskellHsArgType) of
(LH.HsHsSide, Just f) -> f $ HsIdent s
_ -> handoff side t
Internal_TConst t' -> contextForParam (s, t')
_ -> handoff side t
handoff :: LH.HsTypeSide -> Type -> LH.Generator HsQualType
handoff side' t = HsQualType [] <$> LH.cppTypeToHsTypeAndUse side' t
receivePtr :: String -> Class.Class -> Constness -> LH.Generator HsQualType
receivePtr s cls cst = case side of
LH.HsHsSide -> do
ptrClassName <- Class.toHsPtrClassName cst cls
let t' = HsTyVar $ HsIdent s
return $ HsQualType [(UnQual $ HsIdent ptrClassName, [t'])] t'
LH.HsCSide -> do
LH.addImports hsImportForForeign
typeName <- Class.toHsDataTypeName cst cls
return $
HsQualType [] $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr")
(HsTyVar $ HsIdent typeName)
receiveValue :: String -> Type -> Class.Class -> LH.Generator HsQualType
receiveValue s t cls = case side of
LH.HsCSide -> handoff side t
LH.HsHsSide -> do
LH.addImports hsImportForRuntime
valueClassName <- Class.toHsValueClassName cls
let t' = HsTyVar $ HsIdent s
return $ HsQualType [(UnQual $ HsIdent valueClassName, [t'])] t'
renderFnHsType :: FnHsType -> String
renderFnHsType = LH.prettyPrint . fnHsQualType
renderFnHsTypeWithNames :: FnHsType -> String
renderFnHsTypeWithNames fnHsType =
concat $ renderedContextStrs ++ renderedParamStrs
where HsQualType assts unqualType = fnHsQualType fnHsType
paramNameMaybes = fnHsParamNameMaybes fnHsType
renderedContextStrs :: [String]
renderedContextStrs =
if null assts
then []
else "(" : intersperse ", " (map renderAsst assts) ++ [") => "]
renderAsst :: (HsQName, [HsType]) -> String
renderAsst asst = case asst of
(UnQual (HsIdent typeclass), [HsTyVar (HsIdent typeVar)]) ->
concat [typeclass, " ", typeVar]
_ -> error $ "renderAsst: Unexpected argument: " ++ show asst
renderedParamStrs :: [String]
renderedParamStrs = renderParams unqualType paramNameMaybes
renderParams :: HsType -> [Maybe String] -> [String]
renderParams fnType' paramNameMaybes' = case (fnType', paramNameMaybes') of
(HsTyFun a b, (Just name):restNames) ->
"(" : LH.prettyPrint a : ") {- ^ " : name : " -} -> " : renderParams b restNames
(HsTyFun a b, Nothing:restNames) ->
"(" : LH.prettyPrint a : ") -> " : renderParams b restNames
_ -> "(" : LH.prettyPrint fnType' : [")"]