module Foreign.Hoppy.Generator.Spec (
Interface,
ErrorMsg,
interface,
interfaceName,
interfaceModules,
interfaceNamesToModules,
interfaceHaskellModuleBase,
interfaceDefaultHaskellModuleBase,
interfaceAddHaskellModuleBase,
Include,
includeStd,
includeLocal,
includeToString,
Module,
moduleName,
moduleHppPath,
moduleCppPath,
moduleExports,
moduleReqs,
moduleHaskellName,
makeModule,
moduleModify,
moduleModify',
moduleSetHppPath,
moduleSetCppPath,
moduleAddExports,
moduleAddHaskellName,
Reqs,
reqsIncludes,
reqInclude,
HasReqs (..),
addReqs,
addReqIncludes,
ExtName,
toExtName,
fromExtName,
FnName (..),
IsFnName (..),
Operator (..),
OperatorType (..),
operatorPreferredExtName,
operatorPreferredExtName',
operatorType,
Export (..),
exportExtName,
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,
Bitspace, makeBitspace, bitspaceExtName, bitspaceType, bitspaceValueNames, bitspaceEnum,
bitspaceAddEnum, bitspaceCppTypeIdentifier, bitspaceFromCppValueFn, bitspaceToCppValueFn,
bitspaceAddCppType, bitspaceReqs,
Purity (..),
Function, makeFn, fnCName, fnExtName, fnPurity, fnParams, fnReturn, fnReqs,
Class, makeClass, classIdentifier, classExtName, classSuperclasses, classCtors, classDtorIsPublic,
classMethods, classConversion, classReqs, classAddCtors, classSetDtorPrivate, classAddMethods,
classIsMonomorphicSuperclass, classSetMonomorphicSuperclass,
classIsSubclassOfMonomorphic, classSetSubclassOfMonomorphic,
HasClassyExtName (..),
Ctor, makeCtor, mkCtor, ctorExtName, ctorParams,
Method,
MethodImpl (..),
MethodApplicability (..),
Constness (..),
constNegate,
Staticness (..),
makeMethod, makeFnMethod, mkMethod, mkMethod', mkConstMethod, mkConstMethod',
mkStaticMethod, mkStaticMethod',
mkProps, mkProp, mkStaticProp, mkBoolIsProp, mkBoolHasProp,
methodImpl, methodExtName, methodApplicability, methodPurity, methodParams,
methodReturn, methodConst, methodStatic,
ClassConversion (..),
classConversionNone,
classModifyConversion,
ClassHaskellConversion (..),
Callback, makeCallback, callbackExtName, callbackParams, callbackReturn, callbackReqs,
callbackToTFn,
Addendum (..),
HasAddendum,
addAddendumHaskell,
HsModuleName, HsImportSet, HsImportKey (..), HsImportSpecs (..), HsImportName, HsImportVal (..),
hsWholeModuleImport, hsQualifiedImport, hsImport1, hsImport1', hsImports, hsImports',
hsImportSetMakeSource,
stringOrIdentifier,
makeHsImportSet,
getHsImportSet,
hsImportForBits,
hsImportForInt,
hsImportForWord,
hsImportForForeign,
hsImportForForeignC,
hsImportForPrelude,
hsImportForRuntime,
hsImportForSystemPosixTypes,
hsImportForUnsafeIO,
tObjToHeapWrongDirectionErrorMsg,
) 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 (fromMaybe)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid, mappend, mconcat, mempty)
#endif
import qualified Data.Set as S
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]
}
instance Show Interface where
show iface = concat ["<Interface ", show (interfaceName iface), ">"]
interface :: String
-> [Module]
-> Either ErrorMsg Interface
interface ifName modules = do
let extNamesToModules :: M.Map ExtName [Module]
extNamesToModules =
M.unionsWith (++) $
map (\m -> const [m] <$> moduleExports m) modules
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
return Interface
{ interfaceName = ifName
, interfaceModules = M.fromList $ map (moduleName &&& id) modules
, interfaceNamesToModules = M.map (\[x] -> x) extNamesToModules
, interfaceHaskellModuleBase' = 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
]
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]
}
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 }
makeModule :: String
-> String
-> String
-> Module
makeModule name hppPath cppPath = Module
{ moduleName = name
, moduleHppPath = hppPath
, moduleCppPath = cppPath
, moduleExports = M.empty
, moduleReqs = mempty
, moduleHaskellName = Nothing
}
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 (exportExtName &&& 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, "."]
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, Ord)
instance Show ExtName where
show extName = concat ["$\"", fromExtName extName, "\"$"]
toExtName :: String -> ExtName
toExtName str = case str of
[] -> error "An ExtName cannot be empty."
c:cs -> if isAlpha c && all ((||) <$> isAlphaNum <*> (== '_')) cs
then ExtName str
else error $
"An ExtName must start with a letter and only contain letters, numbers, and '_': " ++
show str
extNameOrIdentifier :: Identifier -> Maybe ExtName -> ExtName
extNameOrIdentifier ident = fromMaybe $ case identifierParts ident of
[] -> error "extNameOrIdentifier: Invalid empty identifier."
parts -> toExtName $ idPartBase $ last parts
stringOrIdentifier :: Identifier -> Maybe String -> String
stringOrIdentifier ident = fromMaybe $ case identifierParts ident of
[] -> error "stringOrIdentifier: Invalid empty identifier."
parts -> 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
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)
exportExtName :: Export -> ExtName
exportExtName export = case export of
ExportVariable v -> varExtName v
ExportEnum e -> enumExtName e
ExportBitspace b -> bitspaceExtName b
ExportFn f -> fnExtName f
ExportClass c -> classExtName c
ExportCallback cb -> callbackExtName 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 =
TVoid
| TBool
| TChar
| TUChar
| TShort
| TUShort
| TInt
| TUInt
| TLong
| TULong
| TLLong
| TULLong
| TFloat
| TDouble
| TInt8
| TInt16
| TInt32
| TInt64
| TWord8
| TWord16
| TWord32
| TWord64
| TPtrdiff
| TSize
| TSSize
| TEnum CppEnum
| TBitspace Bitspace
| TPtr Type
| TRef Type
| TFn [Type] Type
| TCallback Callback
| TObj Class
| TObjToHeap Class
| TConst Type
deriving (Eq, Show)
normalizeType :: Type -> Type
normalizeType t = case t of
TVoid -> t
TBool -> t
TChar -> t
TUChar -> t
TShort -> t
TUShort -> t
TInt -> t
TUInt -> t
TLong -> t
TULong -> t
TLLong -> t
TULLong -> t
TFloat -> t
TDouble -> t
TInt8 -> t
TInt16 -> t
TInt32 -> t
TInt64 -> t
TWord8 -> t
TWord16 -> t
TWord32 -> t
TWord64 -> t
TPtrdiff -> t
TSize -> t
TSSize -> t
TEnum _ -> t
TBitspace _ -> t
TPtr t' -> TPtr $ normalizeType t'
TRef t' -> TRef $ normalizeType t'
TFn paramTypes retType -> TFn (map normalizeType paramTypes) $ normalizeType retType
TCallback _ -> t
TObj _ -> t
TObjToHeap _ -> t
TConst (TConst t') -> normalizeType $ TConst t'
TConst _ -> t
stripConst :: Type -> Type
stripConst t = case t of
TConst t' -> stripConst t'
_ -> t
data Variable = Variable
{ varIdentifier :: Identifier
, varExtName :: ExtName
, varType :: Type
, varReqs :: Reqs
, varAddendum :: Addendum
}
instance Eq Variable where
(==) = (==) `on` varIdentifier
instance Show Variable where
show v = concat ["<Variable ", show (varExtName v), " ", show (varType 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
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
}
instance Eq CppEnum where
(==) = (==) `on` enumIdentifier
instance Show CppEnum where
show e = concat ["<Enum ", show (enumExtName e), " ", show (enumIdentifier e), ">"]
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 =
CppEnum identifier (extNameOrIdentifier identifier maybeExtName) valueNames mempty mempty
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
}
instance Eq Bitspace where
(==) = (==) `on` bitspaceExtName
instance Show Bitspace where
show e = concat ["<Bitspace ", show (bitspaceExtName e), " ", show (bitspaceType e), ">"]
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
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
, fnAddendum :: Addendum
}
instance Show Function where
show fn =
concat ["<Function ", show (fnExtName fn), " ", show (fnCName fn),
show (fnParams fn), " ", show (fnReturn fn), ">"]
instance HasReqs Function where
getReqs = fnReqs
setReqs reqs fn = fn { fnReqs = reqs }
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
data Class = Class
{ classIdentifier :: Identifier
, classExtName :: ExtName
, classSuperclasses :: [Class]
, classCtors :: [Ctor]
, classDtorIsPublic :: Bool
, classMethods :: [Method]
, classConversion :: ClassConversion
, classReqs :: Reqs
, classAddendum :: Addendum
, classIsMonomorphicSuperclass :: Bool
, classIsSubclassOfMonomorphic :: Bool
}
instance Eq Class where
(==) = (==) `on` classIdentifier
instance Show Class where
show cls =
concat ["<Class ", show (classExtName cls), " ", show (classIdentifier 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]
-> [Ctor]
-> [Method]
-> Class
makeClass identifier maybeExtName supers ctors methods = Class
{ classIdentifier = identifier
, classExtName = extNameOrIdentifier identifier maybeExtName
, classSuperclasses = supers
, classCtors = ctors
, classDtorIsPublic = True
, classMethods = methods
, classConversion = classConversionNone
, classReqs = mempty
, classAddendum = mempty
, classIsMonomorphicSuperclass = False
, classIsSubclassOfMonomorphic = False
}
classAddCtors :: [Ctor] -> Class -> Class
classAddCtors ctors cls =
if null ctors then cls else cls { classCtors = classCtors cls ++ ctors }
classSetDtorPrivate :: Class -> Class
classSetDtorPrivate cls = cls { classDtorIsPublic = False }
classSetMonomorphicSuperclass :: Class -> Class
classSetMonomorphicSuperclass cls = cls { classIsMonomorphicSuperclass = True }
classSetSubclassOfMonomorphic :: Class -> Class
classSetSubclassOfMonomorphic cls = cls { classIsSubclassOfMonomorphic = True }
classAddMethods :: [Method] -> Class -> Class
classAddMethods methods cls =
if null methods then cls else cls { classMethods = classMethods cls ++ methods }
data ClassConversion = ClassConversion
{ classHaskellConversion :: Maybe ClassHaskellConversion
}
classConversionNone :: ClassConversion
classConversionNone = ClassConversion Nothing
classModifyConversion :: (ClassConversion -> ClassConversion) -> Class -> Class
classModifyConversion f cls = cls { classConversion = f $ classConversion cls }
data ClassHaskellConversion = ClassHaskellConversion
{ classHaskellConversionType :: Haskell.Generator HsType
, classHaskellConversionToCppFn :: Haskell.Generator ()
, classHaskellConversionFromCppFn :: Haskell.Generator ()
}
class HasClassyExtName a where
getClassyExtNameSuffix :: a -> ExtName
getClassyExtName :: Class -> a -> ExtName
getClassyExtName cls x =
toExtName $ concat [fromExtName $ classExtName cls, "_", fromExtName $ getClassyExtNameSuffix x]
data Ctor = Ctor
{ ctorExtName :: ExtName
, ctorParams :: [Type]
}
instance Show Ctor where
show ctor = concat ["<Ctor ", show (ctorExtName ctor), " ", show (ctorParams ctor), ">"]
instance HasClassyExtName Ctor where
getClassyExtNameSuffix = ctorExtName
makeCtor :: ExtName
-> [Type]
-> Ctor
makeCtor = Ctor
mkCtor :: String
-> [Type]
-> Ctor
mkCtor = makeCtor . toExtName
data Method = Method
{ methodImpl :: MethodImpl
, methodExtName :: ExtName
, methodApplicability :: MethodApplicability
, methodPurity :: Purity
, methodParams :: [Type]
, methodReturn :: Type
}
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 HasClassyExtName Method where
getClassyExtNameSuffix = 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
-> Method
makeMethod name = Method $ RealMethod $ toFnName name
makeFnMethod :: IsFnName Identifier name
=> name
-> String
-> MethodApplicability
-> Purity
-> [Type]
-> Type
-> Method
makeFnMethod cName foreignName = Method (FnMethod $ toFnName cName) (toExtName foreignName)
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
-> Method
mkMethod name = makeMethod' name MNormal Nonpure
mkMethod' :: IsFnName String name
=> name
-> String
-> [Type]
-> Type
-> Method
mkMethod' cName foreignName = makeMethod'' cName foreignName MNormal Nonpure
mkConstMethod :: IsFnName String name => name -> [Type] -> Type -> Method
mkConstMethod name = makeMethod' name MConst Nonpure
mkConstMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> Method
mkConstMethod' cName foreignName = makeMethod'' cName foreignName MConst Nonpure
mkStaticMethod :: IsFnName String name => name -> [Type] -> Type -> Method
mkStaticMethod name = makeMethod' name MStatic Nonpure
mkStaticMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> Method
mkStaticMethod' cName foreignName = makeMethod'' cName foreignName MStatic Nonpure
mkProps :: [[Method]] -> [Method]
mkProps = concat
mkProp :: String -> Type -> [Method]
mkProp name t =
let c:cs = name
setName = 's' : 'e' : 't' : toUpper c : cs
in [ mkConstMethod name [] t
, mkMethod setName [t] TVoid
]
mkStaticProp :: String -> Type -> [Method]
mkStaticProp name t =
let c:cs = name
setName = 's' : 'e' : 't' : toUpper c : cs
in [ mkStaticMethod name [] t
, mkStaticMethod setName [t] TVoid
]
mkBoolIsProp :: String -> [Method]
mkBoolIsProp name =
let c:cs = name
name' = toUpper c : cs
isName = 'i':'s':name'
setName = 's':'e':'t':name'
in [ mkConstMethod isName [] TBool
, mkMethod setName [TBool] TVoid
]
mkBoolHasProp :: String -> [Method]
mkBoolHasProp name =
let c:cs = name
name' = toUpper c : cs
hasName = 'h':'a':'s':name'
setName = 's':'e':'t':name'
in [ mkConstMethod hasName [] TBool
, mkMethod setName [TBool] TVoid
]
data Callback = Callback
{ callbackExtName :: ExtName
, callbackParams :: [Type]
, callbackReturn :: Type
, 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 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 mempty mempty
callbackToTFn :: Callback -> Type
callbackToTFn = TFn <$> callbackParams <*> callbackReturn
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"
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"
hsImportForPrelude :: HsImportSet
hsImportForPrelude = hsQualifiedImport "Prelude" "HoppyP"
hsImportForRuntime :: HsImportSet
hsImportForRuntime = hsQualifiedImport "Foreign.Hoppy.Runtime" "HoppyFHR"
hsImportForSystemPosixTypes :: HsImportSet
hsImportForSystemPosixTypes = hsQualifiedImport "System.Posix.Types" "HoppySPT"
hsImportForUnsafeIO :: HsImportSet
hsImportForUnsafeIO = hsQualifiedImport "System.IO.Unsafe" "HoppySIU"
tObjToHeapWrongDirectionErrorMsg :: Maybe String -> Class -> String
tObjToHeapWrongDirectionErrorMsg maybeCaller cls =
concat [maybe "" (++ ": ") maybeCaller,
"(TObjToHeap ", show cls, ") cannot be passed into C++",
maybe "" (const ".") maybeCaller]