diff --git a/hoppy-generator.cabal b/hoppy-generator.cabal --- a/hoppy-generator.cabal +++ b/hoppy-generator.cabal @@ -1,5 +1,5 @@ name: hoppy-generator -version: 0.3.3 +version: 0.3.4 synopsis: C++ FFI generator - Code generator homepage: http://khumba.net/projects/hoppy license: AGPL-3 diff --git a/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs b/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs --- a/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs +++ b/src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs @@ -234,10 +234,7 @@ unless (classIsSubclassOfMonomorphic cls) $ forM_ (classSuperclasses cls) $ genDowncastFns cls - ExportCallback cb -> do - -- Need for std::shared_ptr. - addReqsM $ callbackReqs cb `mappend` reqInclude (includeStd "memory") - sayExportCallback sayBody cb + ExportCallback cb -> sayExportCallback sayBody cb where genUpcastFns :: Class -> Class -> Generator () genUpcastFns cls ancestorCls = do @@ -576,9 +573,11 @@ let paramCTypes = zipWith fromMaybe paramTypes $ map typeToCType paramTypes retCType = fromMaybe retType $ typeToCType retType - addReqsM . mconcat =<< mapM typeReqs (retType:paramTypes) + -- Add requirements specified manually by the callback, and for its parameter + -- and return types. + addReqsM . mconcat . (callbackReqs cb:) =<< mapM typeReqs (retType:paramTypes) - let fnCType = fnT ((if throws then ([ptrT intT, ptrT $ ptrT voidT] ++) else id) + let fnCType = fnT ((if throws then (++ [ptrT intT, ptrT $ ptrT voidT]) else id) paramCTypes) retCType fnPtrCType = ptrT fnCType @@ -586,7 +585,8 @@ if not sayBody then do -- Render the class declarations into the header file. - addInclude $ includeStd "memory" -- Needed for std::shared_ptr. + (sharedPtrReqs, sharedPtrStr) <- interfaceSharedPtr <$> askInterface + addReqsM sharedPtrReqs says ["\nclass ", implClassName, " {\n"] say "public:\n" @@ -610,7 +610,7 @@ say " " >> sayVar "operator()" Nothing fnType >> say ";\n" say " operator bool() const;\n" say "private:\n" - says [" std::shared_ptr<", implClassName, "> impl_;\n"] + says [" ", sharedPtrStr, "<", implClassName, "> impl_;\n"] say "};\n" else do @@ -663,14 +663,19 @@ "module. Please use interfaceSetExceptionSupportModule." -- Invoke the function pointer into foreign code. - let sayCall = do + let -- | Generates the call to the foreign language function pointer. + sayCall :: Generator () + sayCall = do say "f_(" + sayArgNames paramCount when throws $ do - says ["&", exceptionIdArgName, ", &", exceptionPtrArgName] when (paramCount /= 0) $ say ", " - sayArgNames paramCount + says ["&", exceptionIdArgName, ", &", exceptionPtrArgName] say ")" + -- | Generates code to check whether an exception was thrown by the + -- callback, and rethrows it in C++ if so. + sayExceptionCheck :: Generator () sayExceptionCheck = when throws $ do says ["if (", exceptionIdArgName, " != 0) { ", exceptionRethrowFnName, "(", exceptionIdArgName, ", ", @@ -698,20 +703,20 @@ (Internal_TObj cls1, Just retCType@(Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) | cls1 == cls2 -> do sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n" + sayExceptionCheck sayVar "result" Nothing retType >> say " = *resultPtr;\n" say "delete resultPtr;\n" - sayExceptionCheck say "return result;\n" (Internal_TRef (Internal_TConst (Internal_TObj cls1)), Just (Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) | cls1 == cls2 -> do - sayVar "result" Nothing retType >> say " = *" >> sayCall >> say ";\n" + sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n" sayExceptionCheck - say "return result;\n" + say "return *resultPtr;\n" (Internal_TRef (Internal_TObj cls1), Just (Internal_TPtr (Internal_TObj cls2))) | cls1 == cls2 -> do - sayVar "result" Nothing retType >> say " = *" >> sayCall >> say ";\n" + sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n" sayExceptionCheck - say "return result;\n" + say "return *resultPtr;\n" ts -> abort $ concat ["sayExportCallback: Unexpected return types ", show ts, "."] diff --git a/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs b/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs --- a/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs +++ b/src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs @@ -343,8 +343,9 @@ ln saysLn ["instance ", className, " (", prettyPrint hsCNumType, ") where"] indent $ saysLn [toFnName, " = ", hsTypeName] - saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ") where"] - indent $ saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral"] + when (hsHsNumType /= hsCNumType) $ do + saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ") where"] + indent $ saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral"] saysLn ["instance ", className, " ", hsTypeName, " where"] indent $ saysLn [toFnName, " = HoppyP.id"] @@ -362,7 +363,7 @@ ln forM_ values $ \(num, valueName) -> do addExport valueName - saysLn [valueName, " = ", hsTypeName, " ", show num] + saysLn [valueName, " = ", hsTypeName, " (", show num, ")"] SayExportBoot -> do hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace @@ -387,7 +388,8 @@ saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType] ln saysLn ["instance ", className, " (", prettyPrint hsCNumType, ")"] - saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ")"] + when (hsHsNumType /= hsCNumType) $ + saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ")"] saysLn ["instance ", className, " ", hsTypeName] forM_ (bitspaceEnum bitspace) $ \enum -> do enumTypeName <- toHsEnumTypeName enum @@ -446,18 +448,21 @@ forM_ (zip3 paramTypes argNames convertedArgNames) $ \(t, argName, argName') -> sayArgProcessing ToCpp t argName argName' - when catches $ do - iface <- askInterface - currentModule <- askModule - let exceptionSupportModule = interfaceExceptionSupportModule iface - when (exceptionSupportModule /= Just currentModule) $ - addImports . hsWholeModuleImport . getModuleName iface =<< - fromMaybeM (throwError "Internal error, an exception support module is not available") - exceptionSupportModule - addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForRuntime] - sayLn "HoppyFHR.internalHandleExceptions exceptionDb' $" + exceptionHandling <- + if catches + then do iface <- askInterface + currentModule <- askModule + let exceptionSupportModule = interfaceExceptionSupportModule iface + when (exceptionSupportModule /= Just currentModule) $ + addImports . hsWholeModuleImport . getModuleName iface =<< + fromMaybeM (throwError + "Internal error, an exception support module is not available") + exceptionSupportModule + addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForRuntime] + return "HoppyFHR.internalHandleExceptions exceptionDb' $" + else return "" - let callWords = hsFnImportedName : map (' ':) convertedArgNames + let callWords = exceptionHandling : hsFnImportedName : map (' ':) convertedArgNames sayCallAndProcessReturn ToCpp retType callWords SayExportBoot -> @@ -549,6 +554,7 @@ SayExportDecls -> do addExports [hsNewFunPtrFnName, hsCtorName] + -- Generate the *_newFunPtr function. wholeNewFunPtrFnType <- getWholeNewFunPtrFnType let paramCount = length paramTypes argNames = map toArgName [1..paramCount] @@ -559,7 +565,7 @@ ln saysLn [hsNewFunPtrFnName, " :: ", prettyPrint wholeNewFunPtrFnType] saysLn $ hsNewFunPtrFnName : " f'hs = " : hsCtorName'newFunPtr : " $" : - case (if throws then (["excIdPtr", "excPtrPtr"] ++) else id) argNames of + case (if throws then (++ ["excIdPtr", "excPtrPtr"]) else id) argNames of [] -> [] argNames' -> [" \\", unwords argNames', " ->"] indent $ do @@ -569,6 +575,7 @@ sayCallAndProcessReturn FromCpp retType $ "f'hs" : map (' ':) argNames' + -- Generate the *_new function. wholeCtorType <- getWholeCtorType ln saysLn [hsCtorName, " :: ", prettyPrint wholeCtorType] diff --git a/src/Foreign/Hoppy/Generator/Main.hs b/src/Foreign/Hoppy/Generator/Main.hs --- a/src/Foreign/Hoppy/Generator/Main.hs +++ b/src/Foreign/Hoppy/Generator/Main.hs @@ -34,14 +34,16 @@ module Foreign.Hoppy.Generator.Main ( Action (..), defaultMain, + defaultMain', run, ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar) -import Control.Monad ((<=<), unless, when) +import Control.Arrow ((&&&)) +import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar, readMVar) +import Control.Monad ((<=<), forM, unless, when) import Data.Foldable (forM_) import Data.List (intercalate) import qualified Data.Map as M @@ -59,7 +61,9 @@ -- | Actions that can be requested of the program. data Action = - ListInterfaces + SelectInterface String + -- ^ Sets the interface that will be used for subsequent actions. + | ListInterfaces -- ^ Lists the interfaces compiled into the generator. | ListCppFiles -- ^ Lists the generated files in C++ bindings. @@ -71,14 +75,14 @@ -- ^ Generates Haskell bindings for an interface in the given location. data AppState = AppState - { appInterfaces :: [Interface] + { appInterfaces :: Map String Interface , appCurrentInterface :: Interface , appCaches :: Caches } initialAppState :: [Interface] -> AppState initialAppState ifaces = AppState - { appInterfaces = ifaces + { appInterfaces = M.fromList $ map (interfaceName &&& id) ifaces , appCurrentInterface = head ifaces , appCaches = M.empty } @@ -115,17 +119,24 @@ -- main = defaultMain $ 'interface' ... -- @ -- --- Refer to 'run' for how to use the command-line interface. +-- Refer to 'run' for how to use the command-line interface. Use 'defaultMain'' +-- if you want to include multiple interfaces in your generator. defaultMain :: Either String Interface -> IO () -defaultMain interfaceResult = case interfaceResult of - Left errorMsg -> do - hPutStrLn stderr $ "Error initializing interface: " ++ errorMsg - exitFailure - Right iface -> do - args <- getArgs - _ <- run [iface] args - return () +defaultMain interfaceResult = defaultMain' [interfaceResult] +-- | This is a version of 'defaultMain' that accepts multiple interfaces. +defaultMain' :: [Either String Interface] -> IO () +defaultMain' interfaceResults = do + interfaces <- forM interfaceResults $ \interfaceResult -> case interfaceResult of + Left errorMsg -> do + hPutStrLn stderr $ "Error initializing interface: " ++ errorMsg + exitFailure + Right iface -> return iface + + args <- getArgs + _ <- run interfaces args + return () + -- | @run interfaces args@ runs the driver with the command-line arguments from -- @args@ against the listed interfaces, and returns the list of actions -- performed. @@ -137,6 +148,9 @@ -- -- - __@--list-interfaces@:__ Lists the interfaces compiled into the generator. -- +-- - __@--interface \@:__ Sets the interface that will be used for +-- subsequent arguments. +-- -- - __@--gen-cpp \@:__ Generates C++ bindings in the given directory. -- -- - __@--gen-hs \@:__ Generates Haskell bindings under the given @@ -146,6 +160,8 @@ stateVar <- newMVar $ initialAppState interfaces when (null args) $ do putStrLn "This is a Hoppy interface generator. Use --help for options." + putStrLn "" + putStrLn $ "Interfaces: " ++ unwords (map interfaceName interfaces) exitSuccess when ("--help" `elem` args) $ usage stateVar >> exitSuccess processArgs stateVar args @@ -160,6 +176,7 @@ , "" , "Supported options:" , " --help Displays this menu." + , " --interface Sets the interface used for subsequent options." , " --list-interfaces Lists the interfaces compiled into this binary." , " --list-cpp-files Lists generated file paths in C++ bindings." , " --list-hs-files Lists generated file paths in Haskell bindings." @@ -173,6 +190,17 @@ case args of [] -> return [] + "--interface":name:rest -> do + modifyMVar_ stateVar $ \state -> + case M.lookup name $ appInterfaces state of + Nothing -> do + hPutStrLn stderr $ + "--interface: Interface '" ++ name ++ "' doesn't exist in this generator." + _ <- exitFailure + return state + Just iface -> return state { appCurrentInterface = iface } + (SelectInterface name:) <$> processArgs stateVar rest + "--list-interfaces":rest -> do listInterfaces stateVar (ListInterfaces:) <$> processArgs stateVar rest @@ -181,7 +209,7 @@ genResult <- withCurrentCache stateVar getGeneratedCpp case genResult of Left errorMsg -> do - putStrLn $ "--list-cpp-files: Failed to generate: " ++ errorMsg + hPutStrLn stderr $ "--list-cpp-files: Failed to generate: " ++ errorMsg exitFailure Right gen -> do mapM_ putStrLn $ M.keys $ Cpp.generatedFiles gen @@ -191,7 +219,7 @@ genResult <- withCurrentCache stateVar getGeneratedHaskell case genResult of Left errorMsg -> do - putStrLn $ "--list-hs-files: Failed to generate: " ++ errorMsg + hPutStrLn stderr $ "--list-hs-files: Failed to generate: " ++ errorMsg exitFailure Right gen -> do mapM_ putStrLn $ M.keys $ Haskell.generatedFiles gen @@ -207,7 +235,7 @@ genResult <- withCurrentCache stateVar getGeneratedCpp case genResult of Left errorMsg -> do - putStrLn $ "--gen-cpp: Failed to generate: " ++ errorMsg + hPutStrLn stderr $ "--gen-cpp: Failed to generate: " ++ errorMsg exitFailure Right gen -> do forM_ (M.toList $ Cpp.generatedFiles gen) $ @@ -224,7 +252,7 @@ genResult <- withCurrentCache stateVar getGeneratedHaskell case genResult of Left errorMsg -> do - putStrLn $ "--gen-hs: Failed to generate: " ++ errorMsg + hPutStrLn stderr $ "--gen-hs: Failed to generate: " ++ errorMsg exitFailure Right gen -> do forM_ (M.toList $ Haskell.generatedFiles gen) $ @@ -232,7 +260,7 @@ (GenHaskell baseDir:) <$> processArgs stateVar rest arg:_ -> do - putStrLn $ "Invalid option or missing argument for " ++ arg ++ "." + hPutStrLn stderr $ "Invalid option or missing argument for '" ++ arg ++ "'." exitFailure writeGeneratedFile :: FilePath -> FilePath -> String -> IO () @@ -252,7 +280,7 @@ return (state { appCaches = M.insert name cache $ appCaches state }, result) listInterfaces :: MVar AppState -> IO () -listInterfaces = mapM_ (putStrLn . interfaceName) . appInterfaces <=< readMVar +listInterfaces = mapM_ (putStrLn . interfaceName) <=< getInterfaces getInterfaces :: MVar AppState -> IO [Interface] -getInterfaces = fmap appInterfaces . readMVar +getInterfaces = fmap (M.elems . appInterfaces) . readMVar diff --git a/src/Foreign/Hoppy/Generator/Spec/Base.hs b/src/Foreign/Hoppy/Generator/Spec/Base.hs --- a/src/Foreign/Hoppy/Generator/Spec/Base.hs +++ b/src/Foreign/Hoppy/Generator/Spec/Base.hs @@ -38,6 +38,7 @@ interfaceExceptionClassId, interfaceExceptionSupportModule, interfaceSetExceptionSupportModule, + interfaceSetSharedPtr, -- * C++ includes Include, includeStd, @@ -175,6 +176,7 @@ hsImportSetMakeSource, -- * Internal to Hoppy interfaceAllExceptionClasses, + interfaceSharedPtr, classFindCopyCtor, -- ** Haskell imports makeHsImportSet, @@ -255,6 +257,10 @@ -- ^ When an interface uses C++ exceptions, then one module needs to -- manually be selected to contain some interface-specific runtime support. -- This is the selected module. + , interfaceSharedPtr :: (Reqs, String) + -- ^ The name of the @shared_ptr@ class to use, and the requirements to use + -- it. This defaults to using @std::shared_ptr@ from @@, but can be + -- changed if necessary via 'interfaceSetSharedPtr'. } instance Show Interface where @@ -333,6 +339,7 @@ , interfaceCallbacksThrow = False , interfaceExceptionNamesToIds = exceptionNamesToIds , interfaceExceptionSupportModule = Nothing + , interfaceSharedPtr = (reqInclude $ includeStd "memory", "std::shared_ptr") } -- | The name of the parent Haskell module under which a Haskell module will be @@ -399,6 +406,29 @@ " already has exception support module " ++ show existingMod ++ ", trying to set " ++ show mod ++ "." +-- | Installs a custom @std::shared_ptr@ implementation for use by an interface. +-- Hoppy uses shared pointers for generated callback code. This function is +-- useful for building code with compilers that don't provide a conforming +-- @std::shared_ptr@ implementation. +-- +-- @interfaceSetSharedPtr ident reqs iface@ modifies @iface@ to use as a +-- @shared_ptr@ class the C++ identifier @ident@, which needs @reqs@ in order to +-- be accessed. @ident@ should be the name of a template to which an arbitrary +-- @\@ can be appended, for example @"std::shared_ptr"@. +-- +-- A @shared_ptr\@ implementation @foo@ must at least provide the following +-- interface: +-- +-- > foo(); // Initialization with a null pointer. +-- > foo(T*); // Initialization with a given pointer. +-- > foo(const foo&); // Copy-construction. +-- > T& operator*() const; // Dereferencing (when non-null). +-- > T* operator->() const; // Dereferencing and invocation (when non-null). +-- > explicit operator bool() const; // Is the target object null? +interfaceSetSharedPtr :: String -> Reqs -> Interface -> Interface +interfaceSetSharedPtr identifier reqs iface = + iface { interfaceSharedPtr = (reqs, identifier) } + -- | An @#include@ directive in a C++ file. data Include = Include { includeToString :: String @@ -420,9 +450,10 @@ -- generated module will @#include@ everything necessary for what is written to -- the header and source files separately. You can declare include dependencies -- with e.g. 'addReqIncludes', either for individual exports or at the module --- level. Dependencies between modules are handled automatically, and --- circularity is supported to a certain extent. See the documentation for the --- individual language modules for further details. +-- level (via the @'HasReqs' 'Module'@ instance). Dependencies between modules +-- are handled automatically, and circularity is supported to a certain extent. +-- See the documentation for the individual language modules for further +-- details. data Module = Module { moduleName :: String -- ^ The module's name. A module name must identify a unique module within @@ -561,6 +592,11 @@ reqInclude :: Include -> Reqs reqInclude include = mempty { reqsIncludes = S.singleton include } +-- | Contains the data types for bindings to C++ entities: 'Function', 'Class', +-- etc. Use 'addReqs' or 'addReqIncludes' to specify requirements for these +-- entities, e.g. header files that must be included in order to access the +-- underlying entities that are being bound. + -- | C++ types that have requirements in order to use them in generated -- bindings. class HasReqs a where @@ -1041,6 +1077,8 @@ _ -> t -- | A C++ variable. +-- +-- Use this data type's 'HasReqs' instance to make the variable accessible. data Variable = Variable { varIdentifier :: Identifier -- ^ The identifier used to refer to the variable. @@ -1051,7 +1089,7 @@ -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is -- read-only. , varReqs :: Reqs - -- ^ Requirements for bindings to use this variable. + -- ^ Requirements for bindings to access this variable. , varAddendum :: Addendum -- ^ The variable's addendum. } @@ -1106,7 +1144,8 @@ -- is broken up into words. How the words and ext name get combined to make -- a name in a particular foreign language depends on the language. , enumReqs :: Reqs - -- ^ Requirements for a 'Type' to reference this enum. + -- ^ Requirements for bindings to access this enum. Currently unused, but + -- will be in the future. , enumAddendum :: Addendum -- ^ The enum's addendum. , enumValuePrefix :: String @@ -1288,6 +1327,9 @@ deriving (Eq, Show) -- | A C++ function declaration. +-- +-- Use this data type's 'HasReqs' instance to make the function accessible. You +-- do not need to add requirements for parameter or return types. data Function = Function { fnCName :: FnName Identifier -- ^ The identifier used to call the function. @@ -1300,7 +1342,7 @@ , fnReturn :: Type -- ^ The function's return type. , fnReqs :: Reqs - -- ^ Requirements for a binding to call the function. + -- ^ Requirements for bindings to access this function. , fnExceptionHandlers :: ExceptionHandlers -- ^ Exceptions that the function might throw. , fnAddendum :: Addendum @@ -1346,6 +1388,9 @@ -- | A C++ class declaration. See 'IsClassEntity' for more information about the -- interaction between a class's names and the names of entities within the -- class. +-- +-- Use this data type's 'HasReqs' instance to make the class accessible. You do +-- not need to add requirements for methods' parameter or return types. data Class = Class { classIdentifier :: Identifier -- ^ The identifier used to refer to the class. @@ -1360,7 +1405,7 @@ , classConversion :: ClassConversion -- ^ Behaviour for converting objects to and from foriegn values. , classReqs :: Reqs - -- ^ Requirements for a 'Type' to reference this class. + -- ^ Requirements for bindings to access this class. , classAddendum :: Addendum -- ^ The class's addendum. , classIsMonomorphicSuperclass :: Bool @@ -2163,6 +2208,9 @@ -- | A non-C++ function that can be invoked via a C++ functor or function -- pointer. +-- +-- Use this data type's 'HasReqs' instance to add extra requirements, however +-- manually adding requirements for parameter and return types is not necessary. data Callback = Callback { callbackExtName :: ExtName -- ^ The callback's external name. @@ -2175,7 +2223,7 @@ -- C++ during its execution. When absent, the value is inherited from -- 'moduleCallbacksThrow' and 'interfaceCallbacksThrow'. , callbackReqs :: Reqs - -- ^ Requirements for the callback. + -- ^ Extra requirements for the callback. , callbackAddendum :: Addendum -- ^ The callback's addendum. } @@ -2262,30 +2310,6 @@ handleExceptions classes = modifyExceptionHandlers $ mappend mempty {exceptionHandlersList = classes} --- | A collection of imports for a Haskell module. This is a monoid: import --- Statements are merged to give the union of imported bindings. --- --- This structure supports two specific types of imports: --- - @import Foo (...)@ --- - @import qualified Foo as Bar@ --- Imports with @as@ but without @qualified@, and @qualified@ imports with a --- spec list, are not supported. This satisfies the needs of the code --- generator, and keeps the merging logic simple. -newtype HsImportSet = HsImportSet - { getHsImportSet :: M.Map HsImportKey HsImportSpecs - -- ^ Returns the import set's internal map from module names to imported - -- bindings. - } 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 - -- | A literal piece of code that will be inserted into a generated source file -- after the regular binding glue. The 'Monoid' instance concatenates code -- (actions). @@ -2318,6 +2342,30 @@ addAddendumHaskell :: HasAddendum a => Haskell.Generator () -> a -> a addAddendumHaskell gen = modifyAddendum $ \addendum -> addendum `mappend` mempty { addendumHaskell = gen } + +-- | A collection of imports for a Haskell module. This is a monoid: import +-- Statements are merged to give the union of imported bindings. +-- +-- This structure supports two specific types of imports: +-- - @import Foo (...)@ +-- - @import qualified Foo as Bar@ +-- Imports with @as@ but without @qualified@, and @qualified@ imports with a +-- spec list, are not supported. This satisfies the needs of the code +-- generator, and keeps the merging logic simple. +newtype HsImportSet = HsImportSet + { getHsImportSet :: M.Map HsImportKey HsImportSpecs + -- ^ Returns the import set's internal map from module names to imported + -- bindings. + } 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 -- | Constructor for an import set. makeHsImportSet :: M.Map HsImportKey HsImportSpecs -> HsImportSet