hoppy-generator 0.3.3 → 0.3.4

raw patch · 5 files changed

+174/−86 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hoppy-generator.cabal +1/−1
• src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs +21/−16
• src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs +23/−16
• src/Foreign/Hoppy/Generator/Main.hs +49/−21
• src/Foreign/Hoppy/Generator/Spec/Base.hs +80/−32

@@ -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

@@ -234,10 +234,7 @@     unless (classIsSubclassOfMonomorphic cls) $       forM_ (classSuperclasses cls) $ genDowncastFns cls -  ExportCallback cb -> do-    -- Need <memory> 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, "."] 

@@ -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]

@@ -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 \<iface\>@:__ Sets the interface that will be used for+--   subsequent arguments.+-- -- - __@--gen-cpp \<outdir\>@:__ Generates C++ bindings in the given directory. -- -- - __@--gen-hs \<outdir\>@:__ 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 <iface>         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

@@ -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 @<memory>@, 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+-- @\<T\>@ can be appended, for example @"std::shared_ptr"@.+--+-- A @shared_ptr\<T\>@ 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