{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
module Foreign.Hoppy.Generator.Spec.Base (
ErrorMsg,
Interface,
InterfaceOptions (..),
defaultInterfaceOptions,
interface,
interface',
interfaceName,
interfaceModules,
interfaceNamesToModules,
interfaceHaskellModuleBase,
interfaceDefaultHaskellModuleBase,
interfaceAddHaskellModuleBase,
interfaceHaskellModuleImportNames,
interfaceExceptionHandlers,
interfaceCallbacksThrow,
interfaceSetCallbacksThrow,
interfaceExceptionClassId,
interfaceExceptionSupportModule,
interfaceSetExceptionSupportModule,
interfaceSetSharedPtr,
interfaceCompiler,
interfaceSetCompiler,
interfaceSetCompiler',
interfaceSetNoCompiler,
interfaceValidateEnumTypes,
interfaceSetValidateEnumTypes,
interfaceHooks,
interfaceModifyHooks,
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,
extNameOrIdentifier,
extNameOrFnIdentifier,
extNameOrString,
isValidExtName,
fromExtName,
HasExtNames (..),
getAllExtNames,
FnName (..),
IsFnName (..),
Operator (..),
OperatorType (..),
operatorPreferredExtName,
operatorPreferredExtName',
operatorType,
Identifier,
makeIdentifier,
identifierParts,
IdPart,
makeIdPart,
idPartBase,
idPartArgs,
ident, ident', ident1, ident2, ident3, ident4, ident5,
identT, identT', ident1T, ident2T, ident3T, ident4T, ident5T,
Exportable (..),
Export (..),
Type (..),
normalizeType,
stripConst,
Scoped (..),
isScoped,
Constness (..), constNegate,
Purity (..),
Parameter, parameterType, parameterName,
IsParameter (..), toParameters,
np, (~:),
ConversionMethod (..),
ConversionSpec (conversionSpecName, conversionSpecCpp, conversionSpecHaskell),
makeConversionSpec,
ConversionSpecCpp (
ConversionSpecCpp,
conversionSpecCppName,
conversionSpecCppReqs,
conversionSpecCppConversionType,
conversionSpecCppConversionToCppExpr,
conversionSpecCppConversionFromCppExpr
),
makeConversionSpecCpp,
ConversionSpecHaskell (
ConversionSpecHaskell,
conversionSpecHaskellHsType,
conversionSpecHaskellHsArgType,
conversionSpecHaskellCType,
conversionSpecHaskellToCppFn,
conversionSpecHaskellFromCppFn
),
makeConversionSpecHaskell,
ExceptionId (..),
exceptionCatchAllId,
ExceptionHandler (..),
ExceptionHandlers (..),
HandlesExceptions (..),
handleExceptions,
Addendum (..),
HasAddendum (..),
addAddendumHaskell,
EnumInfo (..),
EnumEntryWords,
EnumValueMap (..),
EnumValue (..),
ForeignLanguage (..),
WithForeignLanguageOverrides,
MapWithForeignLanguageOverrides,
HsModuleName, HsImportSet, HsImportKey (..), HsImportSpecs (..), HsImportName, HsImportVal (..),
hsWholeModuleImport, hsQualifiedImport, hsImport1, hsImport1', hsImports, hsImports',
hsImportSetMakeSource,
EvaluatedEnumData (..),
EvaluatedEnumValueMap,
interfaceAllExceptionClasses,
interfaceSharedPtr,
interfaceEvaluatedEnumData,
interfaceGetEvaluatedEnumData,
makeHsImportSet,
getHsImportSet,
hsImportForBits,
hsImportForException,
hsImportForInt,
hsImportForWord,
hsImportForForeign,
hsImportForForeignC,
hsImportForMap,
hsImportForPrelude,
hsImportForRuntime,
hsImportForSystemPosixTypes,
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, put)
import Data.Char (isAlpha, isAlphaNum)
import Data.Function (on)
import Data.List (intercalate, intersperse)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid, mappend, mconcat, mempty)
#endif
import Data.Semigroup as Sem
import qualified Data.Set as S
import Data.Typeable (Typeable, cast)
import Foreign.Hoppy.Generator.Common
import Foreign.Hoppy.Generator.Compiler (Compiler, SomeCompiler (SomeCompiler), defaultCompiler)
import {-# SOURCE #-} Foreign.Hoppy.Generator.Hook (Hooks, defaultHooks)
import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Cpp as LC
import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as LH
import Foreign.Hoppy.Generator.Override (MapWithOverrides, WithOverrides)
import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Class (Class, classExtName)
import GHC.Stack (HasCallStack)
import Language.Haskell.Syntax (HsName, HsQualType, 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
, interfaceSharedPtr :: (Reqs, String)
, interfaceCompiler :: Maybe SomeCompiler
, interfaceHooks :: Hooks
, interfaceEvaluatedEnumData :: Maybe (M.Map ExtName EvaluatedEnumData)
, interfaceValidateEnumTypes :: Bool
}
instance Show Interface where
show iface = concat ["<Interface ", show (interfaceName iface), ">"]
instance HasExports Interface where
lookupExport name iface =
lookupExport name =<< M.lookup name (interfaceNamesToModules iface)
newtype 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 $ \m ->
let extNames = concatMap getAllExtNames $ M.elems $ moduleExports m
in M.fromList $ zip extNames $ repeat [m]
extNamesInMultipleModules :: [(ExtName, [Module])]
extNamesInMultipleModules =
M.toList $
M.filter (\case
_:_:_ -> 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::Int)..] $
\m index -> (m, '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
, interfaceSharedPtr = (reqInclude $ includeStd "memory", "std::shared_ptr")
, interfaceCompiler = Just $ SomeCompiler defaultCompiler
, interfaceHooks = defaultHooks
, interfaceEvaluatedEnumData = Nothing
, interfaceValidateEnumTypes = True
}
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 $ \m ->
catMaybes $
map getExportExceptionClass $
M.elems $ moduleExports m
interfaceSetCallbacksThrow :: Bool -> Interface -> Interface
interfaceSetCallbacksThrow b iface = iface { interfaceCallbacksThrow = b }
interfaceSetExceptionSupportModule :: HasCallStack => Module -> Interface -> Interface
interfaceSetExceptionSupportModule m iface = case interfaceExceptionSupportModule iface of
Nothing -> iface { interfaceExceptionSupportModule = Just m }
Just existingMod ->
if m == existingMod
then iface
else error $ "interfaceSetExceptionSupportModule: " ++ show iface ++
" already has exception support module " ++ show existingMod ++
", trying to set " ++ show m ++ "."
interfaceSetSharedPtr :: String -> Reqs -> Interface -> Interface
interfaceSetSharedPtr identifier reqs iface =
iface { interfaceSharedPtr = (reqs, identifier) }
interfaceSetCompiler :: Compiler a => a -> Interface -> Interface
interfaceSetCompiler = interfaceSetCompiler' . Just . SomeCompiler
interfaceSetCompiler' :: Maybe SomeCompiler -> Interface -> Interface
interfaceSetCompiler' compiler iface = iface { interfaceCompiler = compiler }
interfaceSetNoCompiler :: Interface -> Interface
interfaceSetNoCompiler =
interfaceSetValidateEnumTypes False .
interfaceSetCompiler' Nothing
interfaceSetValidateEnumTypes :: Bool -> Interface -> Interface
interfaceSetValidateEnumTypes validate iface =
iface { interfaceValidateEnumTypes = validate }
interfaceModifyHooks :: (Hooks -> Hooks) -> Interface -> Interface
interfaceModifyHooks f iface =
iface { interfaceHooks = f $ interfaceHooks iface }
interfaceGetEvaluatedEnumData :: HasCallStack => Interface -> ExtName -> EvaluatedEnumData
interfaceGetEvaluatedEnumData iface extName =
case interfaceEvaluatedEnumData iface of
Nothing -> error $ "interfaceGetEvaluatedEnumData: Data have not been " ++
"evaluated for " ++ show iface ++ "."
Just enumMap -> case M.lookup extName enumMap of
Nothing -> error $ "interfaceGetEvaluatedEnumData: No data found for " ++
show extName ++ " in " ++ show iface ++ "."
Just info -> info
newtype 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 HasExports Module where
lookupExport name m = M.lookup name $ moduleExports 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' :: HasCallStack => 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 put 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 -> put 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 }
newtype Reqs = Reqs
{ reqsIncludes :: S.Set Include
} deriving (Show)
instance Sem.Semigroup Reqs where
(<>) (Reqs incl) (Reqs incl') = Reqs $ mappend incl incl'
instance Monoid Reqs where
mempty = Reqs mempty
mappend = (<>)
mconcat reqs = Reqs $ mconcat $ map reqsIncludes reqs
reqInclude :: Include -> Reqs
reqInclude include = mempty { reqsIncludes = S.singleton include }
class HasReqs a where
{-# MINIMAL getReqs, (setReqs | modifyReqs) #-}
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, Sem.Semigroup, Monoid, Ord)
instance Show ExtName where
show extName = concat ["$\"", fromExtName extName, "\"$"]
toExtName :: HasCallStack => 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 :: HasCallStack => Identifier -> Maybe ExtName -> ExtName
extNameOrIdentifier identifier = fromMaybe $ case identifierParts identifier of
[] -> error "extNameOrIdentifier: Invalid empty identifier."
parts -> toExtName $ idPartBase $ last parts
extNameOrFnIdentifier :: HasCallStack => 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 :: HasCallStack => 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 :: HasCallStack => 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."
class HasExports a where
lookupExport :: ExtName -> a -> Maybe Export
newtype Identifier = Identifier
{ identifierParts :: [IdPart]
} deriving (Eq, Monoid, Sem.Semigroup)
instance Show Identifier where
show identifier =
(\wordList -> concat $ "<Identifier " : wordList ++ [">"]) $
intersperse "::" $
map (\part -> case idPartArgs part of
Nothing -> idPartBase part
Just args ->
concat $
idPartBase part : "<" :
intersperse ", " (map show args) ++ [">"]) $
identifierParts identifier
data IdPart = IdPart
{ idPartBase :: String
, idPartArgs :: Maybe [Type]
} deriving (Eq, Show)
makeIdentifier :: [IdPart] -> Identifier
makeIdentifier = Identifier
makeIdPart :: String -> Maybe [Type] -> IdPart
makeIdPart = IdPart
ident :: String -> Identifier
ident a = Identifier [IdPart a Nothing]
ident' :: [String] -> Identifier
ident' = Identifier . map (\x -> IdPart { idPartBase = x, idPartArgs = 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]
class (HasAddendum a, HasExtNames a, HasReqs a, Typeable a, Show a) => Exportable a where
toExport :: a -> Export
toExport = Export
castExport :: (Typeable a, Exportable b, Typeable b) => a -> Maybe b
castExport = cast
sayExportCpp :: LC.SayExportMode -> a -> LC.Generator ()
sayExportHaskell :: LH.SayExportMode -> a -> LH.Generator ()
getExportEnumInfo :: a -> Maybe EnumInfo
getExportEnumInfo _ = Nothing
getExportExceptionClass :: a -> Maybe Class
getExportExceptionClass _ = Nothing
data Export = forall a. Exportable a => Export a
instance HasAddendum Export where
getAddendum (Export e) = getAddendum e
setAddendum a (Export e) = Export $ setAddendum a e
modifyAddendum f (Export e) = Export $ modifyAddendum f e
instance HasExtNames Export where
getPrimaryExtName (Export e) = getPrimaryExtName e
getNestedExtNames (Export e) = getNestedExtNames e
instance HasReqs Export where
getReqs (Export e) = getReqs e
setReqs reqs (Export e) = Export $ setReqs reqs e
modifyReqs f (Export e) = Export $ modifyReqs f e
instance Exportable Export where
toExport = id
castExport (Export e) = castExport e
sayExportCpp sayBody (Export e) = sayExportCpp sayBody e
sayExportHaskell mode (Export e) = sayExportHaskell mode e
getExportEnumInfo (Export e) = getExportEnumInfo e
getExportExceptionClass (Export e) = getExportExceptionClass e
instance Show Export where
show (Export e) = "<Export " ++ show e ++ ">"
data Type =
Internal_TVoid
| Internal_TPtr Type
| Internal_TRef Type
| Internal_TFn [Parameter] Type
| Internal_TObj Class
| Internal_TObjToHeap Class
| Internal_TToGc Type
| Internal_TManual ConversionSpec
| Internal_TConst Type
deriving (Show)
instance Eq Type where
Internal_TVoid == Internal_TVoid = True
(Internal_TPtr t) == (Internal_TPtr t') = t == t'
(Internal_TRef t) == (Internal_TRef t') = t == t'
(Internal_TFn ps r) == (Internal_TFn ps' r') =
(and $ zipWith ((==) `on` parameterType) ps ps') && r == r'
(Internal_TObj cls) == (Internal_TObj cls') = cls == cls'
(Internal_TObjToHeap cls) == (Internal_TObjToHeap cls') = cls == cls'
(Internal_TToGc t) == (Internal_TToGc t') = t == t'
(Internal_TManual s) == (Internal_TManual s') = s == s'
(Internal_TConst t) == (Internal_TConst t') = t == t'
_ == _ = False
normalizeType :: Type -> Type
normalizeType t = case t of
Internal_TVoid -> t
Internal_TPtr t' -> Internal_TPtr $ normalizeType t'
Internal_TRef t' -> Internal_TRef $ normalizeType t'
Internal_TFn params retType ->
Internal_TFn (map (onParameterType normalizeType) params) $ normalizeType retType
Internal_TObj _ -> t
Internal_TObjToHeap _ -> t
Internal_TToGc _ -> t
Internal_TManual _ -> 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 Scoped =
Unscoped
| Scoped
deriving (Eq, Ord, Show)
isScoped :: Scoped -> Bool
isScoped Unscoped = False
isScoped Scoped = True
data Constness = Nonconst | Const
deriving (Bounded, Enum, Eq, Show)
constNegate :: Constness -> Constness
constNegate Nonconst = Const
constNegate Const = Nonconst
data Purity = Nonpure
| Pure
deriving (Eq, Show)
data Parameter = Parameter
{ parameterType :: Type
, parameterName :: Maybe String
} deriving (Show)
class Show a => IsParameter a where
toParameter :: a -> Parameter
instance IsParameter Parameter where
toParameter = id
instance IsParameter Type where
toParameter t =
Parameter
{ parameterType = t
, parameterName = Nothing
}
onParameterType :: (Type -> Type) -> (Parameter -> Parameter)
onParameterType f p = p { parameterType = f $ parameterType p }
np :: [Parameter]
np = []
toParameters :: IsParameter a => [a] -> [Parameter]
toParameters = map toParameter
(~:) :: IsParameter a => String -> a -> Parameter
(~:) name param =
(toParameter param) { parameterName = if null name then Nothing else Just name }
infixr 0 ~:
data ConversionMethod c =
ConversionUnsupported
| BinaryCompatible
| CustomConversion c
deriving (Show)
data ConversionSpec = ConversionSpec
{ conversionSpecName :: String
, conversionSpecCpp :: ConversionSpecCpp
, conversionSpecHaskell :: Maybe ConversionSpecHaskell
}
instance Eq ConversionSpec where
(==) = (==) `on` conversionSpecName
instance Show ConversionSpec where
show x = "<ConversionSpec " ++ show (conversionSpecName x) ++ ">"
makeConversionSpec ::
String
-> ConversionSpecCpp
-> ConversionSpec
makeConversionSpec name cppSpec =
ConversionSpec
{ conversionSpecName = name
, conversionSpecCpp = cppSpec
, conversionSpecHaskell = Nothing
}
data ConversionSpecCpp = ConversionSpecCpp
{ conversionSpecCppName :: String
, conversionSpecCppReqs :: LC.Generator Reqs
, conversionSpecCppConversionType :: LC.Generator (Maybe Type)
, conversionSpecCppConversionToCppExpr ::
Maybe (LC.Generator () -> Maybe (LC.Generator ()) -> LC.Generator ())
, conversionSpecCppConversionFromCppExpr ::
Maybe (LC.Generator () -> Maybe (LC.Generator ()) -> LC.Generator ())
}
makeConversionSpecCpp :: String -> LC.Generator Reqs -> ConversionSpecCpp
makeConversionSpecCpp cppName cppReqs =
ConversionSpecCpp
{ conversionSpecCppName = cppName
, conversionSpecCppReqs = cppReqs
, conversionSpecCppConversionType = return Nothing
, conversionSpecCppConversionToCppExpr = Nothing
, conversionSpecCppConversionFromCppExpr = Nothing
}
data ConversionSpecHaskell = ConversionSpecHaskell
{ conversionSpecHaskellHsType :: LH.Generator HsType
, conversionSpecHaskellHsArgType :: Maybe (HsName -> LH.Generator HsQualType)
, conversionSpecHaskellCType :: Maybe (LH.Generator HsType)
, conversionSpecHaskellToCppFn :: ConversionMethod (LH.Generator ())
, conversionSpecHaskellFromCppFn :: ConversionMethod (LH.Generator ())
}
makeConversionSpecHaskell ::
LH.Generator HsType
-> Maybe (LH.Generator HsType)
-> ConversionMethod (LH.Generator ())
-> ConversionMethod (LH.Generator ())
-> ConversionSpecHaskell
makeConversionSpecHaskell hsType cType toCppFn fromCppFn =
ConversionSpecHaskell
{ conversionSpecHaskellHsType = hsType
, conversionSpecHaskellHsArgType = Nothing
, conversionSpecHaskellCType = cType
, conversionSpecHaskellToCppFn = toCppFn
, conversionSpecHaskellFromCppFn = fromCppFn
}
data EvaluatedEnumData = EvaluatedEnumData
{ evaluatedEnumType :: Type
, evaluatedEnumValueMap :: EvaluatedEnumValueMap
}
type EvaluatedEnumValueMap = M.Map [String] Integer
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)
newtype ExceptionHandlers = ExceptionHandlers
{ exceptionHandlersList :: [ExceptionHandler]
}
instance Sem.Semigroup ExceptionHandlers where
(<>) e1 e2 =
ExceptionHandlers $ exceptionHandlersList e1 ++ exceptionHandlersList e2
instance Monoid ExceptionHandlers where
mempty = ExceptionHandlers []
mappend = (<>)
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 Addendum = Addendum
{ addendumHaskell :: LH.Generator ()
}
instance Sem.Semigroup Addendum where
(<>) (Addendum a) (Addendum b) = Addendum $ a >> b
instance Monoid Addendum where
mempty = Addendum $ return ()
mappend = (<>)
class HasAddendum a where
{-# MINIMAL getAddendum, (setAddendum | modifyAddendum) #-}
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 => LH.Generator () -> a -> a
addAddendumHaskell gen = modifyAddendum $ \addendum ->
addendum `mappend` mempty { addendumHaskell = gen }
data EnumInfo = EnumInfo
{ enumInfoExtName :: ExtName
, enumInfoIdentifier :: Identifier
, enumInfoNumericType :: Maybe Type
, enumInfoReqs :: Reqs
, enumInfoScoped :: Scoped
, enumInfoValues :: EnumValueMap
}
type EnumEntryWords = [String]
data EnumValueMap = EnumValueMap
{ enumValueMapNames :: [EnumEntryWords]
, enumValueMapForeignNames :: MapWithForeignLanguageOverrides EnumEntryWords EnumEntryWords
, enumValueMapValues :: M.Map EnumEntryWords EnumValue
}
instance Eq EnumValueMap where
(==) = (==) `on` enumValueMapValues
instance Show EnumValueMap where
show x = "<EnumValueMap values=" ++ show (enumValueMapValues x) ++ ">"
data EnumValue =
EnumValueManual Integer
| EnumValueAuto Identifier
deriving (Eq, Show)
data ForeignLanguage =
Haskell
deriving (Eq, Ord, Show)
type WithForeignLanguageOverrides = WithOverrides ForeignLanguage
type MapWithForeignLanguageOverrides = MapWithOverrides ForeignLanguage
data HsImportSet = HsImportSet
{ getHsImportSet :: M.Map HsImportKey HsImportSpecs
} deriving (Show)
instance Sem.Semigroup HsImportSet where
(<>) (HsImportSet m) (HsImportSet m') =
HsImportSet $ M.unionWith mergeImportSpecs m m'
instance Monoid HsImportSet where
mempty = HsImportSet M.empty
mappend = (<>)
mconcat sets =
HsImportSet $ M.unionsWith mergeImportSpecs $ map getHsImportSet sets
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 x, HsImportValSome x') -> HsImportValSome $ x ++ x'
(x@(HsImportValSome _), _) -> x
(_, x@(HsImportValSome _)) -> x
(HsImportVal, HsImportVal) -> HsImportVal
type HsImportName = String
data HsImportVal =
HsImportVal
| HsImportValSome [HsImportName]
| HsImportValAll
deriving (Show)
hsWholeModuleImport :: HsModuleName -> HsImportSet
hsWholeModuleImport modName =
HsImportSet $ M.singleton (HsImportKey modName Nothing) $
HsImportSpecs Nothing False
hsQualifiedImport :: HsModuleName -> HsModuleName -> HsImportSet
hsQualifiedImport modName qualifiedName =
HsImportSet $ M.singleton (HsImportKey modName $ Just qualifiedName) $
HsImportSpecs Nothing False
hsImport1 :: HsModuleName -> HsImportName -> HsImportSet
hsImport1 modName valueName = hsImport1' modName valueName HsImportVal
hsImport1' :: HsModuleName -> HsImportName -> HsImportVal -> HsImportSet
hsImport1' modName valueName valueType =
HsImportSet $ M.singleton (HsImportKey modName Nothing) $
HsImportSpecs (Just $ M.singleton valueName valueType) False
hsImports :: HsModuleName -> [HsImportName] -> HsImportSet
hsImports modName names =
hsImports' modName $ map (\name -> (name, HsImportVal)) names
hsImports' :: HsModuleName -> [(HsImportName, HsImportVal)] -> HsImportSet
hsImports' modName values =
HsImportSet $ M.singleton (HsImportKey modName 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"
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]