module Foreign.Hoppy.Generator.Spec.Base (
Interface,
ErrorMsg,
InterfaceOptions (..),
defaultInterfaceOptions,
interface,
interface',
interfaceName,
interfaceModules,
interfaceNamesToModules,
interfaceHaskellModuleBase,
interfaceDefaultHaskellModuleBase,
interfaceAddHaskellModuleBase,
interfaceHaskellModuleImportNames,
interfaceExceptionHandlers,
interfaceCallbacksThrow,
interfaceSetCallbacksThrow,
interfaceExceptionClassId,
interfaceExceptionSupportModule,
interfaceSetExceptionSupportModule,
Include,
includeStd,
includeLocal,
includeToString,
Module,
moduleName,
moduleHppPath,
moduleCppPath,
moduleExports,
moduleReqs,
moduleExceptionHandlers,
moduleCallbacksThrow,
moduleSetCallbacksThrow,
moduleAddendum,
moduleHaskellName,
makeModule,
moduleModify,
moduleModify',
moduleSetHppPath,
moduleSetCppPath,
moduleAddExports,
moduleAddHaskellName,
Reqs,
reqsIncludes,
reqInclude,
HasReqs (..),
addReqs,
addReqIncludes,
ExtName,
toExtName,
isValidExtName,
fromExtName,
HasExtNames (..),
getAllExtNames,
FnName (..),
IsFnName (..),
Operator (..),
OperatorType (..),
operatorPreferredExtName,
operatorPreferredExtName',
operatorType,
Export (..),
exportAddendum,
Identifier,
identifierParts,
IdPart,
idPartBase,
idPartArgs,
ident, ident', ident1, ident2, ident3, ident4, ident5,
identT, identT', ident1T, ident2T, ident3T, ident4T, ident5T,
Type (..),
normalizeType,
stripConst,
Variable, makeVariable, varIdentifier, varExtName, varType, varReqs,
varIsConst, varGetterExtName, varSetterExtName,
CppEnum, makeEnum, enumIdentifier, enumExtName, enumValueNames, enumReqs,
enumValuePrefix, enumSetValuePrefix,
Bitspace, makeBitspace, bitspaceExtName, bitspaceType, bitspaceValueNames, bitspaceEnum,
bitspaceAddEnum, bitspaceCppTypeIdentifier, bitspaceFromCppValueFn, bitspaceToCppValueFn,
bitspaceAddCppType, bitspaceReqs,
bitspaceValuePrefix, bitspaceSetValuePrefix,
Purity (..),
Function, makeFn, fnCName, fnExtName, fnPurity, fnParams, fnReturn, fnReqs, fnExceptionHandlers,
Class, makeClass, classIdentifier, classExtName, classSuperclasses,
classEntities, classAddEntities, classVariables, classCtors, classMethods,
classDtorIsPublic, classSetDtorPrivate,
classConversion, classReqs, classEntityPrefix, classSetEntityPrefix,
classIsMonomorphicSuperclass, classSetMonomorphicSuperclass,
classIsSubclassOfMonomorphic, classSetSubclassOfMonomorphic,
classIsException, classMakeException,
ClassEntity (..),
IsClassEntity (..), classEntityExtName, classEntityForeignName, classEntityForeignName',
ClassVariable,
makeClassVariable, makeClassVariable_,
mkClassVariable, mkClassVariable_,
mkStaticClassVariable, mkStaticClassVariable_,
classVarCName, classVarExtName, classVarType, classVarStatic, classVarGettable,
classVarGetterExtName, classVarGetterForeignName,
classVarSetterExtName, classVarSetterForeignName,
Ctor, makeCtor, makeCtor_, mkCtor, mkCtor_, ctorExtName, ctorParams, ctorExceptionHandlers,
Method,
MethodImpl (..),
MethodApplicability (..),
Constness (..),
constNegate,
Staticness (..),
makeMethod, makeMethod_,
makeFnMethod, makeFnMethod_,
mkMethod, mkMethod_, mkMethod', mkMethod'_,
mkConstMethod, mkConstMethod_, mkConstMethod', mkConstMethod'_,
mkStaticMethod, mkStaticMethod_, mkStaticMethod', mkStaticMethod'_,
Prop,
mkProp, mkProp_,
mkStaticProp, mkStaticProp_,
mkBoolIsProp, mkBoolIsProp_,
mkBoolHasProp, mkBoolHasProp_,
methodImpl, methodExtName, methodApplicability, methodPurity, methodParams,
methodReturn, methodExceptionHandlers, methodConst, methodStatic,
ClassConversion (..),
classConversionNone,
classModifyConversion,
classSetConversion,
ClassHaskellConversion (..),
classHaskellConversionNone,
classSetHaskellConversion,
Callback, makeCallback,
callbackExtName, callbackParams, callbackReturn, callbackThrows, callbackReqs,
callbackSetThrows,
ExceptionId (..),
exceptionCatchAllId,
ExceptionHandler (..),
ExceptionHandlers (..),
HandlesExceptions (getExceptionHandlers),
handleExceptions,
Addendum (..),
HasAddendum (..),
addAddendumHaskell,
HsModuleName, HsImportSet, HsImportKey (..), HsImportSpecs (..), HsImportName, HsImportVal (..),
hsWholeModuleImport, hsQualifiedImport, hsImport1, hsImport1', hsImports, hsImports',
hsImportSetMakeSource,
interfaceAllExceptionClasses,
classFindCopyCtor,
makeHsImportSet,
getHsImportSet,
hsImportForBits,
hsImportForException,
hsImportForInt,
hsImportForWord,
hsImportForForeign,
hsImportForForeignC,
hsImportForMap,
hsImportForPrelude,
hsImportForRuntime,
hsImportForSystemPosixTypes,
hsImportForTypeable,
hsImportForUnsafeIO,
objToHeapTWrongDirectionErrorMsg,
tToGcInvalidFormErrorMessage,
toGcTWrongDirectionErrorMsg,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Arrow ((&&&))
import Control.Monad (liftM2, unless)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except (MonadError, throwError)
#else
import Control.Monad.Error (MonadError, throwError)
#endif
import Control.Monad.State (MonadState, StateT, execStateT, get, modify)
import Data.Char (isAlpha, isAlphaNum, toUpper)
import Data.Function (on)
import Data.List (intercalate, intersperse)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid, mappend, mconcat, mempty)
#endif
import qualified Data.Set as S
import Foreign.Hoppy.Generator.Common
import qualified Foreign.Hoppy.Generator.Language.Haskell as Haskell
import Language.Haskell.Syntax (HsType)
type ErrorMsg = String
data Interface = Interface
{ interfaceName :: String
, interfaceModules :: M.Map String Module
, interfaceNamesToModules :: M.Map ExtName Module
, interfaceHaskellModuleBase' :: Maybe [String]
, interfaceHaskellModuleImportNames :: M.Map Module String
, interfaceExceptionHandlers :: ExceptionHandlers
, interfaceCallbacksThrow :: Bool
, interfaceExceptionNamesToIds :: M.Map ExtName ExceptionId
, interfaceExceptionSupportModule :: Maybe Module
}
instance Show Interface where
show iface = concat ["<Interface ", show (interfaceName iface), ">"]
data InterfaceOptions = InterfaceOptions
{ interfaceOptionsExceptionHandlers :: ExceptionHandlers
}
defaultInterfaceOptions :: InterfaceOptions
defaultInterfaceOptions = InterfaceOptions mempty
interface :: String
-> [Module]
-> Either ErrorMsg Interface
interface ifName modules = interface' ifName modules defaultInterfaceOptions
interface' :: String
-> [Module]
-> InterfaceOptions
-> Either ErrorMsg Interface
interface' ifName modules options = do
let extNamesToModules :: M.Map ExtName [Module]
extNamesToModules =
M.unionsWith (++) $
for modules $ \mod ->
let extNames = concatMap getAllExtNames $ M.elems $ moduleExports mod
in M.fromList $ zip extNames $ repeat [mod]
extNamesInMultipleModules :: [(ExtName, [Module])]
extNamesInMultipleModules =
M.toList $
M.filter (\modules -> case modules of
_:_:_ -> True
_ -> False)
extNamesToModules
unless (null extNamesInMultipleModules) $
Left $ unlines $
"Some external name(s) are exported by multiple modules:" :
map (\(extName, modules) ->
concat $ "- " : show extName : ": " : intersperse ", " (map show modules))
extNamesInMultipleModules
let haskellModuleImportNames =
M.fromList $
(\a b f -> zipWith f a b) modules [1..] $
\mod index -> (mod, 'M' : show index)
let exceptionNamesToIds =
M.fromList $
zip (map classExtName $ interfaceAllExceptionClasses' modules)
(map ExceptionId [exceptionFirstFreeId..])
return Interface
{ interfaceName = ifName
, interfaceModules = M.fromList $ map (moduleName &&& id) modules
, interfaceNamesToModules = M.map (\[x] -> x) extNamesToModules
, interfaceHaskellModuleBase' = Nothing
, interfaceHaskellModuleImportNames = haskellModuleImportNames
, interfaceExceptionHandlers = interfaceOptionsExceptionHandlers options
, interfaceCallbacksThrow = False
, interfaceExceptionNamesToIds = exceptionNamesToIds
, interfaceExceptionSupportModule = Nothing
}
interfaceHaskellModuleBase :: Interface -> [String]
interfaceHaskellModuleBase =
fromMaybe interfaceDefaultHaskellModuleBase . interfaceHaskellModuleBase'
interfaceDefaultHaskellModuleBase :: [String]
interfaceDefaultHaskellModuleBase = ["Foreign", "Hoppy", "Generated"]
interfaceAddHaskellModuleBase :: [String] -> Interface -> Either String Interface
interfaceAddHaskellModuleBase modulePath iface = case interfaceHaskellModuleBase' iface of
Nothing -> Right iface { interfaceHaskellModuleBase' = Just modulePath }
Just existingPath ->
Left $ concat
[ "addInterfaceHaskellModuleBase: Trying to add Haskell module base "
, intercalate "." modulePath, " to ", show iface
, " which already has a module base ", intercalate "." existingPath
]
interfaceExceptionClassId :: Interface -> Class -> Maybe ExceptionId
interfaceExceptionClassId iface cls =
M.lookup (classExtName cls) $ interfaceExceptionNamesToIds iface
interfaceAllExceptionClasses :: Interface -> [Class]
interfaceAllExceptionClasses = interfaceAllExceptionClasses' . M.elems . interfaceModules
interfaceAllExceptionClasses' :: [Module] -> [Class]
interfaceAllExceptionClasses' modules =
flip concatMap modules $ \mod ->
catMaybes $
for (M.elems $ moduleExports mod) $ \export -> case export of
ExportClass cls | classIsException cls -> Just cls
_ -> Nothing
interfaceSetCallbacksThrow :: Bool -> Interface -> Interface
interfaceSetCallbacksThrow b iface = iface { interfaceCallbacksThrow = b }
interfaceSetExceptionSupportModule :: Module -> Interface -> Interface
interfaceSetExceptionSupportModule mod iface = case interfaceExceptionSupportModule iface of
Nothing -> iface { interfaceExceptionSupportModule = Just mod }
Just existingMod ->
if mod == existingMod
then iface
else error $ "interfaceSetExceptionSupportModule: " ++ show iface ++
" already has exception support module " ++ show existingMod ++
", trying to set " ++ show mod ++ "."
data Include = Include
{ includeToString :: String
} deriving (Eq, Ord, Show)
includeStd :: String -> Include
includeStd path = Include $ "#include <" ++ path ++ ">\n"
includeLocal :: String -> Include
includeLocal path = Include $ "#include \"" ++ path ++ "\"\n"
data Module = Module
{ moduleName :: String
, moduleHppPath :: String
, moduleCppPath :: String
, moduleExports :: M.Map ExtName Export
, moduleReqs :: Reqs
, moduleHaskellName :: Maybe [String]
, moduleExceptionHandlers :: ExceptionHandlers
, moduleCallbacksThrow :: Maybe Bool
, moduleAddendum :: Addendum
}
instance Eq Module where
(==) = (==) `on` moduleName
instance Ord Module where
compare = compare `on` moduleName
instance Show Module where
show m = concat ["<Module ", moduleName m, ">"]
instance HasReqs Module where
getReqs = moduleReqs
setReqs reqs m = m { moduleReqs = reqs }
instance HasAddendum Module where
getAddendum = moduleAddendum
setAddendum addendum m = m { moduleAddendum = addendum }
instance HandlesExceptions Module where
getExceptionHandlers = moduleExceptionHandlers
modifyExceptionHandlers f m = m { moduleExceptionHandlers = f $ moduleExceptionHandlers m }
makeModule :: String
-> String
-> String
-> Module
makeModule name hppPath cppPath = Module
{ moduleName = name
, moduleHppPath = hppPath
, moduleCppPath = cppPath
, moduleExports = M.empty
, moduleReqs = mempty
, moduleHaskellName = Nothing
, moduleExceptionHandlers = mempty
, moduleCallbacksThrow = Nothing
, moduleAddendum = mempty
}
moduleModify :: Module -> StateT Module (Either String) () -> Either ErrorMsg Module
moduleModify = flip execStateT
moduleModify' :: Module -> StateT Module (Either String) () -> Module
moduleModify' m action = case moduleModify m action of
Left errorMsg ->
error $ concat
["moduleModify' failed to modify ", show m, ": ", errorMsg]
Right m' -> m'
moduleSetHppPath :: MonadState Module m => String -> m ()
moduleSetHppPath path = modify $ \m -> m { moduleHppPath = path }
moduleSetCppPath :: MonadState Module m => String -> m ()
moduleSetCppPath path = modify $ \m -> m { moduleCppPath = path }
moduleAddExports :: (MonadError String m, MonadState Module m) => [Export] -> m ()
moduleAddExports exports = do
m <- get
let existingExports = moduleExports m
newExports = M.fromList $ map (getPrimaryExtName &&& id) exports
duplicateNames = (S.intersection `on` M.keysSet) existingExports newExports
if S.null duplicateNames
then modify $ \m -> m { moduleExports = existingExports `mappend` newExports }
else throwError $ concat
["moduleAddExports: ", show m, " defines external names multiple times: ",
show duplicateNames]
moduleAddHaskellName :: (MonadError String m, MonadState Module m) => [String] -> m ()
moduleAddHaskellName name = do
m <- get
case moduleHaskellName m of
Nothing -> modify $ \m -> m { moduleHaskellName = Just name }
Just name' ->
throwError $ concat
["moduleAddHaskellName: ", show m, " already has Haskell name ",
show name', "; trying to add name ", show name, "."]
moduleSetCallbacksThrow :: MonadState Module m => Maybe Bool -> m ()
moduleSetCallbacksThrow b = modify $ \m -> m { moduleCallbacksThrow = b }
data Reqs = Reqs
{ reqsIncludes :: S.Set Include
} deriving (Show)
instance Monoid Reqs where
mempty = Reqs mempty
mappend (Reqs incl) (Reqs incl') = Reqs $ mappend incl incl'
mconcat reqs = Reqs $ mconcat $ map reqsIncludes reqs
reqInclude :: Include -> Reqs
reqInclude include = mempty { reqsIncludes = S.singleton include }
class HasReqs a where
getReqs :: a -> Reqs
setReqs :: Reqs -> a -> a
setReqs = modifyReqs . const
modifyReqs :: (Reqs -> Reqs) -> a -> a
modifyReqs f x = setReqs (f $ getReqs x) x
addReqs :: HasReqs a => Reqs -> a -> a
addReqs reqs = modifyReqs $ mappend reqs
addReqIncludes :: HasReqs a => [Include] -> a -> a
addReqIncludes includes =
modifyReqs $ mappend mempty { reqsIncludes = S.fromList includes }
newtype ExtName = ExtName
{ fromExtName :: String
} deriving (Eq, Monoid, Ord)
instance Show ExtName where
show extName = concat ["$\"", fromExtName extName, "\"$"]
toExtName :: String -> ExtName
toExtName str = case str of
[] -> error "An ExtName cannot be empty."
_ -> if isValidExtName str
then ExtName str
else error $
"An ExtName must start with a letter and only contain letters, numbers, and '_': " ++
show str
isValidExtName :: String -> Bool
isValidExtName str = case str of
[] -> False
c:cs -> isAlpha c && all ((||) <$> isAlphaNum <*> (== '_')) cs
extNameOrIdentifier :: Identifier -> Maybe ExtName -> ExtName
extNameOrIdentifier ident = fromMaybe $ case identifierParts ident of
[] -> error "extNameOrIdentifier: Invalid empty identifier."
parts -> toExtName $ idPartBase $ last parts
extNameOrFnIdentifier :: FnName Identifier -> Maybe ExtName -> ExtName
extNameOrFnIdentifier name =
fromMaybe $ case name of
FnName identifier -> case identifierParts identifier of
[] -> error "extNameOrFnIdentifier: Empty idenfitier."
parts -> toExtName $ idPartBase $ last parts
FnOp op -> operatorPreferredExtName op
extNameOrString :: String -> Maybe ExtName -> ExtName
extNameOrString str = fromMaybe $ toExtName str
class HasExtNames a where
getPrimaryExtName :: a -> ExtName
getNestedExtNames :: a -> [ExtName]
getNestedExtNames _ = []
getAllExtNames :: HasExtNames a => a -> [ExtName]
getAllExtNames x = getPrimaryExtName x : getNestedExtNames x
data FnName name =
FnName name
| FnOp Operator
deriving (Eq, Ord)
instance Show name => Show (FnName name) where
show (FnName name) = concat ["<FnName ", show name, ">"]
show (FnOp op) = concat ["<FnOp ", show op, ">"]
class IsFnName t a where
toFnName :: a -> FnName t
instance IsFnName t (FnName t) where
toFnName = id
instance IsFnName t t where
toFnName = FnName
instance IsFnName t Operator where
toFnName = FnOp
data Operator =
OpCall
| OpComma
| OpAssign
| OpArray
| OpDeref
| OpAddress
| OpAdd
| OpAddAssign
| OpSubtract
| OpSubtractAssign
| OpMultiply
| OpMultiplyAssign
| OpDivide
| OpDivideAssign
| OpModulo
| OpModuloAssign
| OpPlus
| OpMinus
| OpIncPre
| OpIncPost
| OpDecPre
| OpDecPost
| OpEq
| OpNe
| OpLt
| OpLe
| OpGt
| OpGe
| OpNot
| OpAnd
| OpOr
| OpBitNot
| OpBitAnd
| OpBitAndAssign
| OpBitOr
| OpBitOrAssign
| OpBitXor
| OpBitXorAssign
| OpShl
| OpShlAssign
| OpShr
| OpShrAssign
deriving (Bounded, Enum, Eq, Ord, Show)
data OperatorType =
UnaryPrefixOperator String
| UnaryPostfixOperator String
| BinaryOperator String
| CallOperator
| ArrayOperator
data OperatorInfo = OperatorInfo
{ operatorPreferredExtName'' :: ExtName
, operatorType' :: OperatorType
}
makeOperatorInfo :: String -> OperatorType -> OperatorInfo
makeOperatorInfo = OperatorInfo . toExtName
operatorPreferredExtName :: Operator -> ExtName
operatorPreferredExtName op = case M.lookup op operatorInfo of
Just info -> operatorPreferredExtName'' info
Nothing ->
error $ concat
["operatorPreferredExtName: Internal error, missing info for operator ", show op, "."]
operatorPreferredExtName' :: Operator -> String
operatorPreferredExtName' = fromExtName . operatorPreferredExtName
operatorType :: Operator -> OperatorType
operatorType op = case M.lookup op operatorInfo of
Just info -> operatorType' info
Nothing ->
error $ concat
["operatorType: Internal error, missing info for operator ", show op, "."]
operatorInfo :: M.Map Operator OperatorInfo
operatorInfo =
let input =
[ (OpCall, makeOperatorInfo "CALL" CallOperator)
, (OpComma, makeOperatorInfo "COMMA" $ BinaryOperator ",")
, (OpAssign, makeOperatorInfo "ASSIGN" $ BinaryOperator "=")
, (OpArray, makeOperatorInfo "ARRAY" ArrayOperator)
, (OpDeref, makeOperatorInfo "DEREF" $ UnaryPrefixOperator "*")
, (OpAddress, makeOperatorInfo "ADDRESS" $ UnaryPrefixOperator "&")
, (OpAdd, makeOperatorInfo "ADD" $ BinaryOperator "+")
, (OpAddAssign, makeOperatorInfo "ADDA" $ BinaryOperator "+=")
, (OpSubtract, makeOperatorInfo "SUB" $ BinaryOperator "-")
, (OpSubtractAssign, makeOperatorInfo "SUBA" $ BinaryOperator "-=")
, (OpMultiply, makeOperatorInfo "MUL" $ BinaryOperator "*")
, (OpMultiplyAssign, makeOperatorInfo "MULA" $ BinaryOperator "*=")
, (OpDivide, makeOperatorInfo "DIV" $ BinaryOperator "/")
, (OpDivideAssign, makeOperatorInfo "DIVA" $ BinaryOperator "/=")
, (OpModulo, makeOperatorInfo "MOD" $ BinaryOperator "%")
, (OpModuloAssign, makeOperatorInfo "MODA" $ BinaryOperator "%=")
, (OpPlus, makeOperatorInfo "PLUS" $ UnaryPrefixOperator "+")
, (OpMinus, makeOperatorInfo "NEG" $ UnaryPrefixOperator "-")
, (OpIncPre, makeOperatorInfo "INC" $ UnaryPrefixOperator "++")
, (OpIncPost, makeOperatorInfo "INCPOST" $ UnaryPostfixOperator "++")
, (OpDecPre, makeOperatorInfo "DEC" $ UnaryPrefixOperator "--")
, (OpDecPost, makeOperatorInfo "DECPOST" $ UnaryPostfixOperator "--")
, (OpEq, makeOperatorInfo "EQ" $ BinaryOperator "==")
, (OpNe, makeOperatorInfo "NE" $ BinaryOperator "!=")
, (OpLt, makeOperatorInfo "LT" $ BinaryOperator "<")
, (OpLe, makeOperatorInfo "LE" $ BinaryOperator "<=")
, (OpGt, makeOperatorInfo "GT" $ BinaryOperator ">")
, (OpGe, makeOperatorInfo "GE" $ BinaryOperator ">=")
, (OpNot, makeOperatorInfo "NOT" $ UnaryPrefixOperator "!")
, (OpAnd, makeOperatorInfo "AND" $ BinaryOperator "&&")
, (OpOr, makeOperatorInfo "OR" $ BinaryOperator "||")
, (OpBitNot, makeOperatorInfo "BNOT" $ UnaryPrefixOperator "~")
, (OpBitAnd, makeOperatorInfo "BAND" $ BinaryOperator "&")
, (OpBitAndAssign, makeOperatorInfo "BANDA" $ BinaryOperator "&=")
, (OpBitOr, makeOperatorInfo "BOR" $ BinaryOperator "|")
, (OpBitOrAssign, makeOperatorInfo "BORA" $ BinaryOperator "|=")
, (OpBitXor, makeOperatorInfo "BXOR" $ BinaryOperator "^")
, (OpBitXorAssign, makeOperatorInfo "BXORA" $ BinaryOperator "^=")
, (OpShl, makeOperatorInfo "SHL" $ BinaryOperator "<<")
, (OpShlAssign, makeOperatorInfo "SHLA" $ BinaryOperator "<<=")
, (OpShr, makeOperatorInfo "SHR" $ BinaryOperator ">>")
, (OpShrAssign, makeOperatorInfo "SHR" $ BinaryOperator ">>=")
]
in if map fst input == [minBound..]
then M.fromList input
else error "operatorInfo: Operator info list is out of sync with Operator data type."
data Export =
ExportVariable Variable
| ExportEnum CppEnum
| ExportBitspace Bitspace
| ExportFn Function
| ExportClass Class
| ExportCallback Callback
deriving (Show)
instance HasExtNames Export where
getPrimaryExtName x = case x of
ExportVariable v -> getPrimaryExtName v
ExportEnum e -> getPrimaryExtName e
ExportBitspace b -> getPrimaryExtName b
ExportFn f -> getPrimaryExtName f
ExportClass cls -> getPrimaryExtName cls
ExportCallback cb -> getPrimaryExtName cb
getNestedExtNames x = case x of
ExportVariable v -> getNestedExtNames v
ExportEnum e -> getNestedExtNames e
ExportBitspace b -> getNestedExtNames b
ExportFn f -> getNestedExtNames f
ExportClass cls -> getNestedExtNames cls
ExportCallback cb -> getNestedExtNames cb
exportAddendum export = case export of
ExportVariable v -> getAddendum v
ExportEnum e -> getAddendum e
ExportBitspace bs -> getAddendum bs
ExportFn f -> getAddendum f
ExportClass cls -> getAddendum cls
ExportCallback cb -> getAddendum cb
newtype Identifier = Identifier
{ identifierParts :: [IdPart]
} deriving (Eq)
instance Show Identifier where
show ident =
(\words -> concat $ "<Identifier " : words ++ [">"]) $
intersperse "::" $
map (\part -> case idPartArgs part of
Nothing -> idPartBase part
Just args ->
concat $
idPartBase part : "<" :
intersperse ", " (map show args) ++ [">"]) $
identifierParts ident
data IdPart = IdPart
{ idPartBase :: String
, idPartArgs :: Maybe [Type]
} deriving (Eq, Show)
ident :: String -> Identifier
ident a = Identifier [IdPart a Nothing]
ident' :: [String] -> Identifier
ident' = Identifier . map (\x -> IdPart x Nothing)
ident1 :: String -> String -> Identifier
ident1 a b = ident' [a, b]
ident2 :: String -> String -> String -> Identifier
ident2 a b c = ident' [a, b, c]
ident3 :: String -> String -> String -> String -> Identifier
ident3 a b c d = ident' [a, b, c, d]
ident4 :: String -> String -> String -> String -> String -> Identifier
ident4 a b c d e = ident' [a, b, c, d, e]
ident5 :: String -> String -> String -> String -> String -> String -> Identifier
ident5 a b c d e f = ident' [a, b, c, d, e, f]
identT :: String -> [Type] -> Identifier
identT a ts = Identifier [IdPart a $ Just ts]
identT' :: [(String, Maybe [Type])] -> Identifier
identT' = Identifier . map (uncurry IdPart)
ident1T :: String -> String -> [Type] -> Identifier
ident1T a b ts = Identifier [IdPart a Nothing, IdPart b $ Just ts]
ident2T :: String -> String -> String -> [Type] -> Identifier
ident2T a b c ts = Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c $ Just ts]
ident3T :: String -> String -> String -> String -> [Type] -> Identifier
ident3T a b c d ts =
Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing,
IdPart d $ Just ts]
ident4T :: String -> String -> String -> String -> String -> [Type] -> Identifier
ident4T a b c d e ts =
Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing,
IdPart d Nothing, IdPart e $ Just ts]
ident5T :: String -> String -> String -> String -> String -> String -> [Type] -> Identifier
ident5T a b c d e f ts =
Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c Nothing,
IdPart d Nothing, IdPart e Nothing, IdPart f $ Just ts]
data Type =
Internal_TVoid
| Internal_TBool
| Internal_TChar
| Internal_TUChar
| Internal_TShort
| Internal_TUShort
| Internal_TInt
| Internal_TUInt
| Internal_TLong
| Internal_TULong
| Internal_TLLong
| Internal_TULLong
| Internal_TFloat
| Internal_TDouble
| Internal_TInt8
| Internal_TInt16
| Internal_TInt32
| Internal_TInt64
| Internal_TWord8
| Internal_TWord16
| Internal_TWord32
| Internal_TWord64
| Internal_TPtrdiff
| Internal_TSize
| Internal_TSSize
| Internal_TEnum CppEnum
| Internal_TBitspace Bitspace
| Internal_TPtr Type
| Internal_TRef Type
| Internal_TFn [Type] Type
| Internal_TCallback Callback
| Internal_TObj Class
| Internal_TObjToHeap Class
| Internal_TToGc Type
| Internal_TConst Type
deriving (Eq, Show)
normalizeType :: Type -> Type
normalizeType t = case t of
Internal_TVoid -> t
Internal_TBool -> t
Internal_TChar -> t
Internal_TUChar -> t
Internal_TShort -> t
Internal_TUShort -> t
Internal_TInt -> t
Internal_TUInt -> t
Internal_TLong -> t
Internal_TULong -> t
Internal_TLLong -> t
Internal_TULLong -> t
Internal_TFloat -> t
Internal_TDouble -> t
Internal_TInt8 -> t
Internal_TInt16 -> t
Internal_TInt32 -> t
Internal_TInt64 -> t
Internal_TWord8 -> t
Internal_TWord16 -> t
Internal_TWord32 -> t
Internal_TWord64 -> t
Internal_TPtrdiff -> t
Internal_TSize -> t
Internal_TSSize -> t
Internal_TEnum _ -> t
Internal_TBitspace _ -> t
Internal_TPtr t' -> Internal_TPtr $ normalizeType t'
Internal_TRef t' -> Internal_TRef $ normalizeType t'
Internal_TFn paramTypes retType ->
Internal_TFn (map normalizeType paramTypes) $ normalizeType retType
Internal_TCallback _ -> t
Internal_TObj _ -> t
Internal_TObjToHeap _ -> t
Internal_TToGc _ -> t
Internal_TConst (Internal_TConst t') -> normalizeType $ Internal_TConst t'
Internal_TConst _ -> t
stripConst :: Type -> Type
stripConst t = case t of
Internal_TConst t' -> stripConst t'
_ -> t
data Variable = Variable
{ varIdentifier :: Identifier
, varExtName :: ExtName
, varType :: Type
, varReqs :: Reqs
, varAddendum :: Addendum
}
instance Eq Variable where
(==) = (==) `on` varExtName
instance Show Variable where
show v = concat ["<Variable ", show (varExtName v), " ", show (varType v), ">"]
instance HasExtNames Variable where
getPrimaryExtName = varExtName
getNestedExtNames v = [varGetterExtName v, varSetterExtName v]
instance HasReqs Variable where
getReqs = varReqs
setReqs reqs v = v { varReqs = reqs }
instance HasAddendum Variable where
getAddendum = varAddendum
setAddendum addendum v = v { varAddendum = addendum }
makeVariable :: Identifier -> Maybe ExtName -> Type -> Variable
makeVariable identifier maybeExtName t =
Variable identifier (extNameOrIdentifier identifier maybeExtName) t mempty mempty
varIsConst :: Variable -> Bool
varIsConst v = case varType v of
Internal_TConst _ -> True
_ -> False
varGetterExtName :: Variable -> ExtName
varGetterExtName = toExtName . (++ "_get") . fromExtName . varExtName
varSetterExtName :: Variable -> ExtName
varSetterExtName = toExtName . (++ "_set") . fromExtName . varExtName
data CppEnum = CppEnum
{ enumIdentifier :: Identifier
, enumExtName :: ExtName
, enumValueNames :: [(Int, [String])]
, enumReqs :: Reqs
, enumAddendum :: Addendum
, enumValuePrefix :: String
}
instance Eq CppEnum where
(==) = (==) `on` enumExtName
instance Show CppEnum where
show e = concat ["<Enum ", show (enumExtName e), " ", show (enumIdentifier e), ">"]
instance HasExtNames CppEnum where
getPrimaryExtName = enumExtName
instance HasReqs CppEnum where
getReqs = enumReqs
setReqs reqs e = e { enumReqs = reqs }
instance HasAddendum CppEnum where
getAddendum = enumAddendum
setAddendum addendum e = e { enumAddendum = addendum }
makeEnum :: Identifier
-> Maybe ExtName
-> [(Int, [String])]
-> CppEnum
makeEnum identifier maybeExtName valueNames =
let extName = extNameOrIdentifier identifier maybeExtName
in CppEnum
identifier
extName
valueNames
mempty
mempty
(fromExtName extName ++ "_")
enumSetValuePrefix :: String -> CppEnum -> CppEnum
enumSetValuePrefix prefix enum = enum { enumValuePrefix = prefix }
data Bitspace = Bitspace
{ bitspaceExtName :: ExtName
, bitspaceType :: Type
, bitspaceValueNames :: [(Int, [String])]
, bitspaceEnum :: Maybe CppEnum
, bitspaceCppTypeIdentifier :: Maybe Identifier
, bitspaceToCppValueFn :: Maybe String
, bitspaceFromCppValueFn :: Maybe String
, bitspaceReqs :: Reqs
, bitspaceAddendum :: Addendum
, bitspaceValuePrefix :: String
}
instance Eq Bitspace where
(==) = (==) `on` bitspaceExtName
instance Show Bitspace where
show e = concat ["<Bitspace ", show (bitspaceExtName e), " ", show (bitspaceType e), ">"]
instance HasExtNames Bitspace where
getPrimaryExtName = bitspaceExtName
instance HasReqs Bitspace where
getReqs = bitspaceReqs
setReqs reqs b = b { bitspaceReqs = reqs }
instance HasAddendum Bitspace where
getAddendum = bitspaceAddendum
setAddendum addendum bs = bs { bitspaceAddendum = addendum }
makeBitspace :: ExtName
-> Type
-> [(Int, [String])]
-> Bitspace
makeBitspace extName t valueNames =
Bitspace extName t valueNames Nothing Nothing Nothing Nothing mempty mempty
(fromExtName extName ++ "_")
bitspaceSetValuePrefix :: String -> Bitspace -> Bitspace
bitspaceSetValuePrefix prefix bitspace = bitspace { bitspaceValuePrefix = prefix }
bitspaceAddEnum :: CppEnum -> Bitspace -> Bitspace
bitspaceAddEnum enum bitspace = case bitspaceEnum bitspace of
Just enum' ->
error $ concat
["bitspaceAddEnum: Adding ", show enum, " to ", show bitspace,
", but it already has ", show enum', "."]
Nothing ->
if bitspaceValueNames bitspace /= enumValueNames enum
then error $ concat
["bitspaceAddEnum: Trying to add ", show enum, " to ", show bitspace,
", but the values aren't equal.\nBitspace values: ", show $ bitspaceValueNames bitspace,
"\n Enum values: ", show $ enumValueNames enum]
else bitspace { bitspaceEnum = Just enum }
bitspaceAddCppType :: Identifier -> Maybe String -> Maybe String -> Bitspace -> Bitspace
bitspaceAddCppType cppTypeId toCppValueFnMaybe fromCppValueFnMaybe b =
case bitspaceCppTypeIdentifier b of
Just cppTypeId' ->
error $ concat
["bitspaceAddCppType: Adding C++ type ", show cppTypeId,
" to ", show b, ", but it already has ", show cppTypeId', "."]
Nothing ->
b { bitspaceCppTypeIdentifier = Just cppTypeId
, bitspaceToCppValueFn = toCppValueFnMaybe
, bitspaceFromCppValueFn = fromCppValueFnMaybe
}
data Purity = Nonpure
| Pure
deriving (Eq, Show)
data Function = Function
{ fnCName :: FnName Identifier
, fnExtName :: ExtName
, fnPurity :: Purity
, fnParams :: [Type]
, fnReturn :: Type
, fnReqs :: Reqs
, fnExceptionHandlers :: ExceptionHandlers
, fnAddendum :: Addendum
}
instance Show Function where
show fn =
concat ["<Function ", show (fnExtName fn), " ", show (fnCName fn),
show (fnParams fn), " ", show (fnReturn fn), ">"]
instance HasExtNames Function where
getPrimaryExtName = fnExtName
instance HasReqs Function where
getReqs = fnReqs
setReqs reqs fn = fn { fnReqs = reqs }
instance HandlesExceptions Function where
getExceptionHandlers = fnExceptionHandlers
modifyExceptionHandlers f fn = fn { fnExceptionHandlers = f $ fnExceptionHandlers fn }
instance HasAddendum Function where
getAddendum = fnAddendum
setAddendum addendum fn = fn { fnAddendum = addendum }
makeFn :: IsFnName Identifier name
=> name
-> Maybe ExtName
-> Purity
-> [Type]
-> Type
-> Function
makeFn cName maybeExtName purity paramTypes retType =
let fnName = toFnName cName
in Function fnName
(extNameOrFnIdentifier fnName maybeExtName)
purity paramTypes retType mempty mempty mempty
data Class = Class
{ classIdentifier :: Identifier
, classExtName :: ExtName
, classSuperclasses :: [Class]
, classEntities :: [ClassEntity]
, classDtorIsPublic :: Bool
, classConversion :: ClassConversion
, classReqs :: Reqs
, classAddendum :: Addendum
, classIsMonomorphicSuperclass :: Bool
, classIsSubclassOfMonomorphic :: Bool
, classIsException :: Bool
, classEntityPrefix :: String
}
instance Eq Class where
(==) = (==) `on` classExtName
instance Ord Class where
compare = compare `on` classExtName
instance Show Class where
show cls =
concat ["<Class ", show (classExtName cls), " ", show (classIdentifier cls), ">"]
instance HasExtNames Class where
getPrimaryExtName = classExtName
getNestedExtNames cls = concatMap (classEntityExtNames cls) $ classEntities cls
instance HasReqs Class where
getReqs = classReqs
setReqs reqs cls = cls { classReqs = reqs }
instance HasAddendum Class where
getAddendum = classAddendum
setAddendum addendum cls = cls { classAddendum = addendum }
makeClass :: Identifier
-> Maybe ExtName
-> [Class]
-> [ClassEntity]
-> Class
makeClass identifier maybeExtName supers entities =
let extName = extNameOrIdentifier identifier maybeExtName
in Class
{ classIdentifier = identifier
, classExtName = extName
, classSuperclasses = supers
, classEntities = entities
, classDtorIsPublic = True
, classConversion = classConversionNone
, classReqs = mempty
, classAddendum = mempty
, classIsMonomorphicSuperclass = False
, classIsSubclassOfMonomorphic = False
, classIsException = False
, classEntityPrefix = fromExtName extName ++ "_"
}
classSetEntityPrefix :: String -> Class -> Class
classSetEntityPrefix prefix cls = cls { classEntityPrefix = prefix }
classAddEntities :: [ClassEntity] -> Class -> Class
classAddEntities ents cls =
if null ents then cls else cls { classEntities = classEntities cls ++ ents }
classVariables :: Class -> [ClassVariable]
classVariables = mapMaybe pickVar . classEntities
where pickVar ent = case ent of
CEVar v -> Just v
CECtor _ -> Nothing
CEMethod _ -> Nothing
CEProp _ -> Nothing
classCtors :: Class -> [Ctor]
classCtors = mapMaybe pickCtor . classEntities
where pickCtor ent = case ent of
CEVar _ -> Nothing
CECtor ctor -> Just ctor
CEMethod _ -> Nothing
CEProp _ -> Nothing
classMethods :: Class -> [Method]
classMethods = concatMap pickMethods . classEntities
where pickMethods ent = case ent of
CEVar _ -> []
CECtor _ -> []
CEMethod m -> [m]
CEProp (Prop ms) -> ms
classSetDtorPrivate :: Class -> Class
classSetDtorPrivate cls = cls { classDtorIsPublic = False }
classSetMonomorphicSuperclass :: Class -> Class
classSetMonomorphicSuperclass cls = cls { classIsMonomorphicSuperclass = True }
classSetSubclassOfMonomorphic :: Class -> Class
classSetSubclassOfMonomorphic cls = cls { classIsSubclassOfMonomorphic = True }
classMakeException :: Class -> Class
classMakeException cls = case classIsException cls of
False -> cls { classIsException = True }
True -> cls
data ClassConversion = ClassConversion
{ classHaskellConversion :: ClassHaskellConversion
}
classConversionNone :: ClassConversion
classConversionNone = ClassConversion classHaskellConversionNone
classModifyConversion :: (ClassConversion -> ClassConversion) -> Class -> Class
classModifyConversion f cls =
let cls' = cls { classConversion = f $ classConversion cls }
conv = classConversion cls'
haskellConv = classHaskellConversion conv
in case undefined of
_ | (isJust (classHaskellConversionToCppFn haskellConv) ||
isJust (classHaskellConversionFromCppFn haskellConv)) &&
isNothing (classHaskellConversionType haskellConv) ->
error $ "classModifyConversion: " ++ show cls' ++
" was given a Haskell-to-C++ or C++-to-Haskell conversion function" ++
" but no Haskell type. Please provide a classHaskellConversionType."
_ -> cls'
classSetConversion :: ClassConversion -> Class -> Class
classSetConversion c = classModifyConversion $ const c
data ClassHaskellConversion = ClassHaskellConversion
{ classHaskellConversionType :: Maybe (Haskell.Generator HsType)
, classHaskellConversionToCppFn :: Maybe (Haskell.Generator ())
, classHaskellConversionFromCppFn :: Maybe (Haskell.Generator ())
}
classHaskellConversionNone :: ClassHaskellConversion
classHaskellConversionNone =
ClassHaskellConversion
{ classHaskellConversionType = Nothing
, classHaskellConversionToCppFn = Nothing
, classHaskellConversionFromCppFn = Nothing
}
classSetHaskellConversion :: ClassHaskellConversion -> Class -> Class
classSetHaskellConversion conv = classModifyConversion $ \c ->
c { classHaskellConversion = conv }
class IsClassEntity a where
classEntityExtNameSuffix :: a -> ExtName
classEntityExtName :: IsClassEntity a => Class -> a -> ExtName
classEntityExtName cls x =
toExtName $ fromExtName (classExtName cls) ++ "_" ++ fromExtName (classEntityExtNameSuffix x)
classEntityForeignName :: IsClassEntity a => Class -> a -> ExtName
classEntityForeignName cls x =
classEntityForeignName' cls $ classEntityExtNameSuffix x
classEntityForeignName' :: Class -> ExtName -> ExtName
classEntityForeignName' cls extName =
toExtName $ classEntityPrefix cls ++ fromExtName extName
data ClassEntity =
CEVar ClassVariable
| CECtor Ctor
| CEMethod Method
| CEProp Prop
classEntityExtNames :: Class -> ClassEntity -> [ExtName]
classEntityExtNames cls ent = case ent of
CEVar v -> [classEntityExtName cls v]
CECtor ctor -> [classEntityExtName cls ctor]
CEMethod m -> [classEntityExtName cls m]
CEProp (Prop methods) -> map (classEntityExtName cls) methods
data ClassVariable = ClassVariable
{ classVarCName :: String
, classVarExtName :: ExtName
, classVarType :: Type
, classVarStatic :: Staticness
, classVarGettable :: Bool
}
instance Show ClassVariable where
show v =
concat ["<ClassVariable ",
show $ classVarCName v, " ",
show $ classVarExtName v, " ",
show $ classVarStatic v, " ",
show $ classVarType v, ">"]
instance IsClassEntity ClassVariable where
classEntityExtNameSuffix = classVarExtName
makeClassVariable :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassEntity
makeClassVariable cName maybeExtName tp static gettable =
CEVar $ makeClassVariable_ cName maybeExtName tp static gettable
makeClassVariable_ :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable
makeClassVariable_ cName maybeExtName =
ClassVariable cName $ extNameOrString cName maybeExtName
mkClassVariable :: String -> Type -> ClassEntity
mkClassVariable = (CEVar .) . mkClassVariable_
mkClassVariable_ :: String -> Type -> ClassVariable
mkClassVariable_ cName t = makeClassVariable_ cName Nothing t Nonstatic True
mkStaticClassVariable :: String -> Type -> ClassEntity
mkStaticClassVariable = (CEVar .) . mkStaticClassVariable_
mkStaticClassVariable_ :: String -> Type -> ClassVariable
mkStaticClassVariable_ cName t = makeClassVariable_ cName Nothing t Static True
classVarGetterExtName :: Class -> ClassVariable -> ExtName
classVarGetterExtName cls v =
toExtName $ fromExtName (classEntityExtName cls v) ++ "_get"
classVarGetterForeignName :: Class -> ClassVariable -> ExtName
classVarGetterForeignName cls v =
toExtName $ fromExtName (classEntityForeignName cls v) ++ "_get"
classVarSetterExtName :: Class -> ClassVariable -> ExtName
classVarSetterExtName cls v =
toExtName $ fromExtName (classEntityExtName cls v) ++ "_set"
classVarSetterForeignName :: Class -> ClassVariable -> ExtName
classVarSetterForeignName cls v =
toExtName $ fromExtName (classEntityForeignName cls v) ++ "_set"
data Ctor = Ctor
{ ctorExtName :: ExtName
, ctorParams :: [Type]
, ctorExceptionHandlers :: ExceptionHandlers
}
instance Show Ctor where
show ctor = concat ["<Ctor ", show (ctorExtName ctor), " ", show (ctorParams ctor), ">"]
instance HandlesExceptions Ctor where
getExceptionHandlers = ctorExceptionHandlers
modifyExceptionHandlers f ctor = ctor { ctorExceptionHandlers = f $ ctorExceptionHandlers ctor }
instance IsClassEntity Ctor where
classEntityExtNameSuffix = ctorExtName
makeCtor :: ExtName
-> [Type]
-> ClassEntity
makeCtor = (CECtor .) . makeCtor_
makeCtor_ :: ExtName -> [Type] -> Ctor
makeCtor_ extName paramTypes = Ctor extName paramTypes mempty
mkCtor :: String
-> [Type]
-> ClassEntity
mkCtor = (CECtor .) . mkCtor_
mkCtor_ :: String -> [Type] -> Ctor
mkCtor_ = makeCtor_ . toExtName
classFindCopyCtor :: Class -> Maybe Ctor
classFindCopyCtor cls = case mapMaybe check $ classEntities cls of
[ctor] -> Just ctor
_ -> Nothing
where check entity = case entity of
CECtor ctor ->
let params = map (stripConst . normalizeType) (ctorParams ctor)
in if params == [Internal_TObj cls] ||
params == [Internal_TRef $ Internal_TConst $ Internal_TObj cls]
then Just ctor
else Nothing
_ -> Nothing
data Method = Method
{ methodImpl :: MethodImpl
, methodExtName :: ExtName
, methodApplicability :: MethodApplicability
, methodPurity :: Purity
, methodParams :: [Type]
, methodReturn :: Type
, methodExceptionHandlers :: ExceptionHandlers
}
instance Show Method where
show method =
concat ["<Method ", show (methodExtName method), " ",
case methodImpl method of
RealMethod name -> show name
FnMethod name -> show name, " ",
show (methodApplicability method), " ",
show (methodPurity method), " ",
show (methodParams method), " ",
show (methodReturn method), ">"]
instance HandlesExceptions Method where
getExceptionHandlers = methodExceptionHandlers
modifyExceptionHandlers f method =
method { methodExceptionHandlers = f $ methodExceptionHandlers method }
instance IsClassEntity Method where
classEntityExtNameSuffix = methodExtName
data MethodImpl =
RealMethod (FnName String)
| FnMethod (FnName Identifier)
deriving (Eq, Show)
data MethodApplicability = MNormal | MStatic | MConst
deriving (Bounded, Enum, Eq, Show)
data Constness = Nonconst | Const
deriving (Bounded, Enum, Eq, Show)
constNegate :: Constness -> Constness
constNegate Nonconst = Const
constNegate Const = Nonconst
data Staticness = Nonstatic | Static
deriving (Bounded, Enum, Eq, Show)
methodConst :: Method -> Constness
methodConst method = case methodApplicability method of
MConst -> Const
_ -> Nonconst
methodStatic :: Method -> Staticness
methodStatic method = case methodApplicability method of
MStatic -> Static
_ -> Nonstatic
makeMethod :: IsFnName String name
=> name
-> ExtName
-> MethodApplicability
-> Purity
-> [Type]
-> Type
-> ClassEntity
makeMethod = (((((CEMethod .) .) .) .) .) . makeMethod_
makeMethod_ :: IsFnName String name
=> name
-> ExtName
-> MethodApplicability
-> Purity
-> [Type]
-> Type
-> Method
makeMethod_ cName extName appl purity paramTypes retType =
Method (RealMethod $ toFnName cName) extName appl purity paramTypes retType mempty
makeFnMethod :: IsFnName Identifier name
=> name
-> String
-> MethodApplicability
-> Purity
-> [Type]
-> Type
-> ClassEntity
makeFnMethod = (((((CEMethod .) .) .) .) .) . makeFnMethod_
makeFnMethod_ :: IsFnName Identifier name
=> name
-> String
-> MethodApplicability
-> Purity
-> [Type]
-> Type
-> Method
makeFnMethod_ cName foreignName appl purity paramTypes retType =
Method (FnMethod $ toFnName cName) (toExtName foreignName)
appl purity paramTypes retType mempty
makeMethod' :: IsFnName String name
=> name
-> MethodApplicability
-> Purity
-> [Type]
-> Type
-> Method
makeMethod' name = makeMethod''' (toFnName name) Nothing
makeMethod'' :: IsFnName String name
=> name
-> String
-> MethodApplicability
-> Purity
-> [Type]
-> Type
-> Method
makeMethod'' name foreignName = makeMethod''' (toFnName name) $ Just foreignName
makeMethod''' :: FnName String
-> Maybe String
-> MethodApplicability
-> Purity
-> [Type]
-> Type
-> Method
makeMethod''' (FnName "") maybeForeignName _ _ paramTypes retType =
error $ concat ["makeMethod''': Given an empty method name with foreign name ",
show maybeForeignName, ", parameter types ", show paramTypes,
", and return type ", show retType, "."]
makeMethod''' name (Just "") _ _ paramTypes retType =
error $ concat ["makeMethod''': Given an empty foreign name with method ",
show name, ", parameter types ", show paramTypes, ", and return type ",
show retType, "."]
makeMethod''' name maybeForeignName appl purity paramTypes retType =
let extName = flip fromMaybe (toExtName <$> maybeForeignName) $ case name of
FnName s -> toExtName s
FnOp op -> operatorPreferredExtName op
in makeMethod_ name extName appl purity paramTypes retType
mkMethod :: IsFnName String name
=> name
-> [Type]
-> Type
-> ClassEntity
mkMethod = ((CEMethod .) .) . mkMethod_
mkMethod_ :: IsFnName String name
=> name
-> [Type]
-> Type
-> Method
mkMethod_ name = makeMethod' name MNormal Nonpure
mkMethod' :: IsFnName String name
=> name
-> String
-> [Type]
-> Type
-> ClassEntity
mkMethod' = (((CEMethod .) .) .) . mkMethod'_
mkMethod'_ :: IsFnName String name
=> name
-> String
-> [Type]
-> Type
-> Method
mkMethod'_ cName foreignName = makeMethod'' cName foreignName MNormal Nonpure
mkConstMethod :: IsFnName String name => name -> [Type] -> Type -> ClassEntity
mkConstMethod = ((CEMethod .) .) . mkConstMethod_
mkConstMethod_ :: IsFnName String name => name -> [Type] -> Type -> Method
mkConstMethod_ name = makeMethod' name MConst Nonpure
mkConstMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> ClassEntity
mkConstMethod' = (((CEMethod .) .) .) . mkConstMethod'_
mkConstMethod'_ :: IsFnName String name => name -> String -> [Type] -> Type -> Method
mkConstMethod'_ cName foreignName = makeMethod'' cName foreignName MConst Nonpure
mkStaticMethod :: IsFnName String name => name -> [Type] -> Type -> ClassEntity
mkStaticMethod = ((CEMethod .) .) . mkStaticMethod_
mkStaticMethod_ :: IsFnName String name => name -> [Type] -> Type -> Method
mkStaticMethod_ name = makeMethod' name MStatic Nonpure
mkStaticMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> ClassEntity
mkStaticMethod' = (((CEMethod .) .) .) . mkStaticMethod'_
mkStaticMethod'_ :: IsFnName String name => name -> String -> [Type] -> Type -> Method
mkStaticMethod'_ cName foreignName = makeMethod'' cName foreignName MStatic Nonpure
newtype Prop = Prop [Method]
mkProp :: String -> Type -> ClassEntity
mkProp = (CEProp .) . mkProp_
mkProp_ :: String -> Type -> Prop
mkProp_ name t =
let c:cs = name
setName = 's' : 'e' : 't' : toUpper c : cs
in Prop [ mkConstMethod_ name [] t
, mkMethod_ setName [t] Internal_TVoid
]
mkStaticProp :: String -> Type -> ClassEntity
mkStaticProp = (CEProp .) . mkStaticProp_
mkStaticProp_ :: String -> Type -> Prop
mkStaticProp_ name t =
let c:cs = name
setName = 's' : 'e' : 't' : toUpper c : cs
in Prop [ mkStaticMethod_ name [] t
, mkStaticMethod_ setName [t] Internal_TVoid
]
mkBoolIsProp :: String -> ClassEntity
mkBoolIsProp = CEProp . mkBoolIsProp_
mkBoolIsProp_ :: String -> Prop
mkBoolIsProp_ name =
let c:cs = name
name' = toUpper c : cs
isName = 'i':'s':name'
setName = 's':'e':'t':name'
in Prop [ mkConstMethod_ isName [] Internal_TBool
, mkMethod_ setName [Internal_TBool] Internal_TVoid
]
mkBoolHasProp :: String -> ClassEntity
mkBoolHasProp = CEProp . mkBoolHasProp_
mkBoolHasProp_ :: String -> Prop
mkBoolHasProp_ name =
let c:cs = name
name' = toUpper c : cs
hasName = 'h':'a':'s':name'
setName = 's':'e':'t':name'
in Prop [ mkConstMethod_ hasName [] Internal_TBool
, mkMethod_ setName [Internal_TBool] Internal_TVoid
]
data Callback = Callback
{ callbackExtName :: ExtName
, callbackParams :: [Type]
, callbackReturn :: Type
, callbackThrows :: Maybe Bool
, callbackReqs :: Reqs
, callbackAddendum :: Addendum
}
instance Eq Callback where
(==) = (==) `on` callbackExtName
instance Show Callback where
show cb =
concat ["<Callback ", show (callbackExtName cb), " ", show (callbackParams cb), " ",
show (callbackReturn cb)]
instance HasExtNames Callback where
getPrimaryExtName = callbackExtName
instance HasReqs Callback where
getReqs = callbackReqs
setReqs reqs cb = cb { callbackReqs = reqs }
instance HasAddendum Callback where
getAddendum = callbackAddendum
setAddendum addendum cb = cb { callbackAddendum = addendum }
makeCallback :: ExtName
-> [Type]
-> Type
-> Callback
makeCallback extName paramTypes retType =
Callback extName paramTypes retType Nothing mempty mempty
callbackSetThrows :: Bool -> Callback -> Callback
callbackSetThrows value cb = cb { callbackThrows = Just value }
newtype ExceptionId = ExceptionId
{ getExceptionId :: Int
} deriving (Eq, Show)
exceptionCatchAllId :: ExceptionId
exceptionCatchAllId = ExceptionId 1
exceptionFirstFreeId :: Int
exceptionFirstFreeId = getExceptionId exceptionCatchAllId + 1
data ExceptionHandler =
CatchClass Class
| CatchAll
deriving (Eq, Ord)
data ExceptionHandlers = ExceptionHandlers
{ exceptionHandlersList :: [ExceptionHandler]
}
instance Monoid ExceptionHandlers where
mempty = ExceptionHandlers []
mappend e1 e2 =
ExceptionHandlers
(S.toList $ S.fromList $ exceptionHandlersList e1 ++ exceptionHandlersList e2)
class HandlesExceptions a where
getExceptionHandlers :: a -> ExceptionHandlers
modifyExceptionHandlers :: (ExceptionHandlers -> ExceptionHandlers) -> a -> a
handleExceptions :: HandlesExceptions a => [ExceptionHandler] -> a -> a
handleExceptions classes =
modifyExceptionHandlers $ mappend mempty {exceptionHandlersList = classes}
newtype HsImportSet = HsImportSet
{ getHsImportSet :: M.Map HsImportKey HsImportSpecs
} deriving (Show)
instance Monoid HsImportSet where
mempty = HsImportSet M.empty
mappend (HsImportSet m) (HsImportSet m') =
HsImportSet $ M.unionWith mergeImportSpecs m m'
mconcat sets =
HsImportSet $ M.unionsWith mergeImportSpecs $ map getHsImportSet sets
data Addendum = Addendum
{ addendumHaskell :: Haskell.Generator ()
}
instance Monoid Addendum where
mempty = Addendum $ return ()
mappend (Addendum a) (Addendum b) = Addendum $ a >> b
class HasAddendum a where
getAddendum :: a -> Addendum
setAddendum :: Addendum -> a -> a
setAddendum addendum = modifyAddendum $ const addendum
modifyAddendum :: (Addendum -> Addendum) -> a -> a
modifyAddendum f x = setAddendum (f $ getAddendum x) x
addAddendumHaskell :: HasAddendum a => Haskell.Generator () -> a -> a
addAddendumHaskell gen = modifyAddendum $ \addendum ->
addendum `mappend` mempty { addendumHaskell = gen }
makeHsImportSet :: M.Map HsImportKey HsImportSpecs -> HsImportSet
makeHsImportSet = HsImportSet
hsImportSetMakeSource :: HsImportSet -> HsImportSet
hsImportSetMakeSource (HsImportSet m) =
HsImportSet $ M.map (\specs -> specs { hsImportSource = True }) m
type HsModuleName = String
data HsImportKey = HsImportKey
{ hsImportModule :: HsModuleName
, hsImportQualifiedName :: Maybe HsModuleName
} deriving (Eq, Ord, Show)
data HsImportSpecs = HsImportSpecs
{ getHsImportSpecs :: Maybe (M.Map HsImportName HsImportVal)
, hsImportSource :: Bool
} deriving (Show)
mergeImportSpecs :: HsImportSpecs -> HsImportSpecs -> HsImportSpecs
mergeImportSpecs (HsImportSpecs mm s) (HsImportSpecs mm' s') =
HsImportSpecs (liftM2 mergeMaps mm mm') (s || s')
where mergeMaps = M.unionWith mergeValues
mergeValues v v' = case (v, v') of
(HsImportValAll, _) -> HsImportValAll
(_, HsImportValAll) -> HsImportValAll
(HsImportValSome s, HsImportValSome s') -> HsImportValSome $ s ++ s'
(x@(HsImportValSome _), _) -> x
(_, x@(HsImportValSome _)) -> x
(HsImportVal, HsImportVal) -> HsImportVal
type HsImportName = String
data HsImportVal =
HsImportVal
| HsImportValSome [HsImportName]
| HsImportValAll
deriving (Show)
hsWholeModuleImport :: HsModuleName -> HsImportSet
hsWholeModuleImport moduleName =
HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $
HsImportSpecs Nothing False
hsQualifiedImport :: HsModuleName -> HsModuleName -> HsImportSet
hsQualifiedImport moduleName qualifiedName =
HsImportSet $ M.singleton (HsImportKey moduleName $ Just qualifiedName) $
HsImportSpecs Nothing False
hsImport1 :: HsModuleName -> HsImportName -> HsImportSet
hsImport1 moduleName valueName = hsImport1' moduleName valueName HsImportVal
hsImport1' :: HsModuleName -> HsImportName -> HsImportVal -> HsImportSet
hsImport1' moduleName valueName valueType =
HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $
HsImportSpecs (Just $ M.singleton valueName valueType) False
hsImports :: HsModuleName -> [HsImportName] -> HsImportSet
hsImports moduleName names =
hsImports' moduleName $ map (\name -> (name, HsImportVal)) names
hsImports' :: HsModuleName -> [(HsImportName, HsImportVal)] -> HsImportSet
hsImports' moduleName values =
HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $
HsImportSpecs (Just $ M.fromList values) False
hsImportForBits :: HsImportSet
hsImportForBits = hsQualifiedImport "Data.Bits" "HoppyDB"
hsImportForException :: HsImportSet
hsImportForException = hsQualifiedImport "Control.Exception" "HoppyCE"
hsImportForInt :: HsImportSet
hsImportForInt = hsQualifiedImport "Data.Int" "HoppyDI"
hsImportForWord :: HsImportSet
hsImportForWord = hsQualifiedImport "Data.Word" "HoppyDW"
hsImportForForeign :: HsImportSet
hsImportForForeign = hsQualifiedImport "Foreign" "HoppyF"
hsImportForForeignC :: HsImportSet
hsImportForForeignC = hsQualifiedImport "Foreign.C" "HoppyFC"
hsImportForMap :: HsImportSet
hsImportForMap = hsQualifiedImport "Data.Map" "HoppyDM"
hsImportForPrelude :: HsImportSet
hsImportForPrelude = hsQualifiedImport "Prelude" "HoppyP"
hsImportForRuntime :: HsImportSet
hsImportForRuntime = hsQualifiedImport "Foreign.Hoppy.Runtime" "HoppyFHR"
hsImportForSystemPosixTypes :: HsImportSet
hsImportForSystemPosixTypes = hsQualifiedImport "System.Posix.Types" "HoppySPT"
hsImportForTypeable :: HsImportSet
hsImportForTypeable = hsQualifiedImport "Data.Typeable" "HoppyDT"
hsImportForUnsafeIO :: HsImportSet
hsImportForUnsafeIO = hsQualifiedImport "System.IO.Unsafe" "HoppySIU"
objToHeapTWrongDirectionErrorMsg :: Maybe String -> Class -> String
objToHeapTWrongDirectionErrorMsg maybeCaller cls =
concat [maybe "" (++ ": ") maybeCaller,
"(TObjToHeap ", show cls, ") cannot be passed into C++",
maybe "" (const ".") maybeCaller]
tToGcInvalidFormErrorMessage :: Maybe String -> Type -> String
tToGcInvalidFormErrorMessage maybeCaller typeArg =
concat [maybe "" (++ ": ") maybeCaller,
"(", show (Internal_TToGc typeArg), ") is an invalid form for TToGc.",
maybe "" (const ".") maybeCaller]
toGcTWrongDirectionErrorMsg :: Maybe String -> Type -> String
toGcTWrongDirectionErrorMsg maybeCaller typeArg =
concat [maybe "" (++ ": ") maybeCaller,
"(", show (Internal_TToGc typeArg), ") cannot be passed into C++",
maybe "" (const ".") maybeCaller]