hoppy-generator 0.2.1 → 0.3.0

raw patch · 11 files changed

+4976/−3400 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hoppy-generator.cabal +6/−1
• src/Foreign/Hoppy/Generator/Common.hs +5/−0
• src/Foreign/Hoppy/Generator/Language/Cpp.hs +26/−2
• src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs +277/−45
• src/Foreign/Hoppy/Generator/Language/Haskell.hs +402/−127
• src/Foreign/Hoppy/Generator/Language/Haskell/Internal.hs +1656/−1333
• src/Foreign/Hoppy/Generator/Spec.hs +30/−1875
• src/Foreign/Hoppy/Generator/Spec/Base.hs +2484/−0
• src/Foreign/Hoppy/Generator/Spec/ClassFeature.hs +12/−16
• src/Foreign/Hoppy/Generator/Spec/Conversion.hs +77/−0
• src/Foreign/Hoppy/Generator/Types.hs +1/−1

@@ -1,5 +1,5 @@ name: hoppy-generator-version: 0.2.1+version: 0.3.0 synopsis: C++ FFI generator - Code generator homepage: http://khumba.net/projects/hoppy license: AGPL-3@@ -29,11 +29,16 @@     , Foreign.Hoppy.Generator.Common.Consume     , Foreign.Hoppy.Generator.Language.Cpp.Internal     , Foreign.Hoppy.Generator.Language.Haskell.Internal+    , Foreign.Hoppy.Generator.Spec.Base+    , Foreign.Hoppy.Generator.Spec.Conversion   default-extensions:       FlexibleContexts     , FlexibleInstances     , FunctionalDependencies+    , LambdaCase     , MultiParamTypeClasses+  other-extensions:+      GeneralizedNewtypeDeriving   build-depends:       base >=4.7 && <5     , containers >=0.5 && <0.6

@@ -22,6 +22,7 @@   fromMaybeM,   fromEitherM,   maybeFail,+  for,   listSubst,   zipWithM,   writeFileIfDifferent,@@ -51,6 +52,10 @@ -- | @maybeFail s x = maybe (fail s) x@ maybeFail :: Monad m => String -> Maybe a -> m a maybeFail = fromMaybeM . fail++-- | @for = flip map@+for :: [a] -> (a -> b) -> [b]+for = flip map  -- | @listSubst a b xs@ replaces all @x@ in @xs@ such that @x == a@ with @b@. listSubst :: Eq a => a -> a -> [a] -> [a]

@@ -27,6 +27,10 @@   callbackFnName,   toArgName,   toArgNameAlt,+  exceptionIdArgName,+  exceptionPtrArgName,+  exceptionVarName,+  exceptionRethrowFnName,   Chunk (..),   runChunkWriter,   evalChunkWriter,@@ -45,6 +49,7 @@ import Control.Monad.Writer (MonadWriter, Writer, WriterT, runWriter, runWriterT, tell) import Data.Foldable (forM_) import Data.List (intercalate, intersperse)+import Foreign.Hoppy.Generator.Common import Foreign.Hoppy.Generator.Spec import Foreign.Hoppy.Generator.Types @@ -108,6 +113,25 @@ toArgNameAlt :: Int -> String toArgNameAlt n = "arg" ++ show n ++ "_" +-- | The C++ variable name to use for the exception ID argument in a gateway+-- function.+exceptionIdArgName :: String+exceptionIdArgName = "excId"++-- | The C++ variable name to use for the exception pointer argument in a+-- gateway function.+exceptionPtrArgName :: String+exceptionPtrArgName = "excPtr"++-- | The C++ variable name to use in a @catch@ statement in a gateway function.+exceptionVarName :: String+exceptionVarName = "exc_"++-- | The name of the C++ function that receives an exception from a foreign+-- language and throws it in C++.+exceptionRethrowFnName :: String+exceptionRethrowFnName = "genthrow"+ -- TODO Fixme, this is most likely backwards, it should be a finite set of -- non-identifier chars.  Also (maybe) share some logic with the toExtName -- requirements?@@ -155,7 +179,7 @@ combineChunks :: [Chunk] -> String combineChunks chunks =   let strs = map chunkContents chunks-  in concat $ flip map (zip ("":strs) strs) $ \(prev, cur) ->+  in concat $ for (zip ("":strs) strs) $ \(prev, cur) ->        let needsSpace =              not (null prev) && not (null cur) &&              (let a = last prev@@ -246,7 +270,7 @@       outer       say "("       sequence_ $ intersperse (say ", ") $-        flip map (zip paramTypes $ maybe (repeat Nothing) (map Just) maybeParamNames) $+        for (zip paramTypes $ maybe (repeat Nothing) (map Just) maybeParamNames) $         \(ptype, pname) ->         sayType' ptype Nothing topPrecedence $ forM_ pname say       say ")"

@@ -32,9 +32,12 @@ import Control.Monad.Writer (WriterT, execWriterT, runWriterT, tell) import Control.Monad.Trans (lift) import Data.Foldable (forM_)+#if !MIN_VERSION_base(4,8,0)+import Data.Functor ((<$))+#endif import Data.List (intersperse) import qualified Data.Map as M-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (catMaybes, fromMaybe, isJust) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mappend, mconcat, mempty) #endif@@ -136,12 +139,20 @@   addReqsM $ moduleReqs m   mapM_ (sayExport False) $ M.elems $ moduleExports m +  iface <- askInterface+  when (interfaceExceptionSupportModule iface == Just m) $+    sayExceptionSupport False+ sayModuleSource :: Generator () sayModuleSource = do   m <- askModule   addInclude $ includeLocal $ moduleHppPath m   mapM_ (sayExport True) $ M.elems $ moduleExports m +  iface <- askInterface+  when (interfaceExceptionSupportModule iface == Just m) $+    sayExceptionSupport True+ sayExport :: Bool -> Export -> Generator () sayExport sayBody export = case export of   ExportVariable v -> when sayBody $ sayExportVariable v@@ -161,6 +172,7 @@                   Nothing                   (fnParams fn)                   (fnReturn fn)+                  (fnExceptionHandlers fn)                   sayBody    ExportClass cls -> when sayBody $ do@@ -171,11 +183,12 @@      -- Export each of the class's constructors.     forM_ (classCtors cls) $ \ctor ->-      sayExportFn (getClassyExtName cls ctor)+      sayExportFn (classEntityExtName cls ctor)                   (CallFn $ say "new" >> sayIdentifier (classIdentifier cls))                   Nothing                   (ctorParams ctor)                   clsPtr+                  (ctorExceptionHandlers ctor)                   sayBody      -- Export a delete function for the class.@@ -185,6 +198,9 @@                   (fnT [ptrT $ constT $ objT cls] voidT) $         Just $ say "delete self;\n" +    -- Export each of the class's variables.+    forM_ (classVariables cls) $ sayExportClassVariable cls+     -- Export each of the class's methods.     forM_ (classMethods cls) $ \method -> do       let nonMemberCall =@@ -193,7 +209,7 @@               RealMethod {} -> False               FnMethod {} -> True       let static = methodStatic method == Static-      sayExportFn (getClassyExtName cls method)+      sayExportFn (classEntityExtName cls method)                   (case methodImpl method of                      RealMethod name -> case name of                        FnName cName -> CallFn $ do@@ -208,6 +224,7 @@                   (if nonMemberCall then Nothing else justClsPtr)                   (methodParams method)                   (methodReturn method)+                  (methodExceptionHandlers method)                   sayBody      -- Export upcast functions for the class to its direct superclasses.@@ -243,43 +260,82 @@           forM_ (classSuperclasses ancestorCls) $ genDowncastFns cls  sayExportVariable :: Variable -> Generator ()-sayExportVariable v = do-  let (isConst, deconstType) = case varType v of+sayExportVariable v =+  sayExportVariable' (varType v)+                     Nothing+                     True+                     (varGetterExtName v)+                     (varSetterExtName v)+                     (sayIdentifier $ varIdentifier v)++sayExportClassVariable :: Class -> ClassVariable -> Generator ()+sayExportClassVariable cls v =+  sayExportVariable' (classVarType v)+                     (case classVarStatic v of+                        Nonstatic -> Just (ptrT $ constT $ objT cls, ptrT $ objT cls)+                        Static -> Nothing)+                     (classVarGettable v)+                     (classVarGetterExtName cls v)+                     (classVarSetterExtName cls v)+                     (case classVarStatic v of+                        Nonstatic -> say $ classVarCName v+                        Static -> do sayIdentifier $ classIdentifier cls+                                     says ["::", classVarCName v])++sayExportVariable' :: Type+                   -> Maybe (Type, Type)+                   -> Bool+                   -> ExtName+                   -> ExtName+                   -> Generator ()+                   -> Generator ()+sayExportVariable' t maybeThisTypes gettable getterName setterName sayVarName = do+  let (isConst, deconstType) = case t of         Internal_TConst t -> (True, t)         t -> (False, t)    -- Say a getter function.-  sayExportFn (varGetterExtName v)-              (VarRead $ varIdentifier v)-              Nothing-              []-              deconstType-              True+  when gettable $+    sayExportFn getterName+                (VarRead sayVarName)+                (fmap fst maybeThisTypes)+                []+                deconstType+                mempty+                True    -- Say a setter function.   unless isConst $-    sayExportFn (varSetterExtName v)-                (VarWrite $ varIdentifier v)-                Nothing+    sayExportFn setterName+                (VarWrite sayVarName)+                (fmap snd maybeThisTypes)                 [deconstType]                 voidT+                mempty                 True  data CallType =     CallOp Operator   | CallFn (Generator ())-  | VarRead Identifier-  | VarWrite Identifier+  | VarRead (Generator ())+  | VarWrite (Generator ())  sayExportFn :: ExtName             -> CallType             -> Maybe Type             -> [Type]             -> Type+            -> ExceptionHandlers             -> Bool             -> Generator ()-sayExportFn extName callType maybeThisType paramTypes retType sayBody = do-  let paramCount = length paramTypes+sayExportFn extName callType maybeThisType paramTypes retType exceptionHandlers sayBody = do+  handlerList <- exceptionHandlersList <$> getEffectiveExceptionHandlers exceptionHandlers+  let catches = not $ null handlerList+      addExceptionParamNames =+        if catches then (++ [exceptionIdArgName, exceptionPtrArgName]) else id+      addExceptionParamTypes = if catches then (++ [ptrT intT, ptrT $ ptrT voidT]) else id++      paramCount = length paramTypes       paramCTypeMaybes = map typeToCType paramTypes       paramCTypes = zipWith fromMaybe paramTypes paramCTypeMaybes       retCTypeMaybe = typeToCType retType@@ -289,14 +345,20 @@    sayFunction (externalNameToCpp extName)               (maybe id (const ("self":)) maybeThisType $+               addExceptionParamNames $                zipWith3 (\t ctm -> case t of                            Internal_TCallback {} -> toArgNameAlt                            _ -> if isJust ctm then toArgNameAlt else toArgName)                paramTypes paramCTypeMaybes [1..paramCount])-              (fnT (maybe id (:) maybeThisType paramCTypes) retCType) $+              (fnT (addExceptionParamTypes $ maybe id (:) maybeThisType paramCTypes)+                   retCType) $     if not sayBody     then Nothing     else Just $ do+      when catches $ do+        say "try {\n"+        says ["*", exceptionIdArgName, " = 0;\n"]+       -- Convert arguments that aren't passed in directly.       mapM_ (sayArgRead DoDecode) $ zip3 [1..] paramTypes paramCTypeMaybes @@ -326,8 +388,13 @@               say "("               sayArgNames paramCount               say ")"-            VarRead identifier -> sayIdentifier identifier-            VarWrite identifier -> sayIdentifier identifier >> says [" = ", toArgName 1]+            VarRead sayVarName -> do+              when (isJust maybeThisType) $ say "self->"+              sayVarName+            VarWrite sayVarName -> do+              when (isJust maybeThisType) $ say "self->"+              sayVarName+              says [" = ", toArgName 1]            -- Writes the call, transforming the return value if necessary.           -- These translations should be kept in sync with typeToCType.@@ -358,6 +425,39 @@        sayCallAndReturn retType retCTypeMaybe +      when catches $ do+        iface <- askInterface++        forM_ handlerList $ \handler -> do+          say "} catch ("+          case handler of+            CatchClass cls -> sayVar exceptionVarName Nothing $ refT $ constT $ objT cls+            CatchAll -> say "..."+          say ") {\n"++          exceptionId <- case handler of+            CatchClass cls -> case interfaceExceptionClassId iface cls of+              Just exceptionId -> return exceptionId+              Nothing -> abort $ concat+                         ["sayExportFn: Trying to catch non-exception class ", show cls,+                          " while generating binding for ", show extName, "."]+            CatchAll -> return exceptionCatchAllId+          says ["*", exceptionIdArgName, " = ", show $ getExceptionId exceptionId, ";\n"]++          case handler of+            CatchAll -> says ["*", exceptionPtrArgName, " = 0;\n"]+            CatchClass cls -> do+              -- Object pointers don't convert automatically to void*.+              says ["*", exceptionPtrArgName, " = reinterpret_cast<void*>(new "]+              sayType Nothing $ objT cls+              says ["(", exceptionVarName, "));\n"]++          -- For all of the types our gateway functions actually return, "return+          -- 0" is a valid statement.+          when (retType /= Internal_TVoid) $ say "return 0;\n"++        say "}\n"+   where sayReturnNew cls sayCall =           say "return new" >> sayIdentifier (classIdentifier cls) >> say "(" >>           sayCall >> say ");\n"@@ -396,6 +496,22 @@                    show cb, "."]     says [callbackClassName cb, " ", toArgName n, "(", toArgNameAlt n, ");\n"] +  t@(Internal_TPtr (Internal_TFn paramTypes retType)) -> do+    -- Assert that all types referred to in a function pointer type are all+    -- representable as C types.+    let check label t' = (label ++ " " ++ show t') <$ typeToCType t'+        mismatches = catMaybes $+                     check "return type" retType :+                     map (\paramType -> check "parameter" paramType)+                         paramTypes+    unless (null mismatches) $+      abort $ concat $+      "sayArgRead: Some types within a function pointer type use non-C types, " :+      "but only C types may be used.  The unsupported types are: " :+      intersperse "; " mismatches ++ [".  The whole function type is ", show t, "."]++    convertDefault+   Internal_TRef t -> convertObj t    Internal_TObj _ -> convertObj $ constT cppType@@ -418,17 +534,19 @@             _ -> t'       sayArgRead dir (n, cppType, typeToCType newCppType) -  -- Primitive types don't need to be encoded/decoded.  But if maybeCType is a-  -- Just, then we're expected to do some encoding/decoding, so something is-  -- wrong.-  ---  -- TODO Do we need to handle TConst?-  _ -> forM_ maybeCType $ \cType ->-    abort $ concat-    ["sayArgRead: Don't know how to ", show dir, " between C-type ", show cType,-     " and C++-type ", show cppType, "."]+  _ -> convertDefault -  where convertObj cppType' = case dir of+  where -- Primitive types don't need to be encoded/decoded.  But if maybeCType is a+        -- Just, then we're expected to do some encoding/decoding, so something is+        -- wrong.+        --+        -- TODO Do we need to handle TConst?+        convertDefault = forM_ maybeCType $ \cType ->+          abort $ concat+          ["sayArgRead: Don't know how to ", show dir, " between C-type ", show cType,+           " and C++-type ", show cppType, "."]++        convertObj cppType' = case dir of           DoDecode -> do             sayVar (toArgName n) Nothing $ refT cppType'             says [" = *", toArgNameAlt n, ";\n"]@@ -442,6 +560,8 @@  sayExportCallback :: Bool -> Callback -> Generator () sayExportCallback sayBody cb = do+  throws <- getEffectiveCallbackThrows cb+   let className = callbackClassName cb       implClassName = callbackImplClassName cb       fnName = callbackFnName cb@@ -458,7 +578,9 @@    addReqsM . mconcat =<< mapM typeReqs (retType:paramTypes) -  let fnCType = fnT paramCTypes retCType+  let fnCType = fnT ((if throws then ([ptrT intT, ptrT $ ptrT voidT] ++) else id)+                     paramCTypes)+                    retCType       fnPtrCType = ptrT fnCType    if not sayBody@@ -520,31 +642,74 @@                   fnType $ Just $ do         -- Convert arguments that aren't passed in directly.         mapM_ (sayArgRead DoEncode) $ zip3 [1..] paramTypes paramCTypeMaybes++        when throws $ do+          says ["int ", exceptionIdArgName, " = 0;\n"]+          says ["void *", exceptionPtrArgName, " = 0;\n"]++          -- Add an include for the exception support module to be able to call the+          -- C++ rethrow function.+          iface <- askInterface+          currentModule <- askModule+          case interfaceExceptionSupportModule iface of+            Just exceptionSupportModule ->+              when (exceptionSupportModule /= currentModule) $+                -- TODO Should this be includeStd?+                addReqsM $ reqInclude $ includeLocal $ moduleHppPath exceptionSupportModule+            Nothing -> abort $ "sayExportCallback: " ++ show iface +++                       " uses exceptions, so it needs an exception support " +++                       "module.  Please use interfaceSetExceptionSupportModule."+         -- Invoke the function pointer into foreign code.-        let sayCall = say "f_(" >> sayArgNames paramCount >> say ")"+        let sayCall = do+              say "f_("+              when throws $ do+                says ["&", exceptionIdArgName, ", &", exceptionPtrArgName]+                when (paramCount /= 0) $ say ", "+              sayArgNames paramCount+              say ")"++            sayExceptionCheck = when throws $ do+              says ["if (", exceptionIdArgName, " != 0) { ",+                    exceptionRethrowFnName, "(", exceptionIdArgName, ", ",+                    exceptionPtrArgName, "); }\n"]+         case (retType, retCTypeMaybe) of-          (Internal_TVoid, Nothing) -> sayCall >> say ";\n"-          (_, Nothing) -> say "return " >> sayCall >> say ";\n"+          (Internal_TVoid, Nothing) -> do+            sayCall >> say ";\n"+            sayExceptionCheck+          (_, Nothing) -> do+            sayVar "result" Nothing retType >> say " = " >> sayCall >> say ";\n"+            sayExceptionCheck+            say "return result;\n"           (Internal_TBitspace b, Just _) -> do             addReqsM $ bitspaceReqs b             let convFn = bitspaceToCppValueFn b-            say "return "+            sayVar "result" Nothing retType+            say " = "             forM_ convFn $ \f -> says [f, "("]             sayCall             when (isJust convFn) $ say ")"             say ";\n";+            sayExceptionCheck+            say "return result;\n"           (Internal_TObj cls1, Just retCType@(Internal_TPtr (Internal_TConst (Internal_TObj cls2))))             | cls1 == cls2 -> do-              sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n"-              sayVar "result" Nothing retType >> say " = *resultPtr;\n"-              say "delete resultPtr;\n"-              say "return result;\n"+            sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n"+            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 ->-            say "return *(" >> sayCall >> say ");\n"+           Just (Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) | cls1 == cls2 -> do+            sayVar "result" Nothing retType >> say " = *" >> sayCall >> say ";\n"+            sayExceptionCheck+            say "return result;\n"           (Internal_TRef (Internal_TObj cls1),-           Just (Internal_TPtr (Internal_TObj cls2))) | cls1 == cls2 ->-            say "return *(" >> sayCall >> say ");\n"+           Just (Internal_TPtr (Internal_TObj cls2))) | cls1 == cls2 -> do+            sayVar "result" Nothing retType >> say " = *" >> sayCall >> say ";\n"+            sayExceptionCheck+            say "return result;\n"           ts -> abort $ concat                 ["sayExportCallback: Unexpected return types ", show ts, "."] @@ -568,6 +733,39 @@       sayFunction fnName ["f", "release", "releaseRelease"] newCallbackFnType $ Just $         says ["return new ", implClassName, "(f, release, releaseRelease);\n"] +-- | Outputs interface-wide code needed to support exceptions.  Currently, this+-- comprises the function for rethrowing in C++ an exception transferred from+-- a foreign language.+sayExceptionSupport :: Bool -> Generator ()+sayExceptionSupport sayBody =+  sayFunction exceptionRethrowFnName+              ["excId", "voidPtr"]+              (fnT [intT, ptrT voidT] voidT) $+  if not sayBody+  then Nothing+  else Just $ do+    iface <- askInterface+    let excClasses = interfaceAllExceptionClasses iface++    says ["switch (excId) {\n"]++    forM_ excClasses $ \cls -> do+      excId <- fmap getExceptionId $+               fromMaybeM (abort $ "sayExceptionSupport: Internal error, " ++ show cls +++                           "should have an exception ID, but doesn't.") $+               interfaceExceptionClassId iface cls+      says ["case ", show excId, ": {\n"]+      sayVar "excPtr" Nothing (ptrT $ objT cls) >> say " = reinterpret_cast<" >>+        sayType Nothing (ptrT $ objT cls) >> says [">(voidPtr);\n"]+      sayVar "exc" Nothing (objT cls) >> say " = *excPtr;\n"+      say "delete excPtr;\n"+      say "throw exc;\n"+      say "}\n"++    say "}\n"+    says ["throw \"Internal Hoppy error, ", exceptionRethrowFnName,+          " got an unknown exception ID.\";\n"]+ -- | Returns a 'Type' iff there is a C type distinct from the given C++ type -- that should be used for conversion. typeToCType :: Type -> Maybe Type@@ -622,10 +820,11 @@     -- TODO Is the right 'ReqsType' being used recursively here?     mconcat <$> mapM typeReqs (retType:paramTypes)   Internal_TCallback cb -> do+    -- TODO Should this be includeStd?     cbClassReqs <- reqInclude . includeLocal . moduleHppPath <$>                    findExportModule (callbackExtName cb)     -- TODO Is the right 'ReqsType' being used recursively here?-    fnTypeReqs <- typeReqs $ callbackToTFn cb+    fnTypeReqs <- typeReqs =<< callbackToTFn cb     return $ cbClassReqs `mappend` fnTypeReqs   Internal_TObj cls -> return $ classReqs cls   Internal_TObjToHeap cls -> return $ classReqs cls@@ -643,3 +842,36 @@   fromMaybeM (abort $ concat               ["findExportModule: Can't find module exporting ", fromExtName extName, "."]) =<<   fmap (M.lookup extName . interfaceNamesToModules) askInterface++getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers+getEffectiveExceptionHandlers handlers = do+  ifaceHandlers <- interfaceExceptionHandlers <$> askInterface+  moduleHandlers <- getExceptionHandlers <$> askModule+  -- Exception handlers declared lower in the hierarchy take precedence over+  -- those in the hierarchy; ExceptionHandlers is a left-biased monoid.+  return $ mconcat [handlers, moduleHandlers, ifaceHandlers]++getEffectiveCallbackThrows :: Callback -> Generator Bool+getEffectiveCallbackThrows cb = case callbackThrows cb of+  Just b -> return b+  Nothing -> moduleCallbacksThrow <$> askModule >>= \case+    Just b -> return b+    Nothing -> interfaceCallbacksThrow <$> askInterface++-- | Constructs the function type for a callback.  A callback that throws has+-- additional parameters.+--+-- Keep this in sync with the Haskell generator's version.+callbackToTFn :: Callback -> Generator Type+callbackToTFn cb = do+  throws <- mayThrow+  return $ Internal_TFn ((if throws then addExcParams else id) $ callbackParams cb)+                        (callbackReturn cb)++  where mayThrow = case callbackThrows cb of+          Just t -> return t+          Nothing -> moduleCallbacksThrow <$> askModule >>= \mt -> case mt of+            Just t -> return t+            Nothing -> interfaceCallbacksThrow <$> askInterface++        addExcParams = (++ [ptrT intT, ptrT $ ptrT voidT])

@@ -31,6 +31,10 @@   evalGenerator,   execGenerator,   renderPartial,+  askInterface,+  askModule,+  askModuleName,+  getModuleForExtName,   withErrorContext,   inFunction,   -- * Exports@@ -40,40 +44,68 @@   addExports,   -- * Imports   addImports,-  importHsModuleForExtName,+  -- * Language extensions+  addExtension,   -- * Code generation   sayLn,   saysLn,   ln,   indent,+  indentSpaces,   sayLet,   toHsEnumTypeName,+  toHsEnumTypeName',   toHsEnumCtorName,+  toHsEnumCtorName',   toHsBitspaceTypeName,+  toHsBitspaceTypeName',   toHsBitspaceValueName,+  toHsBitspaceValueName',   toHsBitspaceToNumName,+  toHsBitspaceToNumName',   toHsBitspaceClassName,+  toHsBitspaceClassName',   toHsBitspaceFromValueName,+  toHsBitspaceFromValueName',   toHsValueClassName,+  toHsValueClassName',   toHsWithValuePtrName,+  toHsWithValuePtrName',   toHsPtrClassName,+  toHsPtrClassName',   toHsCastMethodName,+  toHsCastMethodName',   toHsDownCastClassName,+  toHsDownCastClassName',   toHsDownCastMethodName,+  toHsDownCastMethodName',   toHsCastPrimitiveName,+  toHsCastPrimitiveName',   toHsConstCastFnName,+  toHsConstCastFnName',   toHsDataTypeName,+  toHsDataTypeName',   toHsDataCtorName,-  toHsClassDeleteFnName,-  toHsClassDeleteFnPtrName,+  toHsDataCtorName',+  toHsClassDeleteFnName',+  toHsClassDeleteFnPtrName',+  toHsCtorName,+  toHsCtorName',   toHsMethodName,   toHsMethodName',+  toHsClassEntityName,+  toHsClassEntityName',   toHsCallbackCtorName,+  toHsCallbackCtorName',+  toHsCallbackNewFunPtrFnName,+  toHsCallbackNewFunPtrFnName',   toHsFnName,+  toHsFnName',   toArgName,   HsTypeSide (..),   cppTypeToHsTypeAndUse,   getClassHaskellConversion,+  callbackToTFn,   prettyPrint,   ) where @@ -81,7 +113,6 @@ import Control.Applicative ((<$>)) #endif import Control.Arrow (first)-import Control.Monad (when) #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except (Except, catchError, runExcept, throwError) #else@@ -99,9 +130,10 @@ #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid, mappend, mconcat, mempty) #endif+import qualified Data.Set as S import Data.Tuple (swap)-import Foreign.Hoppy.Generator.Common (capitalize, lowerFirst)-import Foreign.Hoppy.Generator.Spec+import Foreign.Hoppy.Generator.Common+import Foreign.Hoppy.Generator.Spec.Base import Foreign.Hoppy.Generator.Types import qualified Language.Haskell.Pretty as P import Language.Haskell.Syntax (@@ -250,19 +282,35 @@ -- | Context information for generating Haskell code. data Env = Env   { envInterface :: Interface+  , envModule :: Module   , envModuleName :: String   } +-- | Returns the currently generating interface. askInterface :: Generator Interface askInterface = envInterface <$> ask +-- | Returns the currently generating module.+askModule :: Generator Module+askModule = envModule <$> ask++-- | Returns the currently generating module's Haskell module name. askModuleName :: Generator String askModuleName = envModuleName <$> ask +-- | Looks up the 'Module' containing a given external name, throwing an error+-- if it can't be found.+getModuleForExtName :: ExtName -> Generator Module+getModuleForExtName extName = inFunction "getModuleForExtName" $ do+  iface <- askInterface+  case M.lookup extName $ interfaceNamesToModules iface of+    Just mod -> return mod+    Nothing -> throwError $ "Can't find module for " ++ show extName+ -- | A partially-rendered 'Module'.  Contains all of the module's bindings, but -- may be subject to further processing. data Partial = Partial-  { partialModuleHsName :: String+  { partialModuleHsName :: String  -- ^ This is just the module name.   , partialOutput :: Output   } @@ -286,40 +334,43 @@     -- ^ Lines of Haskell code (possibly empty).  These lines may not contain     -- the newline character in them.  There is an implicit newline between each     -- string, as given by @intercalate \"\\n\" . outputBody@.+  , outputExtensions :: S.Set String+    -- ^ Language extensions to enable via the @{-# LANGUAGE #-}@ pragma for the+    -- whole module.   }  instance Monoid Output where-  mempty = Output mempty mempty mempty+  mempty = Output mempty mempty mempty mempty -  (Output e i b) `mappend` (Output e' i' b') =-    Output (e `mappend` e') (i `mappend` i') (b `mappend` b')+  (Output e i b x) `mappend` (Output e' i' b' x') =+    Output (e `mappend` e') (i `mappend` i') (b `mappend` b') (x `mappend` x')    mconcat os =     Output (mconcat $ map outputExports os)            (mconcat $ map outputImports os)            (mconcat $ map outputBody os)+           (mconcat $ map outputExtensions os)  -- | Runs a generator action for the given interface and module name string. -- Returns an error message if an error occurred, otherwise the action's output -- together with its value.-runGenerator :: Interface -> String -> Generator a -> Either ErrorMsg (Partial, a)-runGenerator iface modName generator =-  fmap (first (Partial modName) . swap) $+runGenerator :: Interface -> Module -> Generator a -> Either ErrorMsg (Partial, a)+runGenerator iface mod generator =+  let modName = getModuleName iface mod+  in fmap (first (Partial modName) . swap) $ #if MIN_VERSION_mtl(2,2,1)-  runExcept $+     runExcept $ #endif-  flip catchError (\msg -> throwError $ msg ++ ".") $-  runWriterT $ runReaderT generator $ Env iface modName+     flip catchError (\msg -> throwError $ msg ++ ".") $+     runWriterT $ runReaderT generator $ Env iface mod modName  -- | Runs a generator action and returns the its value.-evalGenerator :: Interface -> String -> Generator a -> Either ErrorMsg a-evalGenerator iface modName =-  fmap snd . runGenerator iface modName+evalGenerator :: Interface -> Module -> Generator a -> Either ErrorMsg a+evalGenerator iface mod = fmap snd . runGenerator iface mod  -- | Runs a generator action and returns its output.-execGenerator :: Interface -> String -> Generator a -> Either ErrorMsg Partial-execGenerator iface modName =-  fmap fst . runGenerator iface modName+execGenerator :: Interface -> Module -> Generator a -> Either ErrorMsg Partial+execGenerator iface mod = fmap fst . runGenerator iface mod  -- | Converts a 'Partial' into a complete Haskell module. renderPartial :: Partial -> String@@ -332,6 +383,11 @@         [ [ "---------- GENERATED FILE, EDITS WILL BE LOST ----------"           , ""           ]+        , case S.elems $ outputExtensions output of+            [] -> []+            extensions -> [ concat $ "{-# LANGUAGE " : intersperse ", " extensions ++ [" #-}"]+                          , ""+                          ]         , case outputExports output of             [] -> [concat ["module ", modName, " where"]]             exports ->@@ -376,24 +432,10 @@ addImports :: HsImportSet -> Generator () addImports imports = tell mempty { outputImports = imports } --- | Imports all of the objects for the given external name into the current--- module.  This is a no-op of the external name is defined in the current--- module.-importHsModuleForExtName :: ExtName -> Generator ()-importHsModuleForExtName extName = inFunction "importHsModuleForExtName" $ do-  iface <- askInterface-  case M.lookup extName $ interfaceNamesToModules iface of-    Just ownerModule -> do-      let ownerModuleName = getModuleName iface ownerModule-      currentModuleName <- askModuleName-      when (currentModuleName /= ownerModuleName) $-        -- Yes, this currently imports the whole dang module to keep things-        -- simple.-        addImports $ hsWholeModuleImport ownerModuleName-    Nothing ->-      throwError $ concat-      ["Couldn't find module for ", show extName,-       " (maybe you forgot to include it in an exports list?)"]+-- | Adds a Haskell language extension to the current module.+addExtension :: String -> Generator ()+addExtension extensionName =+  tell $ mempty { outputExtensions = S.singleton extensionName }  -- | Outputs a line of Haskell code.  A newline will be added on the end of the -- input.  Newline characters must not be given to this function.@@ -418,6 +460,11 @@ indent :: Generator a -> Generator a indent = censor $ \o -> o { outputBody = map (\x -> ' ':' ':x) $ outputBody o } +-- | Runs the given action, indenting all code output by the action N spaces.+indentSpaces :: Int -> Generator a -> Generator a+indentSpaces n = censor $ \o -> o { outputBody = map (\x -> indentation ++ x) $ outputBody o }+  where indentation = replicate n ' '+ -- | Takes a list of binding actions and a body action, and outputs a @let@ -- expression.  By passing in 'Nothing' for the body, it will be omitted, so -- @let@ statements in @do@ blocks can be created as well.  Output is of the@@ -442,11 +489,62 @@       sayLn "in"       indent body +getExtNameModule :: ExtName -> Generator Module+getExtNameModule extName = inFunction "getExtNameModule" $ do+  iface <- askInterface+  fromMaybeM (throwError $ "Couldn't find module for " ++ show extName +++              " (is it included in a module's export list?)") $+    M.lookup extName $+    interfaceNamesToModules iface++-- | Returns a module's unique short name that should be used for a qualified+-- import of the module.+getModuleImportName :: Module -> Generator String+getModuleImportName mod = do+  iface <- askInterface+  fromMaybeM (throwError $ "Couldn't find a Haskell import name for " ++ show mod +++              " (is it included in the interface's module list?)") $+    M.lookup mod $+    interfaceHaskellModuleImportNames iface++-- | Adds a qualified import of the given external name's module into the current+-- module, and returns the qualified name of the import.  If the external name+-- is defined in the current module, then this is a no-op and 'Nothing' is+-- returned.+importHsModuleForExtName :: ExtName -> Generator (Maybe String)+importHsModuleForExtName extName = do+  currentModule <- askModule+  owningModule <- getExtNameModule extName+  if currentModule == owningModule+    then return Nothing+    else do iface <- askInterface+            let fullName = getModuleName iface owningModule+            qualifiedName <- getModuleImportName owningModule+            addImports $ hsQualifiedImport fullName qualifiedName+            return $ Just qualifiedName++-- | Used like @addExtNameModule extName hsEntity@.  @hsEntity@ is a name in+-- Haskell code that is generated from the definition of @extName@, and thus+-- lives in @extName@'s module.  This function adds imports and returns a+-- qualified name as necessary to refer to the given entity.+addExtNameModule :: ExtName -> String -> Generator String+addExtNameModule extName hsEntity = do+  maybeImportName <- importHsModuleForExtName extName+  return $ case maybeImportName of+    Nothing -> hsEntity  -- Same module.+    Just importName -> concat [importName, ".", hsEntity]  -- Different module.+ -- | Internal helper function for constructing Haskell names from external -- names.  Returns a name that is a suitable Haskell type name for the external -- name, and if given 'Const', then with @\"Const\"@ appended.-toHsTypeName :: Constness -> ExtName -> String+toHsTypeName :: Constness -> ExtName -> Generator String toHsTypeName cst extName =+  inFunction "toHsTypeName" $+  addExtNameModule extName $ toHsTypeName' cst extName++-- | Pure version of 'toHsTypeName' that doesn't create a qualified name.+toHsTypeName' :: Constness -> ExtName -> String+toHsTypeName' cst extName =   (case cst of       Const -> (++ "Const")       Nonconst -> id) $@@ -455,67 +553,141 @@     [] -> []  -- | Returns the Haskell name for an enum.-toHsEnumTypeName :: CppEnum -> String-toHsEnumTypeName = toHsTypeName Nonconst . enumExtName+toHsEnumTypeName :: CppEnum -> Generator String+toHsEnumTypeName enum =+  inFunction "toHsEnumTypeName" $+  addExtNameModule (enumExtName enum) $ toHsEnumTypeName' enum +-- | Pure version of 'toHsEnumTypeName' that doesn't create a qualified name.+toHsEnumTypeName' :: CppEnum -> String+toHsEnumTypeName' = toHsTypeName' Nonconst . enumExtName+ -- | Constructs the data constructor name for a value in an enum.  Like C++ and -- unlike say Java, Haskell enum values aren't in a separate enum-specific -- namespace, so we prepend the enum name to the value name to get the data -- constructor name.  The value name is a list of words; see 'enumValueNames'.-toHsEnumCtorName :: CppEnum -> [String] -> String+toHsEnumCtorName :: CppEnum -> [String] -> Generator String toHsEnumCtorName enum words =-  concat $ toHsEnumTypeName enum : "_" : map capitalize words+  inFunction "toHsEnumCtorName" $+  addExtNameModule (enumExtName enum) $ toHsEnumCtorName' enum words +-- | Pure version of 'toHsEnumCtorName' that doesn't create a qualified name.+toHsEnumCtorName' :: CppEnum -> [String] -> String+toHsEnumCtorName' enum words =+  concat $ enumValuePrefix enum : map capitalize words+ -- | Returns the Haskell name for a bitspace.  See 'toHsEnumTypeName'.-toHsBitspaceTypeName :: Bitspace -> String-toHsBitspaceTypeName = toHsTypeName Nonconst . bitspaceExtName+toHsBitspaceTypeName :: Bitspace -> Generator String+toHsBitspaceTypeName bitspace =+  inFunction "toHsBitspaceTypeName" $+  addExtNameModule (bitspaceExtName bitspace) $ toHsBitspaceTypeName' bitspace +-- | Pure version of 'toHsBitspaceTypeName' that doesn't create a qualified name.+toHsBitspaceTypeName' :: Bitspace -> String+toHsBitspaceTypeName' = toHsTypeName' Nonconst . bitspaceExtName+ -- | Constructs the data constructor name for a value in a bitspace.  See -- 'toHsEnumCtorName'.-toHsBitspaceValueName :: Bitspace -> [String] -> String+toHsBitspaceValueName :: Bitspace -> [String] -> Generator String toHsBitspaceValueName bitspace words =-  lowerFirst $ concat $ toHsBitspaceTypeName bitspace : "_" : map capitalize words+  inFunction "toHsBitspaceValueName" $+  addExtNameModule (bitspaceExtName bitspace) $+  toHsBitspaceValueName' bitspace words +-- | Pure version of 'toHsBitspaceValueName' that doesn't create a qualified name.+toHsBitspaceValueName' :: Bitspace -> [String] -> String+toHsBitspaceValueName' bitspace words =+  lowerFirst $ concat $ bitspaceValuePrefix bitspace : map capitalize words+ -- | Returns the name of the function that will convert a bitspace value into a -- raw numeric value.-toHsBitspaceToNumName :: Bitspace -> String-toHsBitspaceToNumName = ("from" ++) . toHsBitspaceTypeName+toHsBitspaceToNumName :: Bitspace -> Generator String+toHsBitspaceToNumName bitspace =+  inFunction "toHsBitspaceToNumName" $+  addExtNameModule (bitspaceExtName bitspace) $ toHsBitspaceToNumName' bitspace +-- | Pure version of 'toHsBitspaceToNumName' that doesn't create a qualified name.+toHsBitspaceToNumName' :: Bitspace -> String+toHsBitspaceToNumName' = ("from" ++) . toHsBitspaceTypeName'+ -- | The name of the Haskell typeclass that contains a method for converting to -- a bitspace value.-toHsBitspaceClassName :: Bitspace -> String-toHsBitspaceClassName bitspace = 'I':'s':toHsBitspaceTypeName bitspace+toHsBitspaceClassName :: Bitspace -> Generator String+toHsBitspaceClassName bitspace =+  inFunction "toHsBitspaceClassName" $+  addExtNameModule (bitspaceExtName bitspace) $ toHsBitspaceClassName' bitspace +-- | Pure version of 'toHsBitspaceClassName' that doesn't create a qualified name.+toHsBitspaceClassName' :: Bitspace -> String+toHsBitspaceClassName' bitspace = 'I':'s':toHsBitspaceTypeName' bitspace+ -- | The name of the method in the 'toHsBitspaceClassName' typeclass that -- constructs bitspace values.-toHsBitspaceFromValueName :: Bitspace -> String-toHsBitspaceFromValueName = ("to" ++) . toHsBitspaceTypeName+toHsBitspaceFromValueName :: Bitspace -> Generator String+toHsBitspaceFromValueName bitspace =+  inFunction "toHsBitspaceFromValueName" $+  addExtNameModule (bitspaceExtName bitspace) $ toHsBitspaceFromValueName' bitspace +-- | Pure version of 'toHsBitspaceFromValueName' that doesn't create a qualified name.+toHsBitspaceFromValueName' :: Bitspace -> String+toHsBitspaceFromValueName' = ("to" ++) . toHsBitspaceTypeName'+ -- | The name for the typeclass of types that can be represented as values of -- the given C++ class.-toHsValueClassName :: Class -> String-toHsValueClassName cls = toHsDataTypeName Nonconst cls ++ "Value"+toHsValueClassName :: Class -> Generator String+toHsValueClassName cls =+  inFunction "toHsValueClassName" $+  addExtNameModule (classExtName cls) $ toHsValueClassName' cls +-- | Pure version of 'toHsValueClassName' that doesn't create a qualified name.+toHsValueClassName' :: Class -> String+toHsValueClassName' cls = toHsDataTypeName' Nonconst cls ++ "Value"+ -- | The name of the method within the 'toHsValueClassName' typeclass for -- accessing an object of the type as a pointer.-toHsWithValuePtrName :: Class -> String-toHsWithValuePtrName cls = concat ["with", toHsDataTypeName Nonconst cls, "Ptr"]+toHsWithValuePtrName :: Class -> Generator String+toHsWithValuePtrName cls =+  inFunction "toHsWithValuePtrName" $+  addExtNameModule (classExtName cls) $ toHsWithValuePtrName' cls +-- | Pure version of 'toHsWithValuePtrName' that doesn't create a qualified name.+toHsWithValuePtrName' :: Class -> String+toHsWithValuePtrName' cls = concat ["with", toHsDataTypeName' Nonconst cls, "Ptr"]+ -- | The name for the typeclass of types that are (possibly const) pointers to -- objects of the given C++ class, or subclasses.-toHsPtrClassName :: Constness -> Class -> String-toHsPtrClassName cst cls = toHsDataTypeName cst cls ++ "Ptr"+toHsPtrClassName :: Constness -> Class -> Generator String+toHsPtrClassName cst cls =+  inFunction "toHsPtrClassName" $+  addExtNameModule (classExtName cls) $ toHsPtrClassName' cst cls +-- | Pure version of 'toHsPtrClassName' that doesn't create a qualified name.+toHsPtrClassName' :: Constness -> Class -> String+toHsPtrClassName' cst cls = toHsDataTypeName' cst cls ++ "Ptr"+ -- | The name of the function that upcasts pointers to the specific class type -- and constness.-toHsCastMethodName :: Constness -> Class -> String-toHsCastMethodName cst cls = "to" ++ toHsDataTypeName cst cls+toHsCastMethodName :: Constness -> Class -> Generator String+toHsCastMethodName cst cls =+  inFunction "toHsCastMethodName" $+  addExtNameModule (classExtName cls) $ toHsCastMethodName' cst cls +-- | Pure version of 'toHsCastMethodName' that doesn't create a qualified name.+toHsCastMethodName' :: Constness -> Class -> String+toHsCastMethodName' cst cls = "to" ++ toHsDataTypeName' cst cls+ -- | The name of the typeclass that provides a method to downcast to a specific -- class type.  See 'toHsDownCastMethodName'.-toHsDownCastClassName :: Constness -> Class -> String+toHsDownCastClassName :: Constness -> Class -> Generator String toHsDownCastClassName cst cls =-  concat [toHsDataTypeName Nonconst cls,+  inFunction "toHsDownCastClassName" $+  addExtNameModule (classExtName cls) $ toHsDownCastClassName' cst cls++-- | Pure version of 'toHsDownCastClassName' that doesn't create a qualified+-- name.+toHsDownCastClassName' :: Constness -> Class -> String+toHsDownCastClassName' cst cls =+  concat [toHsDataTypeName' Nonconst cls,           "Super",           case cst of             Const -> "Const"@@ -523,77 +695,167 @@  -- | The name of the function that downcasts pointers to the specific class type -- and constness.-toHsDownCastMethodName :: Constness -> Class -> String-toHsDownCastMethodName cst cls = "downTo" ++ toHsDataTypeName cst cls+toHsDownCastMethodName :: Constness -> Class -> Generator String+toHsDownCastMethodName cst cls =+  inFunction "toHsDownCastMethodName" $+  addExtNameModule (classExtName cls) $ toHsDownCastMethodName' cst cls +-- | Pure version of 'toHsDownCastMethodName' that doesn't create a qualified+-- name.+toHsDownCastMethodName' :: Constness -> Class -> String+toHsDownCastMethodName' cst cls = "downTo" ++ toHsDataTypeName' cst cls+ -- | The import name for the foreign function that casts between two specific -- pointer types.  Used for upcasting and downcasting.-toHsCastPrimitiveName :: Class -> Class -> String-toHsCastPrimitiveName from to =-  concat ["cast", toHsDataTypeName Nonconst from, "To", toHsDataTypeName Nonconst to]+--+-- We need to know which module the cast function resides in, and while we could+-- look this up, the caller always knows, so we just have them pass it in.+toHsCastPrimitiveName :: Class -> Class -> Class -> Generator String+toHsCastPrimitiveName descendentClass from to =+  inFunction "toHsCastPrimitiveName" $+  addExtNameModule (classExtName descendentClass) $ toHsCastPrimitiveName' from to +-- | Pure version of 'toHsCastPrimitiveName' that doesn't create a qualified+-- name.+toHsCastPrimitiveName' :: Class -> Class -> String+toHsCastPrimitiveName' from to =+  concat ["cast", toHsDataTypeName' Nonconst from, "To", toHsDataTypeName' Nonconst to]+ -- | The name of one of the functions that add/remove const to/from a class's -- pointer type.  Given 'Const', it will return the function that adds const, -- and given 'Nonconst', it will return the function that removes const.-toHsConstCastFnName :: Constness -> Class -> String+toHsConstCastFnName :: Constness -> Class -> Generator String toHsConstCastFnName cst cls =-  concat ["cast", toHsDataTypeName Nonconst cls,+  inFunction "toHsConstCastFnName" $+  addExtNameModule (classExtName cls) $ toHsConstCastFnName' cst cls++-- | Pure version of 'toHsConstCastFnName' that doesn't create a qualified name.+toHsConstCastFnName' :: Constness -> Class -> String+toHsConstCastFnName' cst cls =+  concat ["cast", toHsDataTypeName' Nonconst cls,           case cst of             Const -> "ToConst"             Nonconst -> "ToNonconst"]  -- | The name of the data type that represents a pointer to an object of the -- given class and constness.-toHsDataTypeName :: Constness -> Class -> String-toHsDataTypeName cst cls = toHsTypeName cst $ classExtName cls+toHsDataTypeName :: Constness -> Class -> Generator String+toHsDataTypeName cst cls =+  inFunction "toHsDataTypeName" $+  addExtNameModule (classExtName cls) $ toHsDataTypeName' cst cls +-- | Pure version of 'toHsDataTypeName' that doesn't create a qualified name.+toHsDataTypeName' :: Constness -> Class -> String+toHsDataTypeName' cst cls = toHsTypeName' cst $ classExtName cls+ -- | The name of a data constructor for one of the object pointer types.-toHsDataCtorName :: Managed -> Constness -> Class -> String-toHsDataCtorName m cst cls = case m of+toHsDataCtorName :: Managed -> Constness -> Class -> Generator String+toHsDataCtorName m cst cls =+  inFunction "toHsDataCtorName" $+  addExtNameModule (classExtName cls) $ toHsDataCtorName' m cst cls++-- | Pure version of 'toHsDataCtorName' that doesn't create a qualified name.+toHsDataCtorName' :: Managed -> Constness -> Class -> String+toHsDataCtorName' m cst cls = case m of   Unmanaged -> base   Managed -> base ++ "Gc"-  where base = toHsDataTypeName cst cls+  where base = toHsDataTypeName' cst cls  -- | The name of the foreign function import wrapping @delete@ for the given -- class type.  This is in internal to the binding; normal users should use -- 'Foreign.Hoppy.Runtime.delete'.-toHsClassDeleteFnName :: Class -> String-toHsClassDeleteFnName cls = 'd':'e':'l':'e':'t':'e':'\'':toHsDataTypeName Nonconst cls+--+-- This is internal to a generated Haskell module, so it does not have a public+-- (qualified) form.+toHsClassDeleteFnName' :: Class -> String+toHsClassDeleteFnName' cls = 'd':'e':'l':'e':'t':'e':'\'':toHsDataTypeName' Nonconst cls  -- | The name of the foreign import that imports the same function as -- 'toHsClassDeleteFnName', but as a 'Foreign.Ptr.FunPtr' rather than an actual -- function.-toHsClassDeleteFnPtrName :: Class -> String-toHsClassDeleteFnPtrName cls =-  'd':'e':'l':'e':'t':'e':'P':'t':'r':'\'':toHsDataTypeName Nonconst cls+--+-- This is internal to a generated Haskell module, so it does not have a public+-- (qualified) form.+toHsClassDeleteFnPtrName' :: Class -> String+toHsClassDeleteFnPtrName' cls =+  'd':'e':'l':'e':'t':'e':'P':'t':'r':'\'':toHsDataTypeName' Nonconst cls +-- | Returns the name of the Haskell function that invokes the given+-- constructor.+toHsCtorName :: Class -> Ctor -> Generator String+toHsCtorName cls ctor =+  inFunction "toHsCtorName" $+  toHsClassEntityName cls $ fromExtName $ ctorExtName ctor++-- | Pure version of 'toHsCtorName' that doesn't create a qualified name.+toHsCtorName' :: Class -> Ctor -> String+toHsCtorName' cls ctor =+  toHsClassEntityName' cls $ fromExtName $ ctorExtName ctor+ -- | Returns the name of the Haskell function that invokes the given method.------ See also 'getClassyExtName'.-toHsMethodName :: Class -> Method -> String-toHsMethodName cls method = toHsMethodName' cls $ fromExtName $ methodExtName method+toHsMethodName :: Class -> Method -> Generator String+toHsMethodName cls method =+  inFunction "toHsMethodName" $+  toHsClassEntityName cls $ fromExtName $ methodExtName method --- | Returns the name of the Haskell function that invokes a method with a--- specific name in a class.-toHsMethodName' :: IsFnName String name => Class -> name -> String-toHsMethodName' cls methodName =-  lowerFirst $-  concat [fromExtName $ classExtName cls, "_",-          case toFnName methodName of-            FnName name -> name-            FnOp op -> fromExtName $ operatorPreferredExtName op]+-- | Pure version of 'toHsMethodName' that doesn't create a qualified name.+toHsMethodName' :: Class -> Method -> String+toHsMethodName' cls method =+  toHsClassEntityName' cls $ fromExtName $ methodExtName method +-- | Returns the name of the Haskell function for an entity in a class.+toHsClassEntityName :: IsFnName String name => Class -> name -> Generator String+toHsClassEntityName cls name =+  addExtNameModule (classExtName cls) $ toHsClassEntityName' cls name++-- | Pure version of 'toHsClassEntityName' that doesn't create a qualified name.+toHsClassEntityName' :: IsFnName String name => Class -> name -> String+toHsClassEntityName' cls name =+  lowerFirst $ fromExtName $+  classEntityForeignName' cls $+  case toFnName name of+    FnName name -> toExtName name+    FnOp op -> operatorPreferredExtName op+ -- | The name of the function that takes a Haskell function and wraps it in a -- callback object.  This is internal to the binding; normal users can pass -- Haskell functions to be used as callbacks inplicitly.-toHsCallbackCtorName :: Callback -> String-toHsCallbackCtorName = toHsFnName . callbackExtName+toHsCallbackCtorName :: Callback -> Generator String+toHsCallbackCtorName callback =+  inFunction "toHsCallbackCtorName" $+  addExtNameModule (callbackExtName callback) $ toHsCallbackCtorName' callback +-- | Pure version of 'toHsCallbackCtorName' that doesn't create a qualified+-- name.+toHsCallbackCtorName' :: Callback -> String+toHsCallbackCtorName' callback =+  toHsFnName' $ toExtName $ fromExtName (callbackExtName callback) ++ "_new"++-- | The name of the function that takes a Haskell function with Haskell-side+-- types and wraps it in a 'Foreign.Ptr.FunPtr' that does appropriate+-- conversions to and from C-side types.+toHsCallbackNewFunPtrFnName :: Callback -> Generator String+toHsCallbackNewFunPtrFnName callback =+  inFunction "toHsCallbackNewFunPtrFnName" $+  addExtNameModule (callbackExtName callback) $ toHsCallbackNewFunPtrFnName' callback++-- | Pure version of 'toHsCallbackNewFunPtrFnName' that doesn't create a qualified+-- name.+toHsCallbackNewFunPtrFnName' :: Callback -> String+toHsCallbackNewFunPtrFnName' callback =+  toHsFnName' $ toExtName $ fromExtName (callbackExtName callback) ++ "_newFunPtr"+ -- | Converts an external name into a name suitable for a Haskell function or -- variable.-toHsFnName :: ExtName -> String-toHsFnName = lowerFirst . fromExtName+toHsFnName :: ExtName -> Generator String+toHsFnName extName =+  inFunction "toHsFnName" $+  addExtNameModule extName $ toHsFnName' extName +-- | Pure version of 'toHsFnName' that doesn't create a qualified name.+toHsFnName' :: ExtName -> String+toHsFnName' = lowerFirst . fromExtName+ -- | Returns a distinct argument variable name for each nonnegative number. toArgName :: Int -> String toArgName = ("arg'" ++) . show@@ -652,15 +914,16 @@       addImports hsImportForSystemPosixTypes $> HsTyCon (UnQual $ HsIdent "HoppySPT.CSsize")     Internal_TEnum e -> HsTyCon . UnQual . HsIdent <$> case side of       HsCSide -> addImports hsImportForForeignC $> "HoppyFC.CInt"-      HsHsSide -> importHsModuleForExtName (enumExtName e) $> toHsEnumTypeName e+      HsHsSide -> toHsEnumTypeName e     Internal_TBitspace b -> case side of       HsCSide -> cppTypeToHsTypeAndUse side $ bitspaceType b-      HsHsSide -> importHsModuleForExtName (bitspaceExtName b) $>-                  HsTyCon (UnQual $ HsIdent $ toHsBitspaceTypeName b)+      HsHsSide -> do+        typeName <- toHsBitspaceTypeName b+        return $ HsTyCon $ UnQual $ HsIdent typeName     Internal_TPtr (Internal_TObj cls) -> do       -- Same as TPtr (TConst (TObj cls)), but nonconst.-      importHsModuleForExtName (classExtName cls)-      let dataType = HsTyCon $ UnQual $ HsIdent $ toHsTypeName Nonconst $ classExtName cls+      typeName <- toHsTypeName Nonconst $ classExtName cls+      let dataType = HsTyCon $ UnQual $ HsIdent typeName       case side of         HsCSide -> do           addImports hsImportForForeign@@ -668,23 +931,16 @@         HsHsSide -> return dataType     Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> do       -- Same as TPtr (TObj cls), but const.-      importHsModuleForExtName (classExtName cls)-      let dataType = HsTyCon $ UnQual $ HsIdent $ toHsTypeName Const $ classExtName cls+      typeName <- toHsTypeName Const $ classExtName cls+      let dataType = HsTyCon $ UnQual $ HsIdent typeName       case side of         HsCSide -> do           addImports hsImportForForeign           return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") dataType         HsHsSide -> return dataType-    Internal_TPtr (Internal_TFn paramTypes retType) -> do-      paramHsTypes <- mapM (cppTypeToHsTypeAndUse side) paramTypes-      retHsType <- cppTypeToHsTypeAndUse side retType-      sideFn <- case side of-        HsCSide -> do addImports hsImportForForeign-                      return $ HsTyApp $ HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr"-        HsHsSide -> return id-      addImports hsImportForPrelude-      return $ sideFn $-        foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes+    Internal_TPtr fn@(Internal_TFn {}) -> do+      addImports hsImportForForeign+      HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") <$> cppTypeToHsTypeAndUse HsCSide fn     Internal_TPtr t' -> do       addImports hsImportForForeign       -- Pointers to types not covered above point to raw C++ values, so we need@@ -698,7 +954,7 @@       return $         foldr HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") retHsType) paramHsTypes     Internal_TCallback cb -> do-      hsType <- cppTypeToHsTypeAndUse side $ callbackToTFn cb+      hsType <- cppTypeToHsTypeAndUse side =<< callbackToTFn side cb       case side of         HsHsSide -> return hsType         HsCSide -> do@@ -706,11 +962,11 @@           return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsType     Internal_TObj cls -> case side of       HsCSide -> cppTypeToHsTypeAndUse side $ ptrT $ constT t-      HsHsSide -> case getClassHaskellConversion cls of+      HsHsSide -> case classHaskellConversionType $ getClassHaskellConversion cls of+        Just typeGen -> typeGen         Nothing ->           throwError $ concat           ["Expected a Haskell type for ", show cls, " but there isn't one"]-        Just c -> classHaskellConversionType c     Internal_TObjToHeap cls -> cppTypeToHsTypeAndUse side $ ptrT $ objT cls     Internal_TToGc t' -> case t' of       Internal_TRef _ -> cppTypeToHsTypeAndUse side t'  -- References behave the same as pointers.@@ -719,17 +975,36 @@       _ -> throwError $ tToGcInvalidFormErrorMessage Nothing t'     Internal_TConst t' -> cppTypeToHsTypeAndUse side t' --- | Returns the 'ClassHaskellConversion' of a class, if it has one.-getClassHaskellConversion :: Class -> Maybe ClassHaskellConversion-getClassHaskellConversion cls = case classHaskellConversion $ classConversion cls of-  ClassConversionNone -> Nothing-  ClassConversionManual c -> Just c-  ClassConversionToHeap -> Nothing-  ClassConversionToGc -> Nothing+-- | Returns the 'ClassHaskellConversion' of a class.+getClassHaskellConversion :: Class -> ClassHaskellConversion+getClassHaskellConversion = classHaskellConversion . classConversion +-- | Constructs the function type for a callback.  For Haskell, the type depends+-- on the side; the C++ side has additional parameters.+--+-- Keep this in sync with the C++ generator's version.+callbackToTFn :: HsTypeSide -> Callback -> Generator Type+callbackToTFn side cb = do+  needsExcParams <- case side of+    HsCSide -> mayThrow+    HsHsSide -> return False+  return $ Internal_TFn ((if needsExcParams then addExcParams else id) $ callbackParams cb)+                        (callbackReturn cb)++  where mayThrow = case callbackThrows cb of+          Just t -> return t+          Nothing -> moduleCallbacksThrow <$> askModule >>= \mt -> case mt of+            Just t -> return t+            Nothing -> interfaceCallbacksThrow <$> askInterface++        addExcParams = (++ [ptrT intT, ptrT $ ptrT voidT])+ -- | Prints a value like 'P.prettyPrint', but removes newlines so that they -- don't cause problems with this module's textual generation.  Should be mainly -- used for printing types; stripping newlines from definitions for example -- could go badly. prettyPrint :: P.Pretty a => a -> String-prettyPrint = filter (/= '\n') . P.prettyPrint+prettyPrint = collapseSpaces . filter (/= '\n') . P.prettyPrint+  where collapseSpaces (' ':xs) = ' ' : collapseSpaces (dropWhile (== ' ') xs)+        collapseSpaces (x:xs) = x : collapseSpaces xs+        collapseSpaces [] = []

@@ -27,1336 +27,1659 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>), pure) #endif-import Control.Arrow ((&&&), second)-import Control.Monad (forM, unless, when)-#if MIN_VERSION_mtl(2,2,1)-import Control.Monad.Except (throwError)-#else-import Control.Monad.Error (throwError)-#endif-import Control.Monad.Trans (lift)-import Control.Monad.Writer (execWriterT, tell)-import Data.Foldable (forM_)-import Data.Graph (SCC (AcyclicSCC, CyclicSCC), stronglyConnComp)-import Data.List (intersperse)-import qualified Data.Map as M-import Data.Maybe (isJust, mapMaybe)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (mconcat)-#endif-import qualified Data.Set as S-import Foreign.Hoppy.Generator.Common-import Foreign.Hoppy.Generator.Spec-import Foreign.Hoppy.Generator.Types-import Foreign.Hoppy.Generator.Language.Cpp (-  classCastFnCppName,-  classDeleteFnCppName,-  externalNameToCpp,-  )-import Foreign.Hoppy.Generator.Language.Haskell-import Language.Haskell.Syntax (-  HsAsst,-  HsContext,-  HsName (HsIdent),-  HsQName (Special, UnQual),-  HsQualType (HsQualType),-  HsSpecialCon (HsUnitCon),-  HsType (HsTyApp, HsTyCon, HsTyFun, HsTyVar),-  )-import System.FilePath ((<.>), pathSeparator)---- | The in-memory result of generating Haskell code for an interface.-data Generation = Generation-  { generatedFiles :: M.Map FilePath String-    -- ^ A map from paths of generated files to the contents of those files.-    -- The file paths are relative paths below the Haskell generation root.-  }---- | Runs the C++ code generator against an interface.-generate :: Interface -> Either ErrorMsg Generation-generate iface = do-  -- Build the partial generation of each module.-  modPartials <- forM (M.elems $ interfaceModules iface) $ \m ->-    (,) m <$> execGenerator iface (getModuleName iface m) (generateSource m)--  -- Compute the strongly connected components.  If there is a nontrivial SCC,-  -- then there is a module import cycle that we'll have to break with hs-boot-  -- files.-  let partialsByHsName :: M.Map HsModuleName Partial-      partialsByHsName = M.fromList $ map ((partialModuleHsName &&& id) . snd) modPartials--      sccInput :: [((Module, Partial), Partial, [Partial])]-      sccInput = flip map modPartials $ \x@(_, p) ->-        (x, p,-         mapMaybe (flip M.lookup partialsByHsName . hsImportModule) $-         M.keys $ getHsImportSet $ outputImports $ partialOutput p)--      sccs :: [SCC (Module, Partial)]-      sccs = stronglyConnComp sccInput--  fileContents <- execWriterT $ forM_ sccs $ \scc -> case scc of-    AcyclicSCC (_, p) -> tell [finishPartial p "hs"]-    CyclicSCC mps -> do-      let cycleModNames = S.fromList $ map (partialModuleHsName . snd) mps-      forM_ mps $ \(m, p) -> do-        -- Create a boot partial.-        pBoot <- lift $ execGenerator iface (partialModuleHsName p) (generateBootSource m)--        -- Change the source and boot partials so that all imports of modules in-        -- this cycle are {-# SOURCE #-} imports.-        let p' = setSourceImports cycleModNames p-            pBoot' = setSourceImports cycleModNames pBoot--        -- Emit the completed partials.-        tell [finishPartial p' "hs", finishPartial pBoot' "hs-boot"]--  return $ Generation $ M.fromList fileContents--  where finishPartial :: Partial -> String -> (FilePath, String)-        finishPartial p fileExt =-          (listSubst '.' pathSeparator (partialModuleHsName p) <.> fileExt,-           prependExtensions $ renderPartial p)--        setSourceImports :: S.Set HsModuleName -> Partial -> Partial-        setSourceImports modulesToSourceImport p =-          let output = partialOutput p-              imports = outputImports output-              imports' = makeHsImportSet $-                         M.mapWithKey (setSourceImportIfIn modulesToSourceImport) $-                         getHsImportSet imports-              output' = output { outputImports = imports' }-          in p { partialOutput = output' }--        setSourceImportIfIn :: S.Set HsModuleName -> HsImportKey -> HsImportSpecs -> HsImportSpecs-        setSourceImportIfIn modulesToSourceImport key specs =-          if hsImportModule key `S.member` modulesToSourceImport-          then specs { hsImportSource = True }-          else specs--prependExtensions :: String -> String-prependExtensions = (prependExtensionsPrefix ++)--prependExtensionsPrefix :: String-prependExtensionsPrefix =-  -- MultiParamTypeClasses is necessary for instances of Decodable and-  -- Encodable.  FlexibleContexts is needed for the type signature of the-  -- function that wraps the actual callback function in callback creation-  -- functions.-  ---  -- FlexibleInstances and TypeSynonymInstances are enabled to allow conversions-  -- to and from String, which is really [Char].-  ---  -- UndecidableInstances is needed for instances of the form "SomeClassConstPtr-  -- a => SomeClassValue a", and overlapping instances are used for the overlap-  -- between these instances and instances of SomeClassValue for the class's-  -- native Haskell type, when it's convertible.  CPP is used for warning-free-  -- compatibility using overlapping instances with both GHC 7.8 and 7.10.-  ---  -- GeneralizedNewtypeDeriving is to enable automatic deriving of-  -- Data.Bits.Bits instances for bitspace newtypes.-  concat-  [ "{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving"-  , ", MultiParamTypeClasses, TypeSynonymInstances, UndecidableInstances #-}\n"-  , "#if !MIN_VERSION_base(4,8,0)\n"-  , "{-# LANGUAGE OverlappingInstances #-}\n"-  , "#endif\n\n"-  ]--generateSource :: Module -> Generator ()-generateSource m = do-  forM_ (moduleExports m) $ sayExport SayExportForeignImports-  forM_ (moduleExports m) $ sayExport SayExportDecls--generateBootSource :: Module -> Generator ()-generateBootSource m =-  forM_ (moduleExports m) $ sayExport SayExportBoot--data SayExportMode = SayExportForeignImports | SayExportDecls | SayExportBoot-                   deriving (Eq, Show)--sayExport :: SayExportMode -> Export -> Generator ()-sayExport mode export = do-  case export of-    ExportVariable v -> sayExportVar mode v-    ExportEnum enum -> sayExportEnum mode enum-    ExportBitspace bitspace -> sayExportBitspace mode bitspace-    ExportFn fn ->-      (sayExportFn mode <$> fnExtName <*> pure Nothing <*> fnPurity <*> fnParams <*> fnReturn) fn-    ExportClass cls -> sayExportClass mode cls-    ExportCallback cb -> sayExportCallback mode cb--  when (mode == SayExportDecls) $-    addendumHaskell $ exportAddendum export--sayExportVar :: SayExportMode -> Variable -> Generator ()-sayExportVar mode v = do-  withErrorContext ("generating variable " ++ show (varExtName v)) $ do-    let (isConst, deconstType) = case varType v of-          Internal_TConst t -> (True, t)-          t -> (False, t)-    sayExportFn mode (varGetterExtName v) Nothing Nonpure [] deconstType-    unless isConst $-      sayExportFn mode (varSetterExtName v) Nothing Nonpure [deconstType] voidT--sayExportEnum :: SayExportMode -> CppEnum -> Generator ()-sayExportEnum mode enum =-  withErrorContext ("generating enum " ++ show (enumExtName enum)) $-  case mode of-    -- Nothing to import from the C++ side of an enum.-    SayExportForeignImports -> return ()--    SayExportDecls -> do-      let hsTypeName = toHsEnumTypeName enum-          values :: [(Int, String)]-          values = map (second $ toHsEnumCtorName enum) $ enumValueNames enum-      addImports $ mconcat [hsImports "Prelude" ["($)", "(++)"], hsImportForPrelude]--      -- Print out the data declaration.-      ln-      addExport' hsTypeName-      saysLn ["data ", hsTypeName, " ="]-      indent $ do-        forM_ (zip (False:repeat True) values) $ \(cont, (_, hsCtorName)) ->-          saysLn [if cont then "| " else "", hsCtorName]-        sayLn "deriving (HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)"--      -- Print out the Enum instance.-      ln-      saysLn ["instance HoppyP.Enum ", hsTypeName, " where"]-      indent $ do-        forM_ values $ \(num, hsCtorName) ->-          saysLn ["fromEnum ", hsCtorName, " = ", show num]-        ln-        forM_ values $ \(num, hsCtorName) ->-          saysLn ["toEnum (", show num, ") = ", hsCtorName]-        saysLn ["toEnum n' = HoppyP.error $ ",-                show (concat ["Unknown ", hsTypeName, " numeric value: "]),-                " ++ HoppyP.show n'"]--    SayExportBoot -> do-      let hsTypeName = toHsEnumTypeName enum-      addImports hsImportForPrelude-      addExport hsTypeName-      ln-      saysLn ["data ", hsTypeName]-      saysLn ["instance HoppyP.Bounded ", hsTypeName]-      saysLn ["instance HoppyP.Enum ", hsTypeName]-      saysLn ["instance HoppyP.Eq ", hsTypeName]-      saysLn ["instance HoppyP.Ord ", hsTypeName]-      saysLn ["instance HoppyP.Show ", hsTypeName]--sayExportBitspace :: SayExportMode -> Bitspace -> Generator ()-sayExportBitspace mode bitspace =-  withErrorContext ("generating bitspace " ++ show (bitspaceExtName bitspace)) $-  let hsTypeName = toHsBitspaceTypeName bitspace-      fromFnName = toHsBitspaceToNumName bitspace-      className = toHsBitspaceClassName bitspace-      toFnName = toHsBitspaceFromValueName bitspace-      hsType = HsTyCon $ UnQual $ HsIdent hsTypeName-  in case mode of-    -- Nothing to import from the C++ side of a bitspace.-    SayExportForeignImports -> return ()--    SayExportDecls -> do-      let values :: [(Int, String)]-          values = map (second $ toHsBitspaceValueName bitspace) $ bitspaceValueNames bitspace--      hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace-      hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace--      -- Print out the data declaration and conversion functions.-      addImports $ mconcat [hsImportForBits, hsImportForPrelude, hsImportForRuntime]-      addExport' hsTypeName-      addExport' className-      ln-      saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ",-              fromFnName, " :: ", prettyPrint hsCNumType, " }"]-      indent $ sayLn "deriving (HoppyDB.Bits, HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)"-      ln-      saysLn ["class ", className, " a where"]-      indent $ do-        let tyVar = HsTyVar $ HsIdent "a"-        saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType]-      ln-      saysLn ["instance ", className, " (", prettyPrint hsCNumType, ") where"]-      indent $ saysLn [toFnName, " = ", hsTypeName]-      saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ") where"]-      indent $ saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral"]-      saysLn ["instance ", className, " ", hsTypeName, " where"]-      indent $ saysLn [toFnName, " = HoppyP.id"]--      -- If the bitspace has an associated enum, then print out a conversion-      -- instance for it as well.-      forM_ (bitspaceEnum bitspace) $ \enum -> do-        let enumTypeName = toHsEnumTypeName enum-        importHsModuleForExtName $ enumExtName enum-        addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime]-        ln-        saysLn ["instance ", className, " ", enumTypeName, " where"]-        indent $-          saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral . HoppyP.fromEnum"]--      -- Print out the constants.-      ln-      forM_ values $ \(num, valueName) -> do-        addExport valueName-        saysLn [valueName, " = ", hsTypeName, " ", show num]--    SayExportBoot -> do-      hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace-      hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace--      addImports $ mconcat [hsImportForBits, hsImportForPrelude]-      addExport' hsTypeName-      addExport' className-      ln-      saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ",-              fromFnName, " :: ", prettyPrint hsCNumType, " }"]-      ln-      saysLn ["instance HoppyDB.Bits ", hsTypeName]-      saysLn ["instance HoppyP.Bounded ", hsTypeName]-      saysLn ["instance HoppyP.Eq ", hsTypeName]-      saysLn ["instance HoppyP.Ord ", hsTypeName]-      saysLn ["instance HoppyP.Show ", hsTypeName]-      ln-      saysLn ["class ", className, " a where"]-      indent $ do-        let tyVar = HsTyVar $ HsIdent "a"-        saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType]-      ln-      saysLn ["instance ", className, " (", prettyPrint hsCNumType, ")"]-      saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ")"]-      saysLn ["instance ", className, " ", hsTypeName]-      forM_ (bitspaceEnum bitspace) $ \enum -> do-        let enumTypeName = toHsEnumTypeName enum-        importHsModuleForExtName $ enumExtName enum-        saysLn ["instance ", className, " ", enumTypeName]--sayExportFn :: SayExportMode-            -> ExtName-            -> Maybe (Constness, Class)-            -> Purity-            -> [Type]-            -> Type-            -> Generator ()-sayExportFn mode name methodInfo purity paramTypes retType =-  let hsFnName = toHsFnName name-      hsFnImportedName = hsFnName ++ "'"-  in case mode of-    SayExportForeignImports ->-      withErrorContext ("generating imports for function " ++ show name) $ do-        -- Print a "foreign import" statement.-        hsCType <- fnToHsTypeAndUse HsCSide methodInfo purity paramTypes retType-        saysLn ["foreign import ccall \"", externalNameToCpp name, "\" ", hsFnImportedName, " :: ",-                prettyPrint hsCType]--    SayExportDecls -> withErrorContext ("generating function " ++ show name) $ do-      -- Print the type signature.-      ln-      addExport hsFnName-      hsHsType <- fnToHsTypeAndUse HsHsSide methodInfo purity paramTypes retType-      saysLn [hsFnName, " :: ", prettyPrint hsHsType]--      case purity of-        Nonpure -> return ()-        Pure -> saysLn ["{-# NOINLINE ", hsFnName, " #-}"]--      -- Print the function body.-      let argNames = map toArgName [1..length paramTypes]-          argNamesWithThis = (if isJust methodInfo then ("this":) else id) argNames-          convertedArgNames = map (++ "'") argNames-      -- Operators on this line must bind more weakly than operators used below,-      -- namely ($) and (>>=).  (So finish the line with ($).)-      lineEnd <- case purity of-        Nonpure -> return [" ="]-        Pure -> do addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForUnsafeIO]-                   return [" = HoppySIU.unsafePerformIO $"]-      saysLn $ hsFnName : map (' ':) argNamesWithThis ++ lineEnd-      indent $ do-        forM_ (zip3 paramTypes argNames convertedArgNames) $ \(t, argName, argName') ->-          sayArgProcessing ToCpp t argName argName'--        sayCallAndProcessReturn ToCpp retType $-          hsFnImportedName :-          (case methodInfo of-             Just (cst, cls) -> " (" ++ toHsCastMethodName cst cls ++ " this)"-             Nothing -> "") :-          map (' ':) convertedArgNames--    SayExportBoot ->-      -- Functions (methods included) cannot be referenced from other exports,-      -- so we don't need to emit anything.-      return ()---- | Prints \"foreign import\" statements and an internal callback construction--- function for a given 'Callback' specification.  For example, for a callback--- of 'HsHsSide' type @Int -> String -> IO Int@, we will generate the following--- bindings:------ > foreign import ccall "wrapper" name'newFunPtr--- >   :: (CInt -> Ptr CChar -> IO CInt)--- >   -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt))--- >--- > -- (This is an ad-hoc generated binding for C++ callback impl class constructor.)--- > foreign import ccall "genpop__name_impl" name'newCallback--- >   :: FunPtr (CInt -> Ptr CChar -> IO CInt)--- >   -> FunPtr (FunPtr (IO ()) -> IO ())--- >   -> Bool--- >   -> IO (CCallback (CInt -> Ptr CChar -> IO CInt))--- >--- > name :: (CInt -> String -> IO CInt) -> IO (CCallback (CInt -> Ptr CChar -> IO CInt))--- > name f = do--- >   let cf arg1' arg2' = do--- >         arg1 <- return arg1'--- >         arg2 <- ...decode the string...--- >         f arg1 arg2 >>= return--- >   cfp <- name'newFunPtr cf--- >   name'newCallback cfp freeHaskellFunPtrFunPtr False------ Only the implementation of bindings that take a callback of this type will--- make use of this @name@ binding; @name@ is not useful to users of bindings.-sayExportCallback :: SayExportMode -> Callback -> Generator ()-sayExportCallback mode cb =-  withErrorContext ("generating callback " ++ show (callbackExtName cb)) $ do-    let name = callbackExtName cb-        paramTypes = callbackParams cb-        retType = callbackReturn cb-        fnType = callbackToTFn cb-        hsFnName = toHsCallbackCtorName cb-        hsFnName'newCallback = hsFnName ++ "'newCallback"-        hsFnName'newFunPtr = hsFnName ++ "'newFunPtr"--    hsFnCType <- cppTypeToHsTypeAndUse HsCSide fnType-    hsFnHsType <- cppTypeToHsTypeAndUse HsHsSide fnType--    let getWholeFnType = do-          addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]-          return $-            HsTyFun hsFnHsType $-            HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $-            HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType--    case mode of-      SayExportForeignImports -> do-        addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]-        let hsFunPtrType = HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType-            hsFunPtrImportType =-              HsTyFun hsFnCType $-              HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsFunPtrType-            hsCallbackCtorImportType =-              HsTyFun hsFunPtrType $-              HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $-                       HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $-                                HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $-                                HsTyCon $ Special HsUnitCon) $-                       HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $-                       HsTyCon $ Special HsUnitCon) $-              HsTyFun (HsTyCon $ UnQual $ HsIdent "HoppyP.Bool") $-              HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $-              HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType--        saysLn ["foreign import ccall \"wrapper\" ", hsFnName'newFunPtr, " :: ",-                prettyPrint hsFunPtrImportType]-        saysLn ["foreign import ccall \"", externalNameToCpp name, "\" ",-                hsFnName'newCallback, " :: ", prettyPrint hsCallbackCtorImportType]--      SayExportDecls -> do-        addExport hsFnName-        wholeFnType <- getWholeFnType-        let paramCount = length paramTypes-            argNames = map toArgName [1..paramCount]-            argNames' = map (++ "'") argNames-        ln-        saysLn [hsFnName, " :: ", prettyPrint wholeFnType]-        saysLn [hsFnName, " f'hs = do"]-        indent $ do-          sayLet-            [do saysLn ["f'c ", unwords argNames, " ="]-                indent $ do-                  forM_ (zip3 paramTypes argNames argNames') $ \(t, argName, argName') ->-                    sayArgProcessing FromCpp t argName argName'-                  sayCallAndProcessReturn FromCpp retType $-                    "f'hs" : map (' ':) argNames']-            Nothing-          saysLn ["f'p <- ", hsFnName'newFunPtr, " f'c"]-          saysLn [hsFnName'newCallback, " f'p HoppyFHR.freeHaskellFunPtrFunPtr HoppyP.False"]--      SayExportBoot -> do-        addExport hsFnName-        wholeFnType <- getWholeFnType-        ln-        saysLn [hsFnName, " :: ", prettyPrint wholeFnType]--data CallDirection =-  ToCpp  -- ^ Haskell code is calling out to C++.-  | FromCpp  -- ^ C++ is invoking a callback.--sayArgProcessing :: CallDirection -> Type -> String -> String -> Generator ()-sayArgProcessing dir t fromVar toVar =-  withErrorContext ("processing argument of type " ++ show t) $-  case t of-    Internal_TVoid -> throwError $ "TVoid is not a valid argument type"-    Internal_TBool -> case dir of-      ToCpp -> saysLn ["let ", toVar, " = if ", fromVar, " then 1 else 0 in"]-      FromCpp -> do addImports $ hsImport1 "Prelude" "(/=)"-                    saysLn ["let ", toVar, " = ", fromVar, " /= 0 in"]-    Internal_TChar -> noConversion-    Internal_TUChar -> noConversion-    Internal_TShort -> noConversion-    Internal_TUShort -> noConversion-    Internal_TInt -> sayCoerceIntegral-    Internal_TUInt -> noConversion-    Internal_TLong -> noConversion-    Internal_TULong -> noConversion-    Internal_TLLong -> noConversion-    Internal_TULLong -> noConversion-    Internal_TFloat -> sayCoerceFloating-    Internal_TDouble -> sayCoerceFloating-    Internal_TInt8 -> noConversion-    Internal_TInt16 -> noConversion-    Internal_TInt32 -> noConversion-    Internal_TInt64 -> noConversion-    Internal_TWord8 -> noConversion-    Internal_TWord16 -> noConversion-    Internal_TWord32 -> noConversion-    Internal_TWord64 -> noConversion-    Internal_TPtrdiff -> noConversion-    Internal_TSize -> noConversion-    Internal_TSSize -> noConversion-    Internal_TEnum _ -> do-      addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForPrelude, hsImportForRuntime]-      saysLn ["let ", toVar,-              -- TODO The coersion here is unnecssary if we replace the C numeric-              -- types with their Haskell ones across the board (e.g. CInt ->-              -- Int).-              case dir of-                ToCpp -> " = HoppyFHR.coerceIntegral $ HoppyP.fromEnum "-                FromCpp -> " = HoppyP.toEnum $ HoppyFHR.coerceIntegral ",-              fromVar, " in"]-    Internal_TBitspace b -> do-      importHsModuleForExtName $ bitspaceExtName b-      saysLn $ concat [ ["let ", toVar, " = "]-                      , case dir of-                          ToCpp -> [toHsBitspaceToNumName b, " $ ", toHsBitspaceFromValueName b]-                          FromCpp -> [toHsBitspaceTypeName b],-                        [" ", fromVar, " in"]-                      ]-    -- References and pointers are handled equivalently.-    Internal_TPtr (Internal_TObj cls) -> do-      addImportForClass cls-      case dir of-        ToCpp -> do-          addImports $ mconcat [hsImport1 "Prelude" "($)",-                                hsImportForRuntime]-          saysLn ["HoppyFHR.withCppPtr (", toHsCastMethodName Nonconst cls, " ", fromVar,-                  ") $ \\", toVar, " ->"]-        FromCpp ->-          saysLn ["let ", toVar, " = ", toHsDataCtorName Unmanaged Nonconst cls,-                  " ", fromVar, " in"]-    Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> do-      addImportForClass cls-      case dir of-        ToCpp -> do-          -- Same as the (TObj _), ToCpp case.-          addImports $ mconcat [hsImport1 "Prelude" "($)",-                                hsImportForPrelude,-                                hsImportForRuntime]-          saysLn [toHsWithValuePtrName cls, " ", fromVar,-                  " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"]-        FromCpp ->-          saysLn ["let ", toVar, " = ", toHsDataCtorName Unmanaged Const cls,-                  " ", fromVar, " in"]-    Internal_TPtr _ -> noConversion-    Internal_TRef t' -> sayArgProcessing dir (ptrT t') fromVar toVar-    Internal_TFn {} -> throwError "TFn unimplemented"-    Internal_TCallback cb -> case dir of-      ToCpp -> do-        addImports $ hsImport1 "Prelude" "(>>=)"-        importHsModuleForExtName $ callbackExtName cb-        saysLn [toHsCallbackCtorName cb, " ", fromVar, " >>= \\", toVar, " ->"]-      FromCpp -> throwError "Can't receive a callback from C++"-    Internal_TObj cls -> case dir of-      ToCpp -> do-        -- Same as the (TPtr (TConst (TObj _))), ToPtr case.-        addImportForClass cls-        addImports $ mconcat [hsImport1 "Prelude" "($)",-                              hsImportForPrelude,-                              hsImportForRuntime]-        saysLn [toHsWithValuePtrName cls, " ", fromVar,-                " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"]-      FromCpp -> case classHaskellConversion $ classConversion cls of-        ClassConversionNone ->-          throwError $ concat-          ["Can't pass a TObj of ", show cls,-           " from C++ to Haskell because no class conversion is defined"]-        ClassConversionManual _ -> do-          addImportForClass cls-          addImports $ mconcat [hsImport1 "Prelude" "(>>=)",-                                hsImportForRuntime]-          saysLn ["HoppyFHR.decode (", toHsDataCtorName Unmanaged Const cls, " ",-                  fromVar, ") >>= \\", toVar, " ->"]-        ClassConversionToHeap -> sayArgProcessing dir (objToHeapT cls) fromVar toVar-        ClassConversionToGc -> sayArgProcessing dir (toGcT t) fromVar toVar-    Internal_TObjToHeap cls -> case dir of-      ToCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls-      FromCpp -> sayArgProcessing dir (ptrT $ objT cls) fromVar toVar-    Internal_TToGc t' -> case dir of-      ToCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t'-      FromCpp -> do-        addImports $ mconcat [hsImport1 "Prelude" "(>>=)",-                              hsImportForRuntime]-        saysLn ["HoppyFHR.toGc ", fromVar, " >>= \\", toVar, " ->"]-    Internal_TConst t' -> sayArgProcessing dir t' fromVar toVar-  where noConversion = saysLn ["let ", toVar, " = ", fromVar, " in"]-        sayCoerceIntegral = do-          addImports hsImportForRuntime-          saysLn ["let ", toVar, " = HoppyFHR.coerceIntegral ", fromVar, " in"]-        sayCoerceFloating = do-          addImports hsImportForPrelude-          saysLn ["let ", toVar, " = HoppyP.realToFrac ", fromVar, " in"]---- | Note that the 'CallDirection' is the direction of the call, not the--- direction of the return.  'ToCpp' means we're returning to the foreign--- language, 'FromCpp' means we're returning from it.-sayCallAndProcessReturn :: CallDirection -> Type -> [String] -> Generator ()-sayCallAndProcessReturn dir t callWords =-  withErrorContext ("processing return value of type " ++ show t) $-  case t of-    Internal_TVoid -> sayCall-    Internal_TBool -> do-      case dir of-        ToCpp -> do addImports $ mconcat [hsImport1 "Prelude" "(/=)", hsImportForPrelude]-                    sayLn "HoppyP.fmap (/= 0)"-        FromCpp -> sayLn "HoppyP.fmap (\\x -> if x then 1 else 0)"-      sayCall-    Internal_TChar -> sayCall-    Internal_TUChar -> sayCall-    Internal_TShort -> sayCall-    Internal_TUShort -> sayCall-    Internal_TInt -> sayCoerceIntegral >> sayCall-    Internal_TUInt -> sayCall-    Internal_TLong -> sayCall-    Internal_TULong -> sayCall-    Internal_TLLong -> sayCall-    Internal_TULLong -> sayCall-    Internal_TFloat -> sayCoerceFloating >> sayCall-    Internal_TDouble -> sayCoerceFloating >> sayCall-    Internal_TInt8 -> sayCall-    Internal_TInt16 -> sayCall-    Internal_TInt32 -> sayCall-    Internal_TInt64 -> sayCall-    Internal_TWord8 -> sayCall-    Internal_TWord16 -> sayCall-    Internal_TWord32 -> sayCall-    Internal_TWord64 -> sayCall-    Internal_TPtrdiff -> sayCall-    Internal_TSize -> sayCall-    Internal_TSSize -> sayCall-    Internal_TEnum _ -> do-      addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime]-      case dir of-        -- TODO The coersion here is unnecssary if we replace the C numeric types-        -- with their Haskell ones across the board (e.g. CInt -> Int).-        ToCpp -> saysLn ["HoppyP.fmap (HoppyP.toEnum . HoppyFHR.coerceIntegral)"]-        FromCpp -> saysLn ["HoppyP.fmap (HoppyFHR.coerceIntegral . HoppyP.fromEnum)"]-      sayCall-    Internal_TBitspace b -> do-      addImports hsImportForPrelude-      importHsModuleForExtName $ bitspaceExtName b-      saysLn ["HoppyP.fmap ", bitspaceConvFn dir b]-      sayCall-    -- The same as TPtr (TConst (TObj _)), but nonconst.-    Internal_TPtr (Internal_TObj cls) -> do-      addImportForClass cls-      case dir of-        ToCpp -> do-          addImports hsImportForPrelude-          saysLn ["HoppyP.fmap ", toHsDataCtorName Unmanaged Nonconst cls]-          sayCall-        FromCpp -> do-          addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]-          sayLn "HoppyP.fmap HoppyFHR.toPtr"-          sayCall-    -- The same as TPtr (TConst (TObj _)), but nonconst.-    Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> do-      addImportForClass cls-      case dir of-        ToCpp -> do-          addImports hsImportForPrelude-          saysLn ["HoppyP.fmap ", toHsDataCtorName Unmanaged Const cls]-          sayCall-        FromCpp -> do-          addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]-          sayLn "HoppyP.fmap HoppyFHR.toPtr"-          sayCall-    Internal_TPtr _ -> sayCall-    Internal_TRef t' -> sayCallAndProcessReturn dir (ptrT t') callWords-    Internal_TFn {} -> throwError "TFn unimplemented"-    Internal_TCallback cb -> case dir of-      ToCpp -> throwError "Can't receive a callback from C++"-      FromCpp -> do-        addImports $ hsImport1 "Prelude" "(=<<)"-        importHsModuleForExtName $ callbackExtName cb-        saysLn [toHsCallbackCtorName cb, "=<<"]-        sayCall-    Internal_TObj cls -> case dir of-      ToCpp -> case classHaskellConversion $ classConversion cls of-        ClassConversionNone ->-          throwError $ concat-          ["Can't return a TObj of ", show cls,-           " from C++ to Haskell because no class conversion is defined"]-        ClassConversionManual _ -> do-          addImportForClass cls-          addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"],-                                hsImportForRuntime]-          saysLn ["(HoppyFHR.decodeAndDelete . ", toHsDataCtorName Unmanaged Const cls, ") =<<"]-          sayCall-        ClassConversionToHeap -> sayCallAndProcessReturn dir (objToHeapT cls) callWords-        ClassConversionToGc -> sayCallAndProcessReturn dir (toGcT t) callWords-      FromCpp -> do-        addImportForClass cls-        addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"],-                              hsImportForPrelude,-                              hsImportForRuntime]-        sayLn "(HoppyP.fmap (HoppyFHR.toPtr) . HoppyFHR.encode) =<<"-        sayCall-    Internal_TObjToHeap cls -> case dir of-      ToCpp -> sayCallAndProcessReturn dir (ptrT $ objT cls) callWords-      FromCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls-    Internal_TToGc t' -> case dir of-      ToCpp -> do-        addImports $ mconcat [hsImport1 "Prelude" "(=<<)",-                              hsImportForRuntime]-        sayLn "HoppyFHR.toGc =<<"-        -- TToGc (TObj _) should create a pointer rather than decoding, so we-        -- change the TObj _ into a TPtr (TObj _).-        case t' of-          Internal_TObj _ -> sayCallAndProcessReturn dir (ptrT t') callWords-          _ -> sayCallAndProcessReturn dir t' callWords-      FromCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t'-    Internal_TConst t' -> sayCallAndProcessReturn dir t' callWords-  where sayCall = saysLn $ "(" : callWords ++ [")"]-        sayCoerceIntegral = do addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]-                               sayLn "HoppyP.fmap HoppyFHR.coerceIntegral"-        sayCoerceFloating = do addImports hsImportForPrelude-                               sayLn "HoppyP.fmap HoppyP.realToFrac"-        bitspaceConvFn dir = case dir of-          ToCpp -> toHsBitspaceTypeName-          FromCpp -> toHsBitspaceToNumName--sayExportClass :: SayExportMode -> Class -> Generator ()-sayExportClass mode cls = do-  case mode of-    SayExportForeignImports -> do-      sayExportClassHsCtors mode cls--      forM_ (classMethods cls) $ \method ->-        (sayExportFn mode <$> getClassyExtName cls <*> pure Nothing <*> methodPurity <*>-         pure (getMethodEffectiveParams cls method) <*> methodReturn) method--    SayExportDecls -> do-      sayExportClassHsClass True cls Const-      sayExportClassHsClass True cls Nonconst--      sayExportClassHsStaticMethods cls--      -- Create a newtype for referencing foreign objects with pointers.  The-      -- newtype is not used with encodings of value objects.-      sayExportClassHsType True cls Const-      sayExportClassHsType True cls Nonconst--      sayExportClassHsCtors mode cls--    SayExportBoot -> do-      sayExportClassHsClass False cls Const-      sayExportClassHsClass False cls Nonconst--      sayExportClassHsType False cls Const-      sayExportClassHsType False cls Nonconst--  sayExportClassCastPrimitives mode cls-  sayExportClassHsSpecialFns mode cls--sayExportClassHsClass :: Bool -> Class -> Constness -> Generator ()-sayExportClassHsClass doDecls cls cst = do-  let hsTypeName = toHsDataTypeName cst cls-      hsValueClassName = toHsValueClassName cls-      hsWithValuePtrName = toHsWithValuePtrName cls-      hsPtrClassName = toHsPtrClassName cst cls-      hsCastMethodName = toHsCastMethodName cst cls-      supers = classSuperclasses cls--  forM_ supers $ importHsModuleForExtName . classExtName-  hsSupers <--    (\x -> if null x-           then do addImports hsImportForRuntime-                   return ["HoppyFHR.CppPtr"]-           else return x) $-    case cst of-      Const -> map (toHsPtrClassName Const) supers-      Nonconst -> toHsPtrClassName Const cls : map (toHsPtrClassName Nonconst) supers--  -- Print the value class definition.  There is only one of these, and it is-  -- spiritually closer to the const version of the pointers for this class, so-  -- we emit for the const case only.-  when (cst == Const) $ do-    addImports hsImportForPrelude-    addExport' hsValueClassName-    ln-    saysLn ["class ", hsValueClassName, " a where"]-    indent $-      saysLn [hsWithValuePtrName, " :: a -> (", hsTypeName, " -> HoppyP.IO b) -> HoppyP.IO b"]--    -- Generate instances for all pointer subtypes.-    ln-    saysLn ["#if MIN_VERSION_base(4,8,0)"]-    saysLn ["instance {-# OVERLAPPABLE #-} ", hsPtrClassName, " a => ", hsValueClassName, " a",-            if doDecls then " where" else ""]-    saysLn ["#else"]-    saysLn ["instance ", hsPtrClassName, " a => ", hsValueClassName, " a",-            if doDecls then " where" else ""]-    saysLn ["#endif"]-    when doDecls $ do-      addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"],-                            hsImportForPrelude]-      indent $ saysLn [hsWithValuePtrName, " = HoppyP.flip ($) . ", hsCastMethodName]--    -- When the class has a native Haskell type, also print an instance for it.-    forM_ (getClassHaskellConversion cls) $ \conv -> do-      hsType <- classHaskellConversionType conv-      ln-      saysLn ["#if MIN_VERSION_base(4,8,0)"]-      saysLn ["instance {-# OVERLAPPING #-} ", hsValueClassName, " (", prettyPrint hsType, ")",-              if doDecls then " where" else ""]-      saysLn ["#else"]-      saysLn ["instance ", hsValueClassName, " (", prettyPrint hsType, ")",-              if doDecls then " where" else ""]-      saysLn ["#endif"]-      when doDecls $ do-        addImports hsImportForRuntime-        indent $ saysLn [hsWithValuePtrName, " = HoppyFHR.withCppObj"]--  -- Print the pointer class definition.-  addExport' hsPtrClassName-  ln-  saysLn $-    "class (" :-    intersperse ", " (map (++ " this") hsSupers) ++-    [") => ", hsPtrClassName, " this where"]-  indent $ saysLn [hsCastMethodName, " :: this -> ", hsTypeName]--  -- Print the non-static methods.-  when doDecls $ do-    let methods = filter ((cst ==) . methodConst) $ classMethods cls-    forM_ methods $ \method ->-      when (methodStatic method == Nonstatic) $-      (sayExportFn SayExportDecls <$> getClassyExtName cls <*> pure Nothing <*>-       methodPurity <*> pure (getMethodEffectiveParams cls method) <*>-       methodReturn) method--sayExportClassHsStaticMethods :: Class -> Generator ()-sayExportClassHsStaticMethods cls =-  forM_ (classMethods cls) $ \method ->-    when (methodStatic method == Static) $-    (sayExportFn SayExportDecls <$> getClassyExtName cls <*> pure Nothing <*> methodPurity <*>-     methodParams <*> methodReturn) method--sayExportClassHsType :: Bool -> Class -> Constness -> Generator ()-sayExportClassHsType doDecls cls cst = do-  addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]-  -- Unfortunately, we must export the data constructor, so that GHC can marshal-  -- it in foreign calls in other modules.-  addExport' hsTypeName-  ln-  saysLn ["data ", hsTypeName, " ="]-  indent $ do-    saysLn ["  ", hsCtor, " (HoppyF.Ptr ", hsTypeName, ")"]-    saysLn ["| ", hsCtorGc, " (HoppyF.ForeignPtr ()) (HoppyF.Ptr ", hsTypeName, ")"]-  when doDecls $ do-    addImports $ hsImport1 "Prelude" "(==)"-    indent $ sayLn "deriving (HoppyP.Show)"-    ln-    saysLn ["instance HoppyP.Eq ", hsTypeName, " where"]-    indent $ saysLn ["x == y = HoppyFHR.toPtr x == HoppyFHR.toPtr y"]-    ln-    saysLn ["instance HoppyP.Ord ", hsTypeName, " where"]-    indent $ saysLn ["compare x y = HoppyP.compare (HoppyFHR.toPtr x) (HoppyFHR.toPtr y)"]--  -- Generate const_cast functions:-  --   castFooToConst :: Foo -> FooConst-  --   castFooToNonconst :: FooConst -> Foo-  ln-  let constCastFnName = toHsConstCastFnName cst cls-  addExport constCastFnName-  saysLn [constCastFnName, " :: ", toHsDataTypeName (constNegate cst) cls, " -> ", hsTypeName]-  when doDecls $ do-    addImports $ hsImport1 "Prelude" "($)"-    saysLn [constCastFnName, " (", toHsDataCtorName Unmanaged (constNegate cst) cls,-            " ptr') = ", hsCtor, " $ HoppyF.castPtr ptr'"]-    saysLn [constCastFnName, " (", toHsDataCtorName Managed (constNegate cst) cls,-            " fptr' ptr') = ", hsCtorGc, " fptr' $ HoppyF.castPtr ptr'"]--  -- Generate an instance of CppPtr.-  ln-  if doDecls-    then do addImports $ hsImport1 "Prelude" "($)"-            saysLn ["instance HoppyFHR.CppPtr ", hsTypeName, " where"]-            indent $ do-              saysLn ["nullptr = ", toHsDataCtorName Unmanaged cst cls, " HoppyF.nullPtr"]-              ln-              saysLn ["withCppPtr (", hsCtor, " ptr') f' = f' ptr'"]-              saysLn ["withCppPtr (", hsCtorGc,-                      " fptr' ptr') f' = HoppyF.withForeignPtr fptr' $ \\_ -> f' ptr'"]-              ln-              saysLn ["toPtr (", hsCtor, " ptr') = ptr'"]-              saysLn ["toPtr (", hsCtorGc, " _ ptr') = ptr'"]-              ln-              saysLn ["touchCppPtr (", hsCtor, " _) = HoppyP.return ()"]-              saysLn ["touchCppPtr (", hsCtorGc, " fptr' _) = HoppyF.touchForeignPtr fptr'"]-            when (classDtorIsPublic cls) $ do-              addImports $ hsImport1 "Prelude" "(==)"-              ln-              saysLn ["instance HoppyFHR.Deletable ", hsTypeName, " where"]-              indent $ do-                saysLn $-                  "delete (" : toHsDataCtorName Unmanaged cst cls : " ptr') = " :-                  toHsClassDeleteFnName cls :-                  case cst of-                    Const -> [" ptr'"]-                    Nonconst -> [" $ (HoppyF.castPtr ptr' :: HoppyF.Ptr ",-                                 toHsDataTypeName Const cls, ")"]-                saysLn ["delete (", toHsDataCtorName Managed cst cls,-                        " _ _) = HoppyP.fail $ HoppyP.concat ",-                        "[\"Deletable.delete: Asked to delete a GC-managed \", ",-                        show hsTypeName, ", \" object.\"]"]-                ln-                saysLn ["toGc this'@(", hsCtor, " ptr') = ",-                        -- No sense in creating a ForeignPtr for a null pointer.-                        "if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ",-                        "(HoppyP.flip ", hsCtorGc, " ptr') $ ",-                        "HoppyF.newForeignPtr ",-                        -- The foreign delete function takes a const pointer; we cast it to-                        -- take a Ptr () to match up with the ForeignPtr () we're creating,-                        -- assuming that data pointers have the same representation.-                        "(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName cls,-                        " :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",-                        "(HoppyF.castPtr ptr' :: HoppyF.Ptr ())"]-                saysLn ["toGc this'@(", hsCtorGc, " {}) = HoppyP.return this'"]-    else do saysLn ["instance HoppyFHR.CppPtr ", hsTypeName]-            saysLn ["instance HoppyFHR.Deletable ", hsTypeName]--  -- Generate instances for all superclasses' typeclasses.-  genInstances [] cls--  where hsTypeName :: String-        hsTypeName = toHsDataTypeName cst cls--        hsCtor :: String-        hsCtor = toHsDataCtorName Unmanaged cst cls--        hsCtorGc :: String-        hsCtorGc = toHsDataCtorName Managed cst cls--        genInstances :: [Class] -> Class -> Generator ()-        genInstances path ancestorCls = do-          -- In this example Bar inherits from Foo.  We are generating instances-          -- either for BarConst or Bar, depending on 'cst'.-          ---          -- BarConst's instances:-          --   instance FooConstPtr BarConst where-          --     toFooConst (BarConst ptr') = FooConst $ castBarToFoo ptr'-          --     toFooConst (BarConstGc fptr' ptr') = FooConstGc fptr' $ castBarToFoo ptr'-          ---          --   instance BarConstPtr BarConst where-          --     toFooConst = id-          ---          -- Bar's instances:-          --   instance FooConstPtr Bar-          --     toFooConst (Bar ptr') =-          --       FooConst $ castBarToFoo $ castBarToConst ptr'-          --     toFooConst (BarGc fptr' ptr') =-          --       FooConstGc fptr' $ castBarToFoo $ castBarToConst ptr'-          ---          --   instance FooPtr Bar-          --     toFoo (Bar ptr') =-          --       Foo $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr'-          --     toFoo (BarGc fptr' ptr') =-          --       FooGc fptr' $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr'-          ---          --   instance BarConstPtr Bar-          --     toBarConst (Bar ptr') = Bar $ castBarToConst ptr'-          --     toBarConst (BarGc fptr' ptr') = BarGc fptr' $ castBarToConst ptr'-          ---          --   instance BarPtr Bar-          --     toBar = id-          ---          -- In all cases, we unwrap the pointer, maybe add const, maybe do an-          -- upcast, maybe remove const, then rewrap the pointer.  The identity-          -- cases are where we just unwrap and wrap again.--          addImportForClass ancestorCls-          forM_ (case cst of-                   Const -> [Const]-                   Nonconst -> [Const, Nonconst]) $ \typeclassCst -> do-            saysLn ["instance ", toHsPtrClassName typeclassCst ancestorCls, " ", hsTypeName,-                    if doDecls then " where" else ""]-            when doDecls $ indent $ do-              let castMethodName = toHsCastMethodName typeclassCst ancestorCls-              if null path && cst == typeclassCst-                then do addImports hsImportForPrelude-                        saysLn [castMethodName, " = HoppyP.id"]-                else do let addConst = cst == Nonconst-                            removeConst = typeclassCst == Nonconst-                        when (addConst || removeConst) $-                          addImports hsImportForForeign-                        forM_ ([minBound..] :: [Managed]) $ \managed -> do-                          let ancestorCtor = case managed of-                                Unmanaged -> [toHsDataCtorName Unmanaged typeclassCst ancestorCls]-                                Managed -> [toHsDataCtorName Managed typeclassCst ancestorCls,-                                            " fptr'"]-                              ptrPattern = case managed of-                                Unmanaged -> [toHsDataCtorName Unmanaged cst cls, " ptr'"]-                                Managed -> [toHsDataCtorName Managed cst cls, " fptr' ptr'"]-                          saysLn $ concat-                            [ [castMethodName, " ("], ptrPattern, [") = "], ancestorCtor-                            , if removeConst-                              then [" $ (HoppyF.castPtr :: HoppyF.Ptr ",-                                    toHsDataTypeName Const ancestorCls, " -> HoppyF.Ptr ",-                                    toHsDataTypeName Nonconst ancestorCls, ")"]-                              else []-                            , if not $ null path-                              then [" $ ", toHsCastPrimitiveName cls ancestorCls]-                              else []-                            , if addConst-                              then [" $ (HoppyF.castPtr :: HoppyF.Ptr ",-                                    toHsDataTypeName Nonconst cls, " -> HoppyF.Ptr ",-                                    toHsDataTypeName Const cls, ")"]-                              else []-                            , [" ptr'"]-                            ]--          forM_ (classSuperclasses ancestorCls) $ genInstances $ ancestorCls : path--sayExportClassHsCtors :: SayExportMode -> Class -> Generator ()-sayExportClassHsCtors mode cls =-  forM_ (classCtors cls) $ \ctor ->-  (sayExportFn mode <$> getClassyExtName cls <*> pure Nothing <*>-   pure Nonpure <*> ctorParams <*> pure (ptrT $ objT cls)) ctor--sayExportClassHsSpecialFns :: SayExportMode -> Class -> Generator ()-sayExportClassHsSpecialFns mode cls = do-  let typeName = toHsDataTypeName Nonconst cls-      typeNameConst = toHsDataTypeName Const cls--  -- Say the delete function.-  case mode of-    SayExportForeignImports -> when (classDtorIsPublic cls) $ do-      addImports $ mconcat [hsImportForForeign, hsImportForPrelude]-      saysLn ["foreign import ccall \"", classDeleteFnCppName cls, "\" ",-              toHsClassDeleteFnName cls, " :: HoppyF.Ptr ",-              toHsDataTypeName Const cls, " -> HoppyP.IO ()"]-      saysLn ["foreign import ccall \"&", classDeleteFnCppName cls, "\" ",-              toHsClassDeleteFnPtrName cls, " :: HoppyF.FunPtr (HoppyF.Ptr ",-              toHsDataTypeName Const cls, " -> HoppyP.IO ())"]-    -- The user interface to this is the generic 'delete' function, rendered-    -- elsewhere.-    SayExportDecls -> return ()-    SayExportBoot -> return ()--  case mode of-    SayExportForeignImports -> return ()-    SayExportDecls -> do-      addImports $ mconcat [hsImport1 "Prelude" "($)",-                            hsImportForForeign,-                            hsImportForRuntime]-      ln-      saysLn ["instance HoppyFHR.Assignable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ",-              typeName, " where"]-      indent $ sayLn "assign ptr' value' = HoppyF.poke ptr' $ HoppyFHR.toPtr value'"-    SayExportBoot -> return ()--  -- If the class has an assignment operator that takes its own type, then-  -- generate an instance of Assignable.-  let assignmentMethods = flip filter (classMethods cls) $ \m ->-        methodApplicability m == MNormal &&-        (methodParams m == [objT cls] || methodParams m == [refT $ constT $ objT cls]) &&-        (case methodImpl m of-          RealMethod name -> name == FnOp OpAssign-          FnMethod name -> name == FnOp OpAssign)-      withAssignmentMethod f = case assignmentMethods of-        [] -> return ()-        [m] -> f m-        _ ->-          throwError $ concat-          ["Can't determine an Assignable instance to generator for ", show cls,-          " because it has multiple assignment operators ", show assignmentMethods]-  when (mode == SayExportDecls) $ withAssignmentMethod $ \m -> do-    addImports $ mconcat [hsImport1 "Prelude" "(>>)", hsImportForPrelude]-    ln-    saysLn ["instance ", toHsValueClassName cls, " a => HoppyFHR.Assignable ", typeName,-            " a where"]-    indent $-      saysLn ["assign x' y' = ", toHsFnName $ getClassyExtName cls m,-                " x' y' >> HoppyP.return ()"]--  -- A pointer to an object pointer is decodable to an object pointer by peeking-  -- at the value, so generate a Decodable instance.  You are now a two-star-  -- programmer.  There is a generic @Ptr (Ptr a)@ to @Ptr a@ instance which-  -- handles deeper levels.-  case mode of-    SayExportForeignImports -> return ()--    SayExportDecls -> do-      addImports $ mconcat [hsImport1 "Prelude" "(.)",-                            hsImportForForeign,-                            hsImportForPrelude,-                            hsImportForRuntime]-      ln-      saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ",-              typeName, ")) ", typeName, " where"]-      indent $-        saysLn ["decode = HoppyP.fmap ",-                toHsDataCtorName Unmanaged Nonconst cls, " . HoppyF.peek"]--    SayExportBoot -> do-      addImports $ mconcat [hsImportForForeign, hsImportForRuntime]-      ln-      -- TODO Encodable.-      saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ", typeName]--  -- Say Encodable and Decodable instances, if the class is encodable and-  -- decodable.-  forM_ (getClassHaskellConversion cls) $ \conv -> do-    hsType <- classHaskellConversionType conv-    let hsTypeStr = concat ["(", prettyPrint hsType, ")"]-    case mode of-      SayExportForeignImports -> return ()--      SayExportDecls -> do-        addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]--        -- Say the Encodable instances.-        ln-        saysLn ["instance HoppyFHR.Encodable ", typeName, " ", hsTypeStr, " where"]-        indent $ do-          sayLn "encode ="-          indent $ classHaskellConversionToCppFn conv-        ln-        saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " ", hsTypeStr, " where"]-        indent $-          saysLn ["encode = HoppyP.fmap (", toHsCastMethodName Const cls,-                  ") . HoppyFHR.encodeAs (HoppyP.undefined :: ", typeName, ")"]--        -- Say the Decodable instances.-        ln-        saysLn ["instance HoppyFHR.Decodable ", typeName, " ", hsTypeStr, " where"]-        indent $-          saysLn ["decode = HoppyFHR.decode . ", toHsCastMethodName Const cls]-        ln-        saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " ", hsTypeStr, " where"]-        indent $ do-          sayLn "decode ="-          indent $ classHaskellConversionFromCppFn conv--      SayExportBoot -> do-        addImports hsImportForRuntime-        ln-        saysLn ["instance HoppyFHR.Encodable ", typeName, " (", hsTypeStr, ")"]-        saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " (", hsTypeStr, ")"]-        saysLn ["instance HoppyFHR.Decodable ", typeName, " (", hsTypeStr, ")"]-        saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " (", hsTypeStr, ")"]--sayExportClassCastPrimitives :: SayExportMode -> Class -> Generator ()-sayExportClassCastPrimitives mode cls = do-  let clsType = toHsDataTypeName Const cls-  case mode of-    SayExportForeignImports ->-      forAncestors cls $ \super -> do-        let hsCastFnName = toHsCastPrimitiveName cls super-            hsDownCastFnName = toHsCastPrimitiveName super cls-            superType = toHsDataTypeName Const super-        addImports hsImportForForeign-        addExport hsCastFnName-        saysLn [ "foreign import ccall \"", classCastFnCppName cls super-               , "\" ", hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType-               ]-        unless (classIsSubclassOfMonomorphic cls || classIsMonomorphicSuperclass super) $ do-          addExport hsDownCastFnName-          saysLn [ "foreign import ccall \"", classCastFnCppName super cls-                 , "\" ", hsDownCastFnName, " :: HoppyF.Ptr ", superType, " -> HoppyF.Ptr ", clsType-                 ]-        return True--    SayExportDecls ->-      -- Generate a downcast typeclass and instances for all ancestor classes-      -- for the current constness.  These don't need to be in the boot file,-      -- since they're not used by other generated bindings.-      unless (classIsSubclassOfMonomorphic cls) $-      forM_ [minBound..] $ \cst -> do-        let downCastClassName = toHsDownCastClassName cst cls-            downCastMethodName = toHsDownCastMethodName cst cls-        addExport' downCastClassName-        ln-        saysLn ["class ", downCastClassName, " a where"]-        indent $ saysLn [downCastMethodName, " :: ",-                         prettyPrint $ HsTyFun (HsTyVar $ HsIdent "a") $-                         HsTyCon $ UnQual $ HsIdent $ toHsDataTypeName cst cls]-        ln-        forAncestors cls $ \super -> case classIsMonomorphicSuperclass super of-          True -> return False-          False -> do-            let superTypeName = toHsDataTypeName cst super-                primitiveCastFn = toHsCastPrimitiveName super cls-            addImportForClass super-            saysLn ["instance ", downCastClassName, " ", superTypeName, " where"]--            -- If Foo is a superclass of Bar:-            ---            -- instance BarSuper Foo where-            --   downToBar castFooToNonconst . downcast' . castFooToConst-            --     where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr'-            --           downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr'-            ---            -- instance BarSuperConst FooConst where-            --   downToBarConst = downcast'-            --     where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr'-            --           downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr'--            indent $ do-              saysLn $-                downCastMethodName : " = " :-                case cst of-                  Const -> ["cast'"]-                  Nonconst -> [toHsConstCastFnName Nonconst cls,-                               " . cast' . ",-                               toHsConstCastFnName Const super]-              indent $ do-                sayLn "where"-                indent $ do-                  saysLn ["cast' (", toHsDataCtorName Unmanaged Const super, " ptr') = ",-                          toHsDataCtorName Unmanaged Const cls, " $ ",-                          primitiveCastFn, " ptr'"]-                  saysLn ["cast' (", toHsDataCtorName Managed Const super, " fptr' ptr') = ",-                          toHsDataCtorName Managed Const cls, " fptr' $ ",-                          primitiveCastFn, " ptr'"]-            return True--    SayExportBoot -> do-      forAncestors cls $ \super -> do-        let hsCastFnName = toHsCastPrimitiveName cls super-            superType = toHsDataTypeName Const super-        addImports $ hsImportForForeign-        addExport hsCastFnName-        saysLn [hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType]-        return True--  where forAncestors :: Class -> (Class -> Generator Bool) -> Generator ()-        forAncestors cls' f = forM_ (classSuperclasses cls') $ \super -> do-          recur <- f super-          when recur $ forAncestors super f---- | Implements special logic on top of 'cppTypeToHsTypeAndUse', that computes--- the Haskell __qualified__ type for a function, including typeclass--- constraints.-fnToHsTypeAndUse :: HsTypeSide-                 -> Maybe (Constness, Class)-                 -> Purity-                 -> [Type]-                 -> Type-                 -> Generator HsQualType-fnToHsTypeAndUse side methodInfo purity paramTypes returnType = do-  params <- mapM contextForParam $-            (case methodInfo of-                Just (cst, cls) -> [("this", case cst of-                                        Nonconst -> ptrT $ objT cls-                                        Const -> ptrT $ constT $ objT cls)]-                Nothing -> []) ++-            zip (map toArgName [1..]) paramTypes-  let context = mapMaybe fst params :: HsContext-      hsParams = map snd params--  -- Determine the 'HsHsSide' return type for the function.  If the function is-  -- returning a 'TObj' of a class that uses 'ClassConversionToHeap' or-  -- 'ClassConversionToGc', then first we wrap the return type.  Then we do the-  -- conversion to a Haskell type, and wrap the result in 'IO' if the function-  -- is impure.  (HsCSide types always get wrapped in IO.)-  returnForGc <- case returnType of-    Internal_TObj cls -> case classHaskellConversion $ classConversion cls of-      ClassConversionNone ->-        throwError $ concat ["Expected ", show cls, " to be returnable from a C++ function"]-      ClassConversionManual _ -> return returnType-      ClassConversionToHeap -> return $ objToHeapT cls-      ClassConversionToGc -> return $ toGcT returnType-    _ -> return returnType-  hsReturnForGc <- cppTypeToHsTypeAndUse side returnForGc-  hsReturnForPurity <- case (purity, side) of-    (Pure, HsHsSide) -> return hsReturnForGc-    _ -> do-      addImports hsImportForPrelude-      return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsReturnForGc--  return $ HsQualType context $ foldr HsTyFun hsReturnForPurity hsParams--  where contextForParam :: (String, Type) -> Generator (Maybe HsAsst, HsType)-        contextForParam (s, t) = case t of-          Internal_TBitspace b -> receiveBitspace s t b-          Internal_TPtr (Internal_TObj cls) -> receivePtr s cls Nonconst-          Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls-          Internal_TRef (Internal_TObj cls) -> receivePtr s cls Nonconst-          Internal_TRef (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls-          Internal_TObj cls -> receiveValue s t cls-          Internal_TConst t' -> contextForParam (s, t')-          _ -> handoff side t--        -- Use whatever type 'cppTypeToHsTypeAndUse' suggests, with no typeclass-        -- constraints.-        handoff :: HsTypeSide -> Type -> Generator (Maybe HsAsst, HsType)-        handoff side t = (,) Nothing <$> cppTypeToHsTypeAndUse side t--        -- Receives a @IsFooBitspace a => a@.-        receiveBitspace s t b = case side of-          HsCSide -> handoff side t-          HsHsSide -> do-            importHsModuleForExtName $ bitspaceExtName b-            let t' = HsTyVar $ HsIdent s-            return (Just (UnQual $ HsIdent $ toHsBitspaceClassName b, [t']),-                    t')--        -- Receives a @FooPtr this => this@.-        receivePtr :: String -> Class -> Constness -> Generator (Maybe HsAsst, HsType)-        receivePtr s cls cst = do-          addImportForClass cls-          case side of-            HsHsSide -> do-              let t' = HsTyVar $ HsIdent s-              return (Just (UnQual $ HsIdent $ toHsPtrClassName cst cls, [t']),-                      t')-            HsCSide -> do-              addImports $ hsImportForForeign-              return (Nothing, HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") $-                               HsTyVar $ HsIdent $ toHsDataTypeName cst cls)--        -- Receives a @FooValue a => a@.-        receiveValue :: String -> Type -> Class -> Generator (Maybe HsAsst, HsType)-        receiveValue s t cls = case side of-          HsCSide -> handoff side t-          HsHsSide -> do-            addImports hsImportForRuntime-            addImportForClass cls-            let t' = HsTyVar $ HsIdent s-            return (Just (UnQual $ HsIdent $ toHsValueClassName cls, [t']),-                    t')--getMethodEffectiveParams :: Class -> Method -> [Type]-getMethodEffectiveParams cls method =-  (case methodImpl method of-     RealMethod {} -> case methodApplicability method of-       MNormal -> (ptrT (objT cls):)-       MConst -> (ptrT (constT $ objT cls):)-       MStatic -> id-     FnMethod {} -> id) $-  methodParams method---- | Imports bindings for the given class into the Haskell module.-addImportForClass :: Class -> Generator ()-addImportForClass = importHsModuleForExtName . classExtName+import Control.Arrow ((&&&))+import Control.Monad (forM, unless, when)+#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except (throwError)+#else+import Control.Monad.Error (throwError)+#endif+import Control.Monad.Trans (lift)+import Control.Monad.Writer (execWriterT, tell)+import Data.Foldable (forM_)+import Data.Graph (SCC (AcyclicSCC, CyclicSCC), stronglyConnComp)+import Data.List (intersperse)+import qualified Data.Map as M+import Data.Maybe (mapMaybe)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mconcat, mempty)+#endif+import qualified Data.Set as S+import Foreign.Hoppy.Generator.Common+import Foreign.Hoppy.Generator.Spec+import Foreign.Hoppy.Generator.Types+import Foreign.Hoppy.Generator.Language.Cpp (+  classCastFnCppName,+  classDeleteFnCppName,+  externalNameToCpp,+  )+import Foreign.Hoppy.Generator.Language.Haskell+import Language.Haskell.Syntax (+  HsAsst,+  HsContext,+  HsName (HsIdent),+  HsQName (Special, UnQual),+  HsQualType (HsQualType),+  HsSpecialCon (HsUnitCon),+  HsType (HsTyApp, HsTyCon, HsTyFun, HsTyVar),+  )+import System.FilePath ((<.>), pathSeparator)++-- | The in-memory result of generating Haskell code for an interface.+data Generation = Generation+  { generatedFiles :: M.Map FilePath String+    -- ^ A map from paths of generated files to the contents of those files.+    -- The file paths are relative paths below the Haskell generation root.+  }++-- | Runs the C++ code generator against an interface.+generate :: Interface -> Either ErrorMsg Generation+generate iface = do+  -- Build the partial generation of each module.+  modPartials <- forM (M.elems $ interfaceModules iface) $ \m ->+    (,) m <$> execGenerator iface m (generateSource m)++  -- Compute the strongly connected components.  If there is a nontrivial SCC,+  -- then there is a module import cycle that we'll have to break with hs-boot+  -- files.+  let partialsByHsName :: M.Map HsModuleName Partial+      partialsByHsName = M.fromList $ map ((partialModuleHsName &&& id) . snd) modPartials++      sccInput :: [((Module, Partial), Partial, [Partial])]+      sccInput = for modPartials $ \x@(_, p) ->+        (x, p,+         mapMaybe (flip M.lookup partialsByHsName . hsImportModule) $+         M.keys $ getHsImportSet $ outputImports $ partialOutput p)++      sccs :: [SCC (Module, Partial)]+      sccs = stronglyConnComp sccInput++  fileContents <- execWriterT $ forM_ sccs $ \scc -> case scc of+    AcyclicSCC (_, p) -> tell [finishPartial p "hs"]+    CyclicSCC mps -> do+      let cycleModNames = S.fromList $ map (partialModuleHsName . snd) mps+      forM_ mps $ \(m, p) -> do+        -- Create a boot partial.+        pBoot <- lift $ execGenerator iface m (generateBootSource m)++        -- Change the source and boot partials so that all imports of modules in+        -- this cycle are {-# SOURCE #-} imports.+        let p' = setSourceImports cycleModNames p+            pBoot' = setSourceImports cycleModNames pBoot++        -- Emit the completed partials.+        tell [finishPartial p' "hs", finishPartial pBoot' "hs-boot"]++  return $ Generation $ M.fromList fileContents++  where finishPartial :: Partial -> String -> (FilePath, String)+        finishPartial p fileExt =+          (listSubst '.' pathSeparator (partialModuleHsName p) <.> fileExt,+           prependExtensions $ renderPartial p)++        setSourceImports :: S.Set HsModuleName -> Partial -> Partial+        setSourceImports modulesToSourceImport p =+          let output = partialOutput p+              imports = outputImports output+              imports' = makeHsImportSet $+                         M.mapWithKey (setSourceImportIfIn modulesToSourceImport) $+                         getHsImportSet imports+              output' = output { outputImports = imports' }+          in p { partialOutput = output' }++        setSourceImportIfIn :: S.Set HsModuleName -> HsImportKey -> HsImportSpecs -> HsImportSpecs+        setSourceImportIfIn modulesToSourceImport key specs =+          if hsImportModule key `S.member` modulesToSourceImport+          then specs { hsImportSource = True }+          else specs++prependExtensions :: String -> String+prependExtensions = (prependExtensionsPrefix ++)++prependExtensionsPrefix :: String+prependExtensionsPrefix =+  -- MultiParamTypeClasses is necessary for instances of Decodable and+  -- Encodable.  FlexibleContexts is needed for the type signature of the+  -- function that wraps the actual callback function in callback creation+  -- functions.+  --+  -- FlexibleInstances and TypeSynonymInstances are enabled to allow conversions+  -- to and from String, which is really [Char].+  --+  -- UndecidableInstances is needed for instances of the form "SomeClassConstPtr+  -- a => SomeClassValue a", and overlapping instances are used for the overlap+  -- between these instances and instances of SomeClassValue for the class's+  -- native Haskell type, when it's convertible.  CPP is used for warning-free+  -- compatibility using overlapping instances with both GHC 7.8 and 7.10.+  --+  -- GeneralizedNewtypeDeriving is to enable automatic deriving of+  -- Data.Bits.Bits instances for bitspace newtypes.+  concat+  [ "{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving"+  , ", MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-}\n"+  , "#if !MIN_VERSION_base(4,8,0)\n"+  , "{-# LANGUAGE OverlappingInstances #-}\n"+  , "#endif\n\n"+  ]++generateSource :: Module -> Generator ()+generateSource m = do+  forM_ (moduleExports m) $ sayExport SayExportForeignImports+  forM_ (moduleExports m) $ sayExport SayExportDecls++  iface <- askInterface+  when (interfaceExceptionSupportModule iface == Just m) $+    sayExceptionSupport True++  addendumHaskell $ getAddendum m++generateBootSource :: Module -> Generator ()+generateBootSource m = do+  forM_ (moduleExports m) $ sayExport SayExportBoot++  iface <- askInterface+  when (interfaceExceptionSupportModule iface == Just m) $+    sayExceptionSupport False++data SayExportMode = SayExportForeignImports | SayExportDecls | SayExportBoot+                   deriving (Eq, Show)++sayExport :: SayExportMode -> Export -> Generator ()+sayExport mode export = do+  case export of+    ExportVariable v -> sayExportVar mode v+    ExportEnum enum -> sayExportEnum mode enum+    ExportBitspace bitspace -> sayExportBitspace mode bitspace+    ExportFn fn ->+      (sayExportFn mode <$> fnExtName <*> fnExtName <*> fnPurity <*>+       fnParams <*> fnReturn <*> fnExceptionHandlers) fn+    ExportClass cls -> sayExportClass mode cls+    ExportCallback cb -> sayExportCallback mode cb++  when (mode == SayExportDecls) $+    addendumHaskell $ exportAddendum export++sayExportVar :: SayExportMode -> Variable -> Generator ()+sayExportVar mode v = withErrorContext ("generating variable " ++ show (varExtName v)) $ do+  let getterName = varGetterExtName v+      setterName = varSetterExtName v+  sayExportVar' mode (varType v) Nothing True getterName getterName setterName setterName++sayExportClassVar :: SayExportMode -> Class -> ClassVariable -> Generator ()+sayExportClassVar mode cls v =+  withErrorContext ("generating variable " ++ show (classVarExtName v)) $+  sayExportVar' mode+                (classVarType v)+                (case classVarStatic v of+                   Nonstatic -> Just cls+                   Static -> Nothing)+                (classVarGettable v)+                (classVarGetterExtName cls v)+                (classVarGetterForeignName cls v)+                (classVarSetterExtName cls v)+                (classVarSetterForeignName cls v)++sayExportVar' :: SayExportMode+              -> Type+              -> Maybe Class+              -> Bool+              -> ExtName+              -> ExtName+              -> ExtName+              -> ExtName+              -> Generator ()+sayExportVar' mode+              t+              classIfNonstatic+              gettable+              getterExtName+              getterForeignName+              setterExtName+              setterForeignName = do+  let (isConst, deconstType) = case t of+        Internal_TConst t -> (True, t)+        t -> (False, t)++  when gettable $+    sayExportFn mode+                getterExtName+                getterForeignName+                Nonpure+                (maybe [] (\cls -> [ptrT $ constT $ objT cls]) classIfNonstatic)+                deconstType+                mempty++  unless isConst $+    sayExportFn mode+                setterExtName+                setterForeignName+                Nonpure+                (maybe [deconstType] (\cls -> [ptrT $ objT cls, deconstType])+                       classIfNonstatic)+                voidT+                mempty++sayExportEnum :: SayExportMode -> CppEnum -> Generator ()+sayExportEnum mode enum =+  withErrorContext ("generating enum " ++ show (enumExtName enum)) $+  case mode of+    -- Nothing to import from the C++ side of an enum.+    SayExportForeignImports -> return ()++    SayExportDecls -> do+      hsTypeName <- toHsEnumTypeName enum+      values <- forM (enumValueNames enum) $ \(value, name) -> do+        ctorName <- toHsEnumCtorName enum name+        return (value, ctorName)+      addImports $ mconcat [hsImports "Prelude" ["($)", "(++)"], hsImportForPrelude]++      -- Print out the data declaration.+      ln+      addExport' hsTypeName+      saysLn ["data ", hsTypeName, " ="]+      indent $ do+        forM_ (zip (False:repeat True) values) $ \(cont, (_, hsCtorName)) ->+          saysLn [if cont then "| " else "", hsCtorName]+        sayLn "deriving (HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)"++      -- Print out the Enum instance.+      ln+      saysLn ["instance HoppyP.Enum ", hsTypeName, " where"]+      indent $ do+        forM_ values $ \(num, hsCtorName) ->+          saysLn ["fromEnum ", hsCtorName, " = ", show num]+        ln+        forM_ values $ \(num, hsCtorName) ->+          saysLn ["toEnum (", show num, ") = ", hsCtorName]+        saysLn ["toEnum n' = HoppyP.error $ ",+                show (concat ["Unknown ", hsTypeName, " numeric value: "]),+                " ++ HoppyP.show n'"]++    SayExportBoot -> do+      hsTypeName <- toHsEnumTypeName enum+      addImports hsImportForPrelude+      addExport hsTypeName+      ln+      saysLn ["data ", hsTypeName]+      saysLn ["instance HoppyP.Bounded ", hsTypeName]+      saysLn ["instance HoppyP.Enum ", hsTypeName]+      saysLn ["instance HoppyP.Eq ", hsTypeName]+      saysLn ["instance HoppyP.Ord ", hsTypeName]+      saysLn ["instance HoppyP.Show ", hsTypeName]++sayExportBitspace :: SayExportMode -> Bitspace -> Generator ()+sayExportBitspace mode bitspace =+  withErrorContext ("generating bitspace " ++ show (bitspaceExtName bitspace)) $ do+  hsTypeName <- toHsBitspaceTypeName bitspace+  fromFnName <- toHsBitspaceToNumName bitspace+  className <- toHsBitspaceClassName bitspace+  toFnName <- toHsBitspaceFromValueName bitspace+  let hsType = HsTyCon $ UnQual $ HsIdent hsTypeName+  case mode of+    -- Nothing to import from the C++ side of a bitspace.+    SayExportForeignImports -> return ()++    SayExportDecls -> do+      values <- forM (bitspaceValueNames bitspace) $ \(value, name) -> do+        bindingName <- toHsBitspaceValueName bitspace name+        return (value, bindingName)++      hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace+      hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace++      -- Print out the data declaration and conversion functions.+      addImports $ mconcat [hsImportForBits, hsImportForPrelude, hsImportForRuntime]+      addExport' hsTypeName+      addExport' className+      ln+      saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ",+              fromFnName, " :: ", prettyPrint hsCNumType, " }"]+      indent $ sayLn "deriving (HoppyDB.Bits, HoppyP.Bounded, HoppyP.Eq, HoppyP.Ord, HoppyP.Show)"+      ln+      saysLn ["class ", className, " a where"]+      indent $ do+        let tyVar = HsTyVar $ HsIdent "a"+        saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType]+      ln+      saysLn ["instance ", className, " (", prettyPrint hsCNumType, ") where"]+      indent $ saysLn [toFnName, " = ", hsTypeName]+      saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ") where"]+      indent $ saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral"]+      saysLn ["instance ", className, " ", hsTypeName, " where"]+      indent $ saysLn [toFnName, " = HoppyP.id"]++      -- If the bitspace has an associated enum, then print out a conversion+      -- instance for it as well.+      forM_ (bitspaceEnum bitspace) $ \enum -> do+        enumTypeName <- toHsEnumTypeName enum+        addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime]+        ln+        saysLn ["instance ", className, " ", enumTypeName, " where"]+        indent $+          saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral . HoppyP.fromEnum"]++      -- Print out the constants.+      ln+      forM_ values $ \(num, valueName) -> do+        addExport valueName+        saysLn [valueName, " = ", hsTypeName, " ", show num]++    SayExportBoot -> do+      hsCNumType <- cppTypeToHsTypeAndUse HsCSide $ bitspaceType bitspace+      hsHsNumType <- cppTypeToHsTypeAndUse HsHsSide $ bitspaceType bitspace++      addImports $ mconcat [hsImportForBits, hsImportForPrelude]+      addExport' hsTypeName+      addExport' className+      ln+      saysLn ["newtype ", hsTypeName, " = ", hsTypeName, " { ",+              fromFnName, " :: ", prettyPrint hsCNumType, " }"]+      ln+      saysLn ["instance HoppyDB.Bits ", hsTypeName]+      saysLn ["instance HoppyP.Bounded ", hsTypeName]+      saysLn ["instance HoppyP.Eq ", hsTypeName]+      saysLn ["instance HoppyP.Ord ", hsTypeName]+      saysLn ["instance HoppyP.Show ", hsTypeName]+      ln+      saysLn ["class ", className, " a where"]+      indent $ do+        let tyVar = HsTyVar $ HsIdent "a"+        saysLn [toFnName, " :: ", prettyPrint $ HsTyFun tyVar hsType]+      ln+      saysLn ["instance ", className, " (", prettyPrint hsCNumType, ")"]+      saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ")"]+      saysLn ["instance ", className, " ", hsTypeName]+      forM_ (bitspaceEnum bitspace) $ \enum -> do+        enumTypeName <- toHsEnumTypeName enum+        saysLn ["instance ", className, " ", enumTypeName]++sayExportFn :: SayExportMode+            -> ExtName+            -> ExtName+            -> Purity+            -> [Type]+            -> Type+            -> ExceptionHandlers+            -> Generator ()+sayExportFn mode extName foreignName purity paramTypes retType exceptionHandlers = do+  effectiveHandlers <- getEffectiveExceptionHandlers exceptionHandlers+  let handlerList = exceptionHandlersList effectiveHandlers+      catches = not $ null handlerList++  -- We use the pure version of toHsFnName here; because foreignName isn't an+  -- ExtName present in the interface's lookup table, toHsFnName would bail on+  -- it.  Since functions don't reference each other (e.g. we don't put anything+  -- in .hs-boot files for them in circular modules cases), this isn't a problem.+  let hsFnName = toHsFnName' foreignName+      hsFnImportedName = hsFnName ++ "'"++  case mode of+    SayExportForeignImports ->+      withErrorContext ("generating imports for function " ++ show extName) $ do+        -- Print a "foreign import" statement.+        hsCType <- fnToHsTypeAndUse HsCSide purity paramTypes retType effectiveHandlers+        saysLn ["foreign import ccall \"", externalNameToCpp extName, "\" ", hsFnImportedName,+                " :: ", prettyPrint hsCType]++    SayExportDecls -> withErrorContext ("generating function " ++ show extName) $ do+      -- Print the type signature.+      ln+      addExport hsFnName+      hsHsType <- fnToHsTypeAndUse HsHsSide purity paramTypes retType effectiveHandlers+      saysLn [hsFnName, " :: ", prettyPrint hsHsType]++      case purity of+        Nonpure -> return ()+        Pure -> saysLn ["{-# NOINLINE ", hsFnName, " #-}"]++      -- Print the function body.+      let argNames = map toArgName [1..length paramTypes]+          convertedArgNames = map (++ "'") argNames+      -- Operators on this line must bind more weakly than operators used below,+      -- namely ($) and (>>=).  (So finish the line with ($).)+      lineEnd <- case purity of+        Nonpure -> return [" ="]+        Pure -> do addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForUnsafeIO]+                   return [" = HoppySIU.unsafePerformIO $"]+      saysLn $ hsFnName : map (' ':) argNames ++ lineEnd+      indent $ do+        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' $"++        let callWords = hsFnImportedName : map (' ':) convertedArgNames+        sayCallAndProcessReturn ToCpp retType callWords++    SayExportBoot ->+      -- Functions (methods included) cannot be referenced from other exports,+      -- so we don't need to emit anything.+      --+      -- If this changes, revisit the comment on hsFnName above.+      return ()++-- | Prints \"foreign import\" statements and an internal callback construction+-- function for a given 'Callback' specification.  For example, for a callback+-- of 'HsHsSide' type @Int -> String -> IO Int@, we will generate the following+-- bindings:+--+-- > foreign import ccall "wrapper" name'newFunPtr+-- >   :: (CInt -> Ptr CChar -> IO CInt)+-- >   -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt))+-- >+-- > -- (This is an ad-hoc generated binding for C++ callback impl class constructor.)+-- > foreign import ccall "genpop__name_impl" name'newCallback+-- >   :: FunPtr (CInt -> Ptr CChar -> IO CInt)+-- >   -> FunPtr (FunPtr (IO ()) -> IO ())+-- >   -> Bool+-- >   -> IO (CCallback (CInt -> Ptr CChar -> IO CInt))+-- >+-- > name_newFunPtr :: (Int -> String -> IO Int) -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt))+-- > name_newFunPtr f'hs = name'newFunPtr $ \excIdPtr excPtrPtr arg1 arg2 ->+-- >   internalHandleCallbackExceptions excIdPtr excPtrPtr $+-- >   coerceIntegral arg1 >>= \arg1' ->+-- >   (...decode the C string) >>= \arg2' ->+-- >   fmap coerceIntegral+-- >   (f'hs arg1' arg2')+-- >+-- > name_new :: (Int -> String -> IO Int) -> IO (CCallback (CInt -> Ptr CChar -> IO CInt))+-- > name_new f = do+-- >   f'p <- name_newFunPtr f+-- >   name'newCallback f'p freeHaskellFunPtrFunPtr False+sayExportCallback :: SayExportMode -> Callback -> Generator ()+sayExportCallback mode cb =+  withErrorContext ("generating callback " ++ show (callbackExtName cb)) $ do+    let name = callbackExtName cb+        paramTypes = callbackParams cb+        retType = callbackReturn cb+    hsNewFunPtrFnName <- toHsCallbackNewFunPtrFnName cb+    hsCtorName <- toHsCallbackCtorName cb+    let hsCtorName'newCallback = hsCtorName ++ "'newCallback"+        hsCtorName'newFunPtr = hsCtorName ++ "'newFunPtr"++    hsFnCType <- cppTypeToHsTypeAndUse HsCSide =<< callbackToTFn HsCSide cb+    hsFnHsType <- cppTypeToHsTypeAndUse HsHsSide =<< callbackToTFn HsHsSide cb++    let getWholeNewFunPtrFnType = do+          addImports $ mconcat [hsImportForForeign, hsImportForPrelude]+          return $+            HsTyFun hsFnHsType $+            HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $+            HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType+        getWholeCtorType = do+          addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]+          return $+            HsTyFun hsFnHsType $+            HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $+            HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType++    case mode of+      SayExportForeignImports -> do+        addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]+        let hsFunPtrType = HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType+            hsFunPtrImportType =+              HsTyFun hsFnCType $+              HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsFunPtrType+            hsCallbackCtorImportType =+              HsTyFun hsFunPtrType $+              HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $+                       HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $+                                HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $+                                HsTyCon $ Special HsUnitCon) $+                       HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $+                       HsTyCon $ Special HsUnitCon) $+              HsTyFun (HsTyCon $ UnQual $ HsIdent "HoppyP.Bool") $+              HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $+              HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType++        saysLn ["foreign import ccall \"wrapper\" ", hsCtorName'newFunPtr, " :: ",+                prettyPrint hsFunPtrImportType]+        saysLn ["foreign import ccall \"", externalNameToCpp name, "\" ",+                hsCtorName'newCallback, " :: ", prettyPrint hsCallbackCtorImportType]++      SayExportDecls -> do+        addExports [hsNewFunPtrFnName, hsCtorName]++        wholeNewFunPtrFnType <- getWholeNewFunPtrFnType+        let paramCount = length paramTypes+            argNames = map toArgName [1..paramCount]+            argNames' = map (++ "'") argNames+        throws <- getEffectiveCallbackThrows cb+        addImports $ mconcat [hsImport1 "Prelude" "($)",+                              hsImportForRuntime]+        ln+        saysLn [hsNewFunPtrFnName, " :: ", prettyPrint wholeNewFunPtrFnType]+        saysLn $ hsNewFunPtrFnName : " f'hs = " : hsCtorName'newFunPtr : " $" :+          case (if throws then (["excIdPtr", "excPtrPtr"] ++) else id) argNames of+            [] -> []+            argNames' -> [" \\", unwords argNames', " ->"]+        indent $ do+          when throws $ sayLn "HoppyFHR.internalHandleCallbackExceptions excIdPtr excPtrPtr $"+          forM_ (zip3 paramTypes argNames argNames') $ \(t, argName, argName') ->+            sayArgProcessing FromCpp t argName argName'+          sayCallAndProcessReturn FromCpp retType $+            "f'hs" : map (' ':) argNames'++        wholeCtorType <- getWholeCtorType+        ln+        saysLn [hsCtorName, " :: ", prettyPrint wholeCtorType]+        saysLn [hsCtorName, " f'hs = do"]+        indent $ do+          saysLn ["f'p <- ", hsNewFunPtrFnName, " f'hs"]+          saysLn [hsCtorName'newCallback, " f'p HoppyFHR.freeHaskellFunPtrFunPtr HoppyP.False"]++      SayExportBoot -> do+        addExports [hsNewFunPtrFnName, hsCtorName]+        wholeNewFunPtrFnType <- getWholeNewFunPtrFnType+        wholeCtorType <- getWholeCtorType+        ln+        saysLn [hsNewFunPtrFnName, " :: ", prettyPrint wholeNewFunPtrFnType]+        ln+        saysLn [hsCtorName, " :: ", prettyPrint wholeCtorType]++data CallDirection =+  ToCpp  -- ^ Haskell code is calling out to C++.+  | FromCpp  -- ^ C++ is invoking a callback.++sayArgProcessing :: CallDirection -> Type -> String -> String -> Generator ()+sayArgProcessing dir t fromVar toVar =+  withErrorContext ("processing argument of type " ++ show t) $+  case t of+    Internal_TVoid -> throwError $ "TVoid is not a valid argument type"+    Internal_TBool -> case dir of+      ToCpp -> saysLn ["let ", toVar, " = if ", fromVar, " then 1 else 0 in"]+      FromCpp -> do addImports $ hsImport1 "Prelude" "(/=)"+                    saysLn ["let ", toVar, " = ", fromVar, " /= 0 in"]+    Internal_TChar -> noConversion+    Internal_TUChar -> noConversion+    Internal_TShort -> noConversion+    Internal_TUShort -> noConversion+    Internal_TInt -> sayCoerceIntegral+    Internal_TUInt -> noConversion+    Internal_TLong -> noConversion+    Internal_TULong -> noConversion+    Internal_TLLong -> noConversion+    Internal_TULLong -> noConversion+    Internal_TFloat -> sayCoerceFloating+    Internal_TDouble -> sayCoerceFloating+    Internal_TInt8 -> noConversion+    Internal_TInt16 -> noConversion+    Internal_TInt32 -> noConversion+    Internal_TInt64 -> noConversion+    Internal_TWord8 -> noConversion+    Internal_TWord16 -> noConversion+    Internal_TWord32 -> noConversion+    Internal_TWord64 -> noConversion+    Internal_TPtrdiff -> noConversion+    Internal_TSize -> noConversion+    Internal_TSSize -> noConversion+    Internal_TEnum _ -> do+      addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForPrelude, hsImportForRuntime]+      saysLn ["let ", toVar,+              -- TODO The coersion here is unnecssary if we replace the C numeric+              -- types with their Haskell ones across the board (e.g. CInt ->+              -- Int).+              case dir of+                ToCpp -> " = HoppyFHR.coerceIntegral $ HoppyP.fromEnum "+                FromCpp -> " = HoppyP.toEnum $ HoppyFHR.coerceIntegral ",+              fromVar, " in"]+    Internal_TBitspace b -> case dir of+      ToCpp -> do+        toNumName <- toHsBitspaceToNumName b+        fromValueName <- toHsBitspaceFromValueName b+        saysLn ["let ", toVar, " = ", toNumName, " $ ", fromValueName, " ", fromVar, " in"]+      FromCpp -> do+        typeName <- toHsBitspaceTypeName b+        saysLn ["let ", toVar, " = " , typeName, " ", fromVar, " in"]+    -- References and pointers are handled equivalently.+    Internal_TPtr (Internal_TObj cls) -> case dir of+      ToCpp -> do+        addImports $ mconcat [hsImport1 "Prelude" "($)",+                              hsImportForRuntime]+        castMethodName <- toHsCastMethodName Nonconst cls+        saysLn ["HoppyFHR.withCppPtr (", castMethodName, " ", fromVar,+                ") $ \\", toVar, " ->"]+      FromCpp -> do+        ctorName <- toHsDataCtorName Unmanaged Nonconst cls+        saysLn ["let ", toVar, " = ", ctorName, " ", fromVar, " in"]+    Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of+      ToCpp -> do+        -- Same as the (TObj _), ToCpp case.+        addImports $ mconcat [hsImport1 "Prelude" "($)",+                              hsImportForPrelude,+                              hsImportForRuntime]+        withValuePtrName <- toHsWithValuePtrName cls+        saysLn [withValuePtrName, " ", fromVar,+                " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"]+      FromCpp -> do+        ctorName <- toHsDataCtorName Unmanaged Const cls+        saysLn ["let ", toVar, " = ", ctorName, " ", fromVar, " in"]+    Internal_TPtr _ -> noConversion+    Internal_TRef t' -> sayArgProcessing dir (ptrT t') fromVar toVar+    Internal_TFn {} -> throwError "TFn unimplemented"+    Internal_TCallback cb -> case dir of+      ToCpp -> do+        addImports $ hsImport1 "Prelude" "(>>=)"+        callbackCtorName <- toHsCallbackCtorName cb+        saysLn [callbackCtorName, " ", fromVar, " >>= \\", toVar, " ->"]+      FromCpp -> throwError "Can't receive a callback from C++"+    Internal_TObj cls -> case dir of+      ToCpp -> do+        -- Same as the (TPtr (TConst (TObj _))), ToPtr case.+        addImports $ mconcat [hsImport1 "Prelude" "($)",+                              hsImportForPrelude,+                              hsImportForRuntime]+        withValuePtrName <- toHsWithValuePtrName cls+        saysLn [withValuePtrName, " ", fromVar,+                " $ HoppyP.flip HoppyFHR.withCppPtr $ \\", toVar, " ->"]+      FromCpp -> case classHaskellConversionFromCppFn $ getClassHaskellConversion cls of+        Just _ -> do+          addImports $ mconcat [hsImport1 "Prelude" "(>>=)",+                                hsImportForRuntime]+          ctorName <- toHsDataCtorName Unmanaged Const cls+          saysLn ["HoppyFHR.decode (", ctorName, " ", fromVar, ") >>= \\", toVar, " ->"]+        Nothing ->+          throwError $ concat+          ["Can't pass a TObj of ", show cls,+           " from C++ to Haskell because no class decode conversion is defined"]+    Internal_TObjToHeap cls -> case dir of+      ToCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls+      FromCpp -> sayArgProcessing dir (ptrT $ objT cls) fromVar toVar+    Internal_TToGc t' -> case dir of+      ToCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t'+      FromCpp -> do+        addImports $ mconcat [hsImport1 "Prelude" "(>>=)",+                              hsImportForRuntime]+        saysLn ["HoppyFHR.toGc ", fromVar, " >>= \\", toVar, " ->"]+    Internal_TConst t' -> sayArgProcessing dir t' fromVar toVar+  where noConversion = saysLn ["let ", toVar, " = ", fromVar, " in"]+        sayCoerceIntegral = do+          addImports hsImportForRuntime+          saysLn ["let ", toVar, " = HoppyFHR.coerceIntegral ", fromVar, " in"]+        sayCoerceFloating = do+          addImports hsImportForPrelude+          saysLn ["let ", toVar, " = HoppyP.realToFrac ", fromVar, " in"]++-- | Note that the 'CallDirection' is the direction of the call, not the+-- direction of the return.  'ToCpp' means we're returning to the foreign+-- language, 'FromCpp' means we're returning from it.+sayCallAndProcessReturn :: CallDirection -> Type -> [String] -> Generator ()+sayCallAndProcessReturn dir t callWords =+  withErrorContext ("processing return value of type " ++ show t) $+  case t of+    Internal_TVoid -> sayCall+    Internal_TBool -> do+      case dir of+        ToCpp -> do addImports $ mconcat [hsImport1 "Prelude" "(/=)", hsImportForPrelude]+                    sayLn "HoppyP.fmap (/= 0)"+        FromCpp -> sayLn "HoppyP.fmap (\\x -> if x then 1 else 0)"+      sayCall+    Internal_TChar -> sayCall+    Internal_TUChar -> sayCall+    Internal_TShort -> sayCall+    Internal_TUShort -> sayCall+    Internal_TInt -> sayCoerceIntegral >> sayCall+    Internal_TUInt -> sayCall+    Internal_TLong -> sayCall+    Internal_TULong -> sayCall+    Internal_TLLong -> sayCall+    Internal_TULLong -> sayCall+    Internal_TFloat -> sayCoerceFloating >> sayCall+    Internal_TDouble -> sayCoerceFloating >> sayCall+    Internal_TInt8 -> sayCall+    Internal_TInt16 -> sayCall+    Internal_TInt32 -> sayCall+    Internal_TInt64 -> sayCall+    Internal_TWord8 -> sayCall+    Internal_TWord16 -> sayCall+    Internal_TWord32 -> sayCall+    Internal_TWord64 -> sayCall+    Internal_TPtrdiff -> sayCall+    Internal_TSize -> sayCall+    Internal_TSSize -> sayCall+    Internal_TEnum _ -> do+      addImports $ mconcat [hsImport1 "Prelude" "(.)", hsImportForPrelude, hsImportForRuntime]+      case dir of+        -- TODO The coersion here is unnecssary if we replace the C numeric types+        -- with their Haskell ones across the board (e.g. CInt -> Int).+        ToCpp -> saysLn ["HoppyP.fmap (HoppyP.toEnum . HoppyFHR.coerceIntegral)"]+        FromCpp -> saysLn ["HoppyP.fmap (HoppyFHR.coerceIntegral . HoppyP.fromEnum)"]+      sayCall+    Internal_TBitspace b -> do+      addImports hsImportForPrelude+      convFn <- bitspaceConvFn dir b+      saysLn ["HoppyP.fmap ", convFn]+      sayCall+    -- The same as TPtr (TConst (TObj _)), but nonconst.+    Internal_TPtr (Internal_TObj cls) -> do+      case dir of+        ToCpp -> do+          addImports hsImportForPrelude+          ctorName <- toHsDataCtorName Unmanaged Nonconst cls+          saysLn ["HoppyP.fmap ", ctorName]+          sayCall+        FromCpp -> do+          addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]+          sayLn "HoppyP.fmap HoppyFHR.toPtr"+          sayCall+    -- The same as TPtr (TConst (TObj _)), but nonconst.+    Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> case dir of+      ToCpp -> do+        addImports hsImportForPrelude+        ctorName <- toHsDataCtorName Unmanaged Const cls+        saysLn ["HoppyP.fmap ", ctorName]+        sayCall+      FromCpp -> do+        addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]+        sayLn "HoppyP.fmap HoppyFHR.toPtr"+        sayCall+    Internal_TPtr _ -> sayCall+    Internal_TRef t' -> sayCallAndProcessReturn dir (ptrT t') callWords+    Internal_TFn {} -> throwError "TFn unimplemented"+    Internal_TCallback cb -> case dir of+      ToCpp -> throwError "Can't receive a callback from C++"+      FromCpp -> do+        addImports $ hsImport1 "Prelude" "(=<<)"+        ctorName <- toHsCallbackCtorName cb+        saysLn [ctorName, "=<<"]+        sayCall+    Internal_TObj cls -> case dir of+      ToCpp -> case classHaskellConversionFromCppFn $ getClassHaskellConversion cls of+        Just _ -> do+          addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"],+                                hsImportForRuntime]+          ctorName <- toHsDataCtorName Unmanaged Const cls+          saysLn ["(HoppyFHR.decodeAndDelete . ", ctorName, ") =<<"]+          sayCall+        Nothing ->+          throwError $ concat+          ["Can't return a TObj of ", show cls,+           " from C++ to Haskell because no class decode conversion is defined"]+      FromCpp -> do+        addImports $ mconcat [hsImports "Prelude" ["(.)", "(=<<)"],+                              hsImportForPrelude,+                              hsImportForRuntime]+        sayLn "(HoppyP.fmap (HoppyFHR.toPtr) . HoppyFHR.encode) =<<"+        sayCall+    Internal_TObjToHeap cls -> case dir of+      ToCpp -> sayCallAndProcessReturn dir (ptrT $ objT cls) callWords+      FromCpp -> throwError $ objToHeapTWrongDirectionErrorMsg Nothing cls+    Internal_TToGc t' -> case dir of+      ToCpp -> do+        addImports $ mconcat [hsImport1 "Prelude" "(=<<)",+                              hsImportForRuntime]+        sayLn "HoppyFHR.toGc =<<"+        -- TToGc (TObj _) should create a pointer rather than decoding, so we+        -- change the TObj _ into a TPtr (TObj _).+        case t' of+          Internal_TObj _ -> sayCallAndProcessReturn dir (ptrT t') callWords+          _ -> sayCallAndProcessReturn dir t' callWords+      FromCpp -> throwError $ toGcTWrongDirectionErrorMsg Nothing t'+    Internal_TConst t' -> sayCallAndProcessReturn dir t' callWords+  where sayCall = saysLn $ "(" : callWords ++ [")"]+        sayCoerceIntegral = do addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]+                               sayLn "HoppyP.fmap HoppyFHR.coerceIntegral"+        sayCoerceFloating = do addImports hsImportForPrelude+                               sayLn "HoppyP.fmap HoppyP.realToFrac"+        bitspaceConvFn dir = case dir of+          ToCpp -> toHsBitspaceTypeName+          FromCpp -> toHsBitspaceToNumName++sayExportClass :: SayExportMode -> Class -> Generator ()+sayExportClass mode cls = withErrorContext ("generating class " ++ show (classExtName cls)) $ do+  case mode of+    SayExportForeignImports -> do+      sayExportClassHsVars mode cls+      sayExportClassHsCtors mode cls++      forM_ (classMethods cls) $ \method ->+        (sayExportFn mode <$> classEntityExtName cls <*> classEntityForeignName cls <*>+         methodPurity <*> pure (getMethodEffectiveParams cls method) <*>+         methodReturn <*> methodExceptionHandlers)+        method++    SayExportDecls -> do+      sayExportClassHsClass True cls Const+      sayExportClassHsClass True cls Nonconst++      sayExportClassHsStaticMethods cls++      -- Create a newtype for referencing foreign objects with pointers.  The+      -- newtype is not used with encodings of value objects.+      sayExportClassHsType True cls Const+      sayExportClassHsType True cls Nonconst++      sayExportClassExceptionSupport True cls++      sayExportClassHsVars mode cls+      sayExportClassHsCtors mode cls++    SayExportBoot -> do+      sayExportClassHsClass False cls Const+      sayExportClassHsClass False cls Nonconst++      sayExportClassHsType False cls Const+      sayExportClassHsType False cls Nonconst++      sayExportClassExceptionSupport False cls++      sayExportClassHsVars mode cls++  sayExportClassCastPrimitives mode cls+  sayExportClassHsSpecialFns mode cls++sayExportClassHsClass :: Bool -> Class -> Constness -> Generator ()+sayExportClassHsClass doDecls cls cst = withErrorContext "generating Haskell typeclass" $ do+  hsTypeName <- toHsDataTypeName cst cls+  hsValueClassName <- toHsValueClassName cls+  hsWithValuePtrName <- toHsWithValuePtrName cls+  hsPtrClassName <- toHsPtrClassName cst cls+  hsCastMethodName <- toHsCastMethodName cst cls+  let supers = classSuperclasses cls++  hsSupers <-+    (\x -> if null x+           then do addImports hsImportForRuntime+                   return ["HoppyFHR.CppPtr"]+           else return x) =<<+    case cst of+      Const -> mapM (toHsPtrClassName Const) supers+      Nonconst ->+        (:) <$> toHsPtrClassName Const cls <*> mapM (toHsPtrClassName Nonconst) supers++  -- Print the value class definition.  There is only one of these, and it is+  -- spiritually closer to the const version of the pointers for this class, so+  -- we emit for the const case only.+  when (cst == Const) $ do+    addImports hsImportForPrelude+    addExport' hsValueClassName+    ln+    saysLn ["class ", hsValueClassName, " a where"]+    indent $+      saysLn [hsWithValuePtrName, " :: a -> (", hsTypeName, " -> HoppyP.IO b) -> HoppyP.IO b"]++    -- Generate instances for all pointer subtypes.+    ln+    saysLn ["#if MIN_VERSION_base(4,8,0)"]+    saysLn ["instance {-# OVERLAPPABLE #-} ", hsPtrClassName, " a => ", hsValueClassName, " a",+            if doDecls then " where" else ""]+    saysLn ["#else"]+    saysLn ["instance ", hsPtrClassName, " a => ", hsValueClassName, " a",+            if doDecls then " where" else ""]+    saysLn ["#endif"]+    when doDecls $ do+      addImports $ mconcat [hsImports "Prelude" ["($)", "(.)"],+                            hsImportForPrelude]+      indent $ saysLn [hsWithValuePtrName, " = HoppyP.flip ($) . ", hsCastMethodName]++    -- When the class is encodable to a native Haskell type, also print an+    -- instance for it.+    let conv = getClassHaskellConversion cls+    case (classHaskellConversionType conv,+          classHaskellConversionToCppFn conv) of+      (Just hsTypeGen, Just _) -> do+        hsType <- hsTypeGen+        ln+        saysLn ["#if MIN_VERSION_base(4,8,0)"]+        saysLn ["instance {-# OVERLAPPING #-} ", hsValueClassName, " (", prettyPrint hsType, ")",+                if doDecls then " where" else ""]+        saysLn ["#else"]+        saysLn ["instance ", hsValueClassName, " (", prettyPrint hsType, ")",+                if doDecls then " where" else ""]+        saysLn ["#endif"]+        when doDecls $ do+          addImports hsImportForRuntime+          indent $ saysLn [hsWithValuePtrName, " = HoppyFHR.withCppObj"]+      _ -> return ()++  -- Print the pointer class definition.+  addExport' hsPtrClassName+  ln+  saysLn $+    "class (" :+    intersperse ", " (map (++ " this") hsSupers) +++    [") => ", hsPtrClassName, " this where"]+  indent $ saysLn [hsCastMethodName, " :: this -> ", hsTypeName]++  -- Print the non-static methods.+  when doDecls $ do+    let methods = filter ((cst ==) . methodConst) $ classMethods cls+    forM_ methods $ \method ->+      when (methodStatic method == Nonstatic) $+      (sayExportFn SayExportDecls <$> classEntityExtName cls <*> classEntityForeignName cls <*>+       methodPurity <*> pure (getMethodEffectiveParams cls method) <*>+       methodReturn <*> methodExceptionHandlers) method++sayExportClassHsStaticMethods :: Class -> Generator ()+sayExportClassHsStaticMethods cls =+  forM_ (classMethods cls) $ \method ->+    when (methodStatic method == Static) $+    (sayExportFn SayExportDecls <$> classEntityExtName cls <*> classEntityForeignName cls <*>+     methodPurity <*> methodParams <*> methodReturn <*> methodExceptionHandlers) method++sayExportClassHsType :: Bool -> Class -> Constness -> Generator ()+sayExportClassHsType doDecls cls cst = withErrorContext "generating Haskell data types" $ do+  hsTypeName <- toHsDataTypeName cst cls+  hsCtor <- toHsDataCtorName Unmanaged cst cls+  hsCtorGc <- toHsDataCtorName Managed cst cls+  constCastFnName <- toHsConstCastFnName cst cls++  addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]+  -- Unfortunately, we must export the data constructor, so that GHC can marshal+  -- it in foreign calls in other modules.+  addExport' hsTypeName+  ln+  saysLn ["data ", hsTypeName, " ="]+  indent $ do+    saysLn ["  ", hsCtor, " (HoppyF.Ptr ", hsTypeName, ")"]+    saysLn ["| ", hsCtorGc, " (HoppyF.ForeignPtr ()) (HoppyF.Ptr ", hsTypeName, ")"]+  when doDecls $ do+    addImports $ hsImport1 "Prelude" "(==)"+    indent $ sayLn "deriving (HoppyP.Show)"+    ln+    saysLn ["instance HoppyP.Eq ", hsTypeName, " where"]+    indent $ saysLn ["x == y = HoppyFHR.toPtr x == HoppyFHR.toPtr y"]+    ln+    saysLn ["instance HoppyP.Ord ", hsTypeName, " where"]+    indent $ saysLn ["compare x y = HoppyP.compare (HoppyFHR.toPtr x) (HoppyFHR.toPtr y)"]++  -- Generate const_cast functions:+  --   castFooToConst :: Foo -> FooConst+  --   castFooToNonconst :: FooConst -> Foo+  hsTypeNameOppConst <- toHsDataTypeName (constNegate cst) cls+  ln+  addExport constCastFnName+  saysLn [constCastFnName, " :: ", hsTypeNameOppConst, " -> ", hsTypeName]+  when doDecls $ do+    addImports $ hsImport1 "Prelude" "($)"+    hsCtorOppConst <- toHsDataCtorName Unmanaged (constNegate cst) cls+    hsCtorGcOppConst <- toHsDataCtorName Managed (constNegate cst) cls+    saysLn [constCastFnName, " (", hsCtorOppConst,+            " ptr') = ", hsCtor, " $ HoppyF.castPtr ptr'"]+    saysLn [constCastFnName, " (", hsCtorGcOppConst,+            " fptr' ptr') = ", hsCtorGc, " fptr' $ HoppyF.castPtr ptr'"]++  -- Generate an instance of CppPtr.+  ln+  if doDecls+    then do addImports $ hsImport1 "Prelude" "($)"+            saysLn ["instance HoppyFHR.CppPtr ", hsTypeName, " where"]+            indent $ do+              saysLn ["nullptr = ", hsCtor, " HoppyF.nullPtr"]+              ln+              saysLn ["withCppPtr (", hsCtor, " ptr') f' = f' ptr'"]+              saysLn ["withCppPtr (", hsCtorGc,+                      " fptr' ptr') f' = HoppyF.withForeignPtr fptr' $ \\_ -> f' ptr'"]+              ln+              saysLn ["toPtr (", hsCtor, " ptr') = ptr'"]+              saysLn ["toPtr (", hsCtorGc, " _ ptr') = ptr'"]+              ln+              saysLn ["touchCppPtr (", hsCtor, " _) = HoppyP.return ()"]+              saysLn ["touchCppPtr (", hsCtorGc, " fptr' _) = HoppyF.touchForeignPtr fptr'"]++            when (classDtorIsPublic cls) $ do+              addImports $ hsImport1 "Prelude" "(==)"+              ln+              saysLn ["instance HoppyFHR.Deletable ", hsTypeName, " where"]+              indent $ do+                -- Note, similar "delete" and "toGc" functions are generated for exception+                -- classes' ExceptionClassInfo structures.+                case cst of+                  Const ->+                    saysLn ["delete (", hsCtor, " ptr') = ", toHsClassDeleteFnName' cls, " ptr'"]+                  Nonconst -> do+                    constTypeName <- toHsDataTypeName Const cls+                    saysLn ["delete (",hsCtor, " ptr') = ", toHsClassDeleteFnName' cls,+                            " $ (HoppyF.castPtr ptr' :: HoppyF.Ptr ", constTypeName, ")"]+                saysLn ["delete (", hsCtorGc,+                        " _ _) = HoppyP.fail $ HoppyP.concat ",+                        "[\"Deletable.delete: Asked to delete a GC-managed \", ",+                        show hsTypeName, ", \" object.\"]"]+                ln+                saysLn ["toGc this'@(", hsCtor, " ptr') = ",+                        -- No sense in creating a ForeignPtr for a null pointer.+                        "if ptr' == HoppyF.nullPtr then HoppyP.return this' else HoppyP.fmap ",+                        "(HoppyP.flip ", hsCtorGc, " ptr') $ ",+                        "HoppyF.newForeignPtr ",+                        -- The foreign delete function takes a const pointer; we cast it to+                        -- take a Ptr () to match up with the ForeignPtr () we're creating,+                        -- assuming that data pointers have the same representation.+                        "(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls,+                        " :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",+                        "(HoppyF.castPtr ptr' :: HoppyF.Ptr ())"]+                saysLn ["toGc this'@(", hsCtorGc, " {}) = HoppyP.return this'"]++            forM_ (classFindCopyCtor cls) $ \copyCtor -> do+              copyCtorName <- toHsCtorName cls copyCtor+              ln+              saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ",+                      case cst of+                        Nonconst -> hsTypeName+                        Const -> hsTypeNameOppConst,+                      " where copy = ", copyCtorName]++    else do saysLn ["instance HoppyFHR.CppPtr ", hsTypeName]++            when (classDtorIsPublic cls) $+              saysLn ["instance HoppyFHR.Deletable ", hsTypeName]++            forM_ (classFindCopyCtor cls) $ \_ ->+              saysLn ["instance HoppyFHR.Copyable ", hsTypeName, " ",+                      case cst of+                        Nonconst -> hsTypeName+                        Const -> hsTypeNameOppConst]++  -- Generate instances for all superclasses' typeclasses.+  genInstances hsTypeName [] cls++  where genInstances :: String -> [Class] -> Class -> Generator ()+        genInstances hsTypeName path ancestorCls = do+          -- In this example Bar inherits from Foo.  We are generating instances+          -- either for BarConst or Bar, depending on 'cst'.+          --+          -- BarConst's instances:+          --   instance FooConstPtr BarConst where+          --     toFooConst (BarConst ptr') = FooConst $ castBarToFoo ptr'+          --     toFooConst (BarConstGc fptr' ptr') = FooConstGc fptr' $ castBarToFoo ptr'+          --+          --   instance BarConstPtr BarConst where+          --     toFooConst = id+          --+          -- Bar's instances:+          --   instance FooConstPtr Bar+          --     toFooConst (Bar ptr') =+          --       FooConst $ castBarToFoo $ castBarToConst ptr'+          --     toFooConst (BarGc fptr' ptr') =+          --       FooConstGc fptr' $ castBarToFoo $ castBarToConst ptr'+          --+          --   instance FooPtr Bar+          --     toFoo (Bar ptr') =+          --       Foo $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr'+          --     toFoo (BarGc fptr' ptr') =+          --       FooGc fptr' $ castFooToNonconst $ castBarToFoo $ castBarToConst ptr'+          --+          --   instance BarConstPtr Bar+          --     toBarConst (Bar ptr') = Bar $ castBarToConst ptr'+          --     toBarConst (BarGc fptr' ptr') = BarGc fptr' $ castBarToConst ptr'+          --+          --   instance BarPtr Bar+          --     toBar = id+          --+          -- In all cases, we unwrap the pointer, maybe add const, maybe do an+          -- upcast, maybe remove const, then rewrap the pointer.  The identity+          -- cases are where we just unwrap and wrap again.++          forM_ (case cst of+                   Const -> [Const]+                   Nonconst -> [Const, Nonconst]) $ \ancestorCst -> do+            ln+            ancestorPtrClassName <- toHsPtrClassName ancestorCst ancestorCls+            saysLn ["instance ", ancestorPtrClassName, " ", hsTypeName,+                    if doDecls then " where" else ""]+            when doDecls $ indent $ do+              -- Unqualified, for Haskell instance methods.+              let castMethodName = toHsCastMethodName' ancestorCst ancestorCls+              if null path && cst == ancestorCst+                then do addImports hsImportForPrelude+                        saysLn [castMethodName, " = HoppyP.id"]+                else do let addConst = cst == Nonconst+                            removeConst = ancestorCst == Nonconst+                        when (addConst || removeConst) $+                          addImports hsImportForForeign+                        forM_ ([minBound..] :: [Managed]) $ \managed -> do+                          ancestorCtor <- case managed of+                            Unmanaged -> (\x -> [x]) <$>+                                         toHsDataCtorName Unmanaged ancestorCst ancestorCls+                            Managed -> (\x -> [x, " fptr'"]) <$>+                                       toHsDataCtorName Managed ancestorCst ancestorCls+                          ptrPattern <- case managed of+                            Unmanaged -> (\x -> [x, " ptr'"]) <$>+                                         toHsDataCtorName Unmanaged cst cls+                            Managed -> (\x -> [x, " fptr' ptr'"]) <$>+                                       toHsDataCtorName Managed cst cls+                          saysLn . concat =<< sequence+                            [ return $+                              [castMethodName, " ("] ++ ptrPattern ++ [") = "] ++ ancestorCtor+                            , if removeConst+                              then do ancestorConstType <- toHsDataTypeName Const ancestorCls+                                      ancestorNonconstType <- toHsDataTypeName Nonconst ancestorCls+                                      return [" $ (HoppyF.castPtr :: HoppyF.Ptr ",+                                              ancestorConstType, " -> HoppyF.Ptr ",+                                              ancestorNonconstType, ")"]+                              else return []+                            , if not $ null path+                              then do addImports $ hsImport1 "Prelude" "($)"+                                      castPrimitiveName <- toHsCastPrimitiveName cls cls ancestorCls+                                      return [" $ ", castPrimitiveName]+                              else return []+                            , if addConst+                              then do addImports $ hsImport1 "Prelude" "($)"+                                      nonconstTypeName <- toHsDataTypeName Nonconst cls+                                      constTypeName <- toHsDataTypeName Const cls+                                      return [" $ (HoppyF.castPtr :: HoppyF.Ptr ",+                                              nonconstTypeName, " -> HoppyF.Ptr ",+                                              constTypeName, ")"]+                              else return []+                            , return [" ptr'"]+                            ]++          forM_ (classSuperclasses ancestorCls) $+            genInstances hsTypeName $+            ancestorCls : path++sayExportClassHsVars :: SayExportMode -> Class -> Generator ()+sayExportClassHsVars mode cls =+  forM_ (classVariables cls) $ sayExportClassVar mode cls++sayExportClassHsCtors :: SayExportMode -> Class -> Generator ()+sayExportClassHsCtors mode cls =+  withErrorContext "generating constructors" $+  forM_ (classCtors cls) $ \ctor ->+  (sayExportFn mode <$> classEntityExtName cls <*> classEntityForeignName cls <*>+   pure Nonpure <*> ctorParams <*> pure (ptrT $ objT cls) <*>+   ctorExceptionHandlers) ctor++sayExportClassHsSpecialFns :: SayExportMode -> Class -> Generator ()+sayExportClassHsSpecialFns mode cls = do+  typeName <- toHsDataTypeName Nonconst cls+  typeNameConst <- toHsDataTypeName Const cls++  -- Say the delete function.+  withErrorContext "generating delete bindings" $+    case mode of+      SayExportForeignImports -> when (classDtorIsPublic cls) $ do+        addImports $ mconcat [hsImportForForeign, hsImportForPrelude]+        saysLn ["foreign import ccall \"", classDeleteFnCppName cls, "\" ",+                toHsClassDeleteFnName' cls, " :: HoppyF.Ptr ",+                typeNameConst, " -> HoppyP.IO ()"]+        saysLn ["foreign import ccall \"&", classDeleteFnCppName cls, "\" ",+                toHsClassDeleteFnPtrName' cls, " :: HoppyF.FunPtr (HoppyF.Ptr ",+                typeNameConst, " -> HoppyP.IO ())"]+      -- The user interface to this is the generic 'delete' function, rendered+      -- elsewhere.+      SayExportDecls -> return ()+      SayExportBoot -> return ()++  withErrorContext "generating pointer Assignable instance" $+    case mode of+      SayExportForeignImports -> return ()+      SayExportDecls -> do+        addImports $ mconcat [hsImport1 "Prelude" "($)",+                              hsImportForForeign,+                              hsImportForRuntime]+        ln+        saysLn ["instance HoppyFHR.Assignable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ",+                typeName, " where"]+        indent $ sayLn "assign ptr' value' = HoppyF.poke ptr' $ HoppyFHR.toPtr value'"+      SayExportBoot -> return ()++  -- If the class has an assignment operator that takes its own type, then+  -- generate an instance of Assignable.+  withErrorContext "generating Assignable instance" $ do+    let assignmentMethods = flip filter (classMethods cls) $ \m ->+          methodApplicability m == MNormal &&+          (methodParams m == [objT cls] || methodParams m == [refT $ constT $ objT cls]) &&+          (case methodImpl m of+            RealMethod name -> name == FnOp OpAssign+            FnMethod name -> name == FnOp OpAssign)+        withAssignmentMethod f = case assignmentMethods of+          [] -> return ()+          [m] -> f m+          _ ->+            throwError $ concat+            ["Can't determine an Assignable instance to generator for ", show cls,+            " because it has multiple assignment operators ", show assignmentMethods]+    when (mode == SayExportDecls) $ withAssignmentMethod $ \m -> do+      addImports $ mconcat [hsImport1 "Prelude" "(>>)", hsImportForPrelude]+      valueClassName <- toHsValueClassName cls+      assignmentMethodName <- toHsMethodName cls m+      ln+      saysLn ["instance ", valueClassName, " a => HoppyFHR.Assignable ", typeName, " a where"]+      indent $+        saysLn ["assign x' y' = ", assignmentMethodName, " x' y' >> HoppyP.return ()"]++  -- A pointer to an object pointer is decodable to an object pointer by peeking+  -- at the value, so generate a Decodable instance.  You are now a two-star+  -- programmer.  There is a generic @Ptr (Ptr a)@ to @Ptr a@ instance which+  -- handles deeper levels.+  withErrorContext "generating pointer Decodable instance" $ do+    case mode of+      SayExportForeignImports -> return ()++      SayExportDecls -> do+        addImports $ mconcat [hsImport1 "Prelude" "(.)",+                              hsImportForForeign,+                              hsImportForPrelude,+                              hsImportForRuntime]+        ln+        saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ",+                typeName, ")) ", typeName, " where"]+        indent $ do+          ctorName <- toHsDataCtorName Unmanaged Nonconst cls+          saysLn ["decode = HoppyP.fmap ", ctorName, " . HoppyF.peek"]++      SayExportBoot -> do+        addImports $ mconcat [hsImportForForeign, hsImportForRuntime]+        ln+        -- TODO Encodable.+        saysLn ["instance HoppyFHR.Decodable (HoppyF.Ptr (HoppyF.Ptr ", typeName, ")) ", typeName]++  -- Say Encodable and Decodable instances, if the class is encodable and+  -- decodable.+  withErrorContext "generating Encodable/Decodable instances" $ do+    let conv = getClassHaskellConversion cls+    forM_ (classHaskellConversionType conv) $ \hsTypeGen -> do+      let hsTypeStrGen = hsTypeGen >>= \hsType -> return $ "(" ++ prettyPrint hsType ++ ")"++      case mode of+        SayExportForeignImports -> return ()++        SayExportDecls -> do+          -- Say the Encodable instances.+          forM_ (classHaskellConversionToCppFn conv) $ \toCppFnGen -> do+            hsTypeStr <- hsTypeStrGen+            addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]+            castMethodName <- toHsCastMethodName Const cls++            ln+            saysLn ["instance HoppyFHR.Encodable ", typeName, " ", hsTypeStr, " where"]+            indent $ do+              sayLn "encode ="+              indent toCppFnGen+            ln+            saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " ", hsTypeStr, " where"]+            indent $+              saysLn ["encode = HoppyP.fmap (", castMethodName,+                      ") . HoppyFHR.encodeAs (HoppyP.undefined :: ", typeName, ")"]++          -- Say the Decodable instances.+          forM_ (classHaskellConversionFromCppFn conv) $ \fromCppFnGen -> do+            hsTypeStr <- hsTypeStrGen+            addImports hsImportForRuntime+            castMethodName <- toHsCastMethodName Const cls++            ln+            saysLn ["instance HoppyFHR.Decodable ", typeName, " ", hsTypeStr, " where"]+            indent $+              saysLn ["decode = HoppyFHR.decode . ", castMethodName]+            ln+            saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " ", hsTypeStr, " where"]+            indent $ do+              sayLn "decode ="+              indent fromCppFnGen++        SayExportBoot -> do+          -- Say the Encodable instances.+          forM_ (classHaskellConversionToCppFn conv) $ \_ -> do+            hsTypeStr <- hsTypeStrGen+            addImports hsImportForRuntime+            ln+            saysLn ["instance HoppyFHR.Encodable ", typeName, " (", hsTypeStr, ")"]+            saysLn ["instance HoppyFHR.Encodable ", typeNameConst, " (", hsTypeStr, ")"]++          -- Say the Decodable instances.+          forM_ (classHaskellConversionFromCppFn conv) $ \_ -> do+            hsTypeStr <- hsTypeStrGen+            addImports hsImportForRuntime+            ln+            saysLn ["instance HoppyFHR.Decodable ", typeName, " (", hsTypeStr, ")"]+            saysLn ["instance HoppyFHR.Decodable ", typeNameConst, " (", hsTypeStr, ")"]++-- | Generates a non-const @CppException@ instance if the class is an exception+-- class.+sayExportClassExceptionSupport :: Bool -> Class -> Generator ()+sayExportClassExceptionSupport doDecls cls =+  when (classIsException cls) $+  withErrorContext "generating exception support" $ do+  typeName <- toHsDataTypeName Nonconst cls+  typeNameConst <- toHsDataTypeName Const cls++  -- Generate a non-const CppException instance.+  exceptionId <- getClassExceptionId cls+  addImports hsImportForRuntime+  ln+  saysLn ["instance HoppyFHR.CppException ", typeName,+          if doDecls then " where" else ""]+  when doDecls $ indent $ do+    ctorName <- toHsDataCtorName Unmanaged Nonconst cls+    ctorGcName <- toHsDataCtorName Managed Nonconst cls+    addImports $ mconcat [hsImports "Prelude" ["($)", "(.)", "(=<<)"],+                          hsImportForForeign,+                          hsImportForMap,+                          hsImportForPrelude]+    sayLn "cppExceptionInfo _ ="+    indent $ do+      saysLn ["HoppyFHR.ExceptionClassInfo (HoppyFHR.ExceptionId ",+              show $ getExceptionId exceptionId, ") ", show typeName,+              " upcasts' delete' copy' toGc'"]++      -- Note, similar "delete" and "toGc" functions are generated for the class's+      -- Deletable instance.+      saysLn ["where delete' ptr' = ", toHsClassDeleteFnName' cls,+              " (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeNameConst, ")"]++      indentSpaces 6 $ do+        ctorName <- toHsDataCtorName Unmanaged Nonconst cls+        ln+        saysLn ["copy' = HoppyP.fmap (HoppyF.castPtr . HoppyFHR.toPtr) . HoppyFHR.copy . ",+                ctorName, " . HoppyF.castPtr"]++        ln+        saysLn ["toGc' ptr' = HoppyF.newForeignPtr ",+                -- The foreign delete function takes a const pointer; we cast it to+                -- take a Ptr () to match up with the ForeignPtr () we're creating,+                -- assuming that data pointers have the same representation.+                "(HoppyF.castFunPtr ", toHsClassDeleteFnPtrName' cls,+                " :: HoppyF.FunPtr (HoppyF.Ptr () -> HoppyP.IO ())) ",+                "ptr'"]++        sayLn "upcasts' = HoppyDM.fromList"+        indent $ case classSuperclasses cls of+          [] -> sayLn "[]"+          _ -> do+            let genCast :: Bool -> [Class] -> Class -> Generator ()+                genCast first path ancestorCls =+                  when (classIsException ancestorCls) $ do+                    let path' = ancestorCls : path+                    ancestorId <- getClassExceptionId ancestorCls+                    ancestorCastChain <- forM (zip path' $ drop 1 path') $ \(from, to) ->+                      -- We're upcasting, so 'from' is the subclass.+                      toHsCastPrimitiveName from to from+                    saysLn $ concat [ [if first then "[" else ",",+                                       " ( HoppyFHR.ExceptionId ",+                                       show $ getExceptionId ancestorId,+                                       ", \\(e' :: HoppyF.Ptr ()) -> "]+                                    , intersperse " $ " $+                                        "HoppyF.castPtr" :+                                        ancestorCastChain +++                                        ["HoppyF.castPtr e' :: HoppyF.Ptr ()"]+                                    , [")"]+                                    ]+                    forM_ (classSuperclasses ancestorCls) $ genCast False path'++            forM_ (zip (classSuperclasses cls) (True : repeat False)) $+              \(ancestorCls, first) -> genCast first [cls] ancestorCls+            sayLn "]"++    ln+    saysLn ["cppExceptionBuild fptr' ptr' = ", ctorGcName,+            " fptr' (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"]+    ln+    saysLn ["cppExceptionBuildToGc ptr' = HoppyFHR.toGc $ ", ctorName,+            " (HoppyF.castPtr ptr' :: HoppyF.Ptr ", typeName, ")"]++  -- Generate a const CppException instance that piggybacks off of the+  -- non-const implementation.+  ln+  saysLn ["instance HoppyFHR.CppException ", typeNameConst,+          if doDecls then " where" else ""]+  when doDecls $ indent $ do+    addImports $ mconcat [hsImport1 "Prelude" "(.)",+                          hsImportForPrelude]+    constCastFnName <- toHsConstCastFnName Const cls+    saysLn ["cppExceptionInfo _ = HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ",+            typeName, ")"]+    saysLn ["cppExceptionBuild = (", constCastFnName,+            " .) . HoppyFHR.cppExceptionBuild"]+    saysLn ["cppExceptionBuildToGc = HoppyP.fmap ", constCastFnName,+            " . HoppyFHR.cppExceptionBuildToGc"]++  -- Generate a non-const CppThrowable instance.+  ln+  saysLn ["instance HoppyFHR.CppThrowable ", typeName,+          if doDecls then " where" else ""]+  when doDecls $ indent $ do+    ctorName <- toHsDataCtorName Unmanaged Nonconst cls+    ctorGcName <- toHsDataCtorName Managed Nonconst cls+    addImports $ mconcat [hsImportForForeign,+                          hsImportForPrelude]+    saysLn ["toSomeCppException this'@(", ctorName, " ptr') = HoppyFHR.SomeCppException ",+            "(HoppyFHR.cppExceptionInfo this') HoppyP.Nothing (HoppyF.castPtr ptr')"]+    saysLn ["toSomeCppException this'@(", ctorGcName, " fptr' ptr') = HoppyFHR.SomeCppException ",+            "(HoppyFHR.cppExceptionInfo this') (HoppyP.Just fptr') (HoppyF.castPtr ptr')"]++sayExportClassCastPrimitives :: SayExportMode -> Class -> Generator ()+sayExportClassCastPrimitives mode cls = withErrorContext "generating cast primitives" $ do+  clsType <- toHsDataTypeName Const cls+  case mode of+    SayExportForeignImports ->+      forAncestors cls $ \super -> do+        hsCastFnName <- toHsCastPrimitiveName cls cls super+        hsDownCastFnName <- toHsCastPrimitiveName cls super cls+        superType <- toHsDataTypeName Const super+        addImports hsImportForForeign+        addExport hsCastFnName+        saysLn [ "foreign import ccall \"", classCastFnCppName cls super+               , "\" ", hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType+               ]+        unless (classIsSubclassOfMonomorphic cls || classIsMonomorphicSuperclass super) $ do+          addExport hsDownCastFnName+          saysLn [ "foreign import ccall \"", classCastFnCppName super cls+                 , "\" ", hsDownCastFnName, " :: HoppyF.Ptr ", superType, " -> HoppyF.Ptr ", clsType+                 ]+        return True++    SayExportDecls ->+      -- Generate a downcast typeclass and instances for all ancestor classes+      -- for the current constness.  These don't need to be in the boot file,+      -- since they're not used by other generated bindings.+      unless (classIsSubclassOfMonomorphic cls) $+      forM_ [minBound..] $ \cst -> do+        downCastClassName <- toHsDownCastClassName cst cls+        downCastMethodName <- toHsDownCastMethodName cst cls+        typeName <- toHsDataTypeName cst cls+        addExport' downCastClassName+        ln+        saysLn ["class ", downCastClassName, " a where"]+        indent $ saysLn [downCastMethodName, " :: ",+                         prettyPrint $ HsTyFun (HsTyVar $ HsIdent "a") $+                         HsTyCon $ UnQual $ HsIdent typeName]+        ln+        forAncestors cls $ \super -> case classIsMonomorphicSuperclass super of+          True -> return False+          False -> do+            superTypeName <- toHsDataTypeName cst super+            primitiveCastFn <- toHsCastPrimitiveName cls super cls+            saysLn ["instance ", downCastClassName, " ", superTypeName, " where"]++            -- If Foo is a superclass of Bar:+            --+            -- instance BarSuper Foo where+            --   downToBar castFooToNonconst . downcast' . castFooToConst+            --     where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr'+            --           downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr'+            --+            -- instance BarSuperConst FooConst where+            --   downToBarConst = downcast'+            --     where downcast' (FooConst ptr') = BarConst $ castFooToBar ptr'+            --           downcast' (FooConstGc fptr' ptr') = BarConstGc fptr' $ castFooToBar ptr'++            indent $ do+              case cst of+                Const -> saysLn [downCastMethodName, " = cast'"]+                Nonconst -> do+                  addImports $ hsImport1 "Prelude" "(.)"+                  castClsToNonconst <- toHsConstCastFnName Nonconst cls+                  castSuperToConst <- toHsConstCastFnName Const super+                  saysLn [downCastMethodName, " = ", castClsToNonconst, " . cast' . ",+                          castSuperToConst]+              indent $ do+                sayLn "where"+                indent $ do+                  clsCtorName <- toHsDataCtorName Unmanaged Const cls+                  clsCtorGcName <- toHsDataCtorName Managed Const cls+                  superCtorName <- toHsDataCtorName Unmanaged Const super+                  superCtorGcName <- toHsDataCtorName Managed Const super+                  saysLn ["cast' (", superCtorName, " ptr') = ",+                          clsCtorName, " $ ", primitiveCastFn, " ptr'"]+                  saysLn ["cast' (", superCtorGcName, " fptr' ptr') = ",+                          clsCtorGcName , " fptr' $ ", primitiveCastFn, " ptr'"]+            return True++    SayExportBoot -> do+      forAncestors cls $ \super -> do+        hsCastFnName <- toHsCastPrimitiveName cls cls super+        superType <- toHsDataTypeName Const super+        addImports $ hsImportForForeign+        addExport hsCastFnName+        saysLn [hsCastFnName, " :: HoppyF.Ptr ", clsType, " -> HoppyF.Ptr ", superType]+        return True++  where forAncestors :: Class -> (Class -> Generator Bool) -> Generator ()+        forAncestors cls' f = forM_ (classSuperclasses cls') $ \super -> do+          recur <- f super+          when recur $ forAncestors super f++-- | Outputs the @ExceptionDb@ needed by all Haskell gateway functions that deal+-- with exceptions.+sayExceptionSupport :: Bool -> Generator ()+sayExceptionSupport doDecls = do+  iface <- askInterface+  addExport "exceptionDb'"+  addImports hsImportForRuntime+  ln+  sayLn "exceptionDb' :: HoppyFHR.ExceptionDb"+  when doDecls $ do+    addImports $ mconcat [hsImport1 "Prelude" "($)",+                          hsImportForMap]+    sayLn "exceptionDb' = HoppyFHR.ExceptionDb $ HoppyDM.fromList"+    indent $ do+      let classes = interfaceAllExceptionClasses iface+      case classes of+        [] -> sayLn "[]"+        _ -> do+          addImports hsImportForPrelude+          forM_ (zip classes (True : repeat False)) $ \(cls, first) -> do+            exceptionId <-+              fromMaybeM (throwError $ "sayExceptionSupport: Internal error, " ++ show cls +++                          " has no exception ID.") $+              interfaceExceptionClassId iface cls+            typeName <- toHsDataTypeName Nonconst cls+            saysLn [if first then "[ (" else ", (",+                    "HoppyFHR.ExceptionId ", show $ getExceptionId exceptionId,+                    ", HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ",+                    typeName, "))"]+          sayLn "]"++-- | Implements special logic on top of 'cppTypeToHsTypeAndUse', that computes+-- the Haskell __qualified__ type for a function, including typeclass+-- constraints.+fnToHsTypeAndUse :: HsTypeSide+                 -> Purity+                 -> [Type]+                 -> Type+                 -> ExceptionHandlers+                 -> Generator HsQualType+fnToHsTypeAndUse side purity paramTypes returnType exceptionHandlers = do+  let catches = not $ null $ exceptionHandlersList exceptionHandlers++  params <- mapM contextForParam $+            (if catches && side == HsCSide+             then (++ [("excId", ptrT intT), ("excPtr", ptrT $ ptrT voidT)])+             else id) $+            zip (map toArgName [1..]) paramTypes+  let context = mapMaybe fst params :: HsContext+      hsParams = map snd params++  -- Determine the 'HsHsSide' return type for the function.  Do the conversion+  -- to a Haskell type, and wrap the result in 'IO' if the function is impure.+  -- (HsCSide types always get wrapped in IO.)+  hsReturnInitial <- cppTypeToHsTypeAndUse side returnType+  hsReturnForPurity <- case (purity, side) of+    (Pure, HsHsSide) -> return hsReturnInitial+    _ -> do+      addImports hsImportForPrelude+      return $ HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsReturnInitial++  return $ HsQualType context $ foldr HsTyFun hsReturnForPurity hsParams++  where contextForParam :: (String, Type) -> Generator (Maybe HsAsst, HsType)+        contextForParam (s, t) = case t of+          Internal_TBitspace b -> receiveBitspace s t b+          Internal_TPtr (Internal_TObj cls) -> receivePtr s cls Nonconst+          Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls+          Internal_TRef (Internal_TObj cls) -> receivePtr s cls Nonconst+          Internal_TRef (Internal_TConst (Internal_TObj cls)) -> receiveValue s t cls+          Internal_TObj cls -> receiveValue s t cls+          Internal_TConst t' -> contextForParam (s, t')+          _ -> handoff side t++        -- Use whatever type 'cppTypeToHsTypeAndUse' suggests, with no typeclass+        -- constraints.+        handoff :: HsTypeSide -> Type -> Generator (Maybe HsAsst, HsType)+        handoff side t = (,) Nothing <$> cppTypeToHsTypeAndUse side t++        -- Receives a @IsFooBitspace a => a@.+        receiveBitspace s t b = case side of+          HsCSide -> handoff side t+          HsHsSide -> do+            bitspaceClassName <- toHsBitspaceClassName b+            let t' = HsTyVar $ HsIdent s+            return (Just (UnQual $ HsIdent bitspaceClassName, [t']),+                    t')++        -- Receives a @FooPtr this => this@.+        receivePtr :: String -> Class -> Constness -> Generator (Maybe HsAsst, HsType)+        receivePtr s cls cst = case side of+          HsHsSide -> do+            ptrClassName <- toHsPtrClassName cst cls+            let t' = HsTyVar $ HsIdent s+            return (Just (UnQual $ HsIdent ptrClassName, [t']),+                    t')+          HsCSide -> do+            addImports $ hsImportForForeign+            typeName <- toHsDataTypeName cst cls+            return (Nothing, HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.Ptr") $+                             HsTyVar $ HsIdent typeName)++        -- Receives a @FooValue a => a@.+        receiveValue :: String -> Type -> Class -> Generator (Maybe HsAsst, HsType)+        receiveValue s t cls = case side of+          HsCSide -> handoff side t+          HsHsSide -> do+            addImports hsImportForRuntime+            valueClassName <- toHsValueClassName cls+            let t' = HsTyVar $ HsIdent s+            return (Just (UnQual $ HsIdent valueClassName, [t']),+                    t')++getMethodEffectiveParams :: Class -> Method -> [Type]+getMethodEffectiveParams cls method =+  (case methodImpl method of+     RealMethod {} -> case methodApplicability method of+       MNormal -> (ptrT (objT cls):)+       MConst -> (ptrT (constT $ objT cls):)+       MStatic -> id+     FnMethod {} -> id) $+  methodParams method++getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers+getEffectiveExceptionHandlers handlers = do+  ifaceHandlers <- interfaceExceptionHandlers <$> askInterface+  moduleHandlers <- getExceptionHandlers <$> askModule+  -- Exception handlers declared lower in the hierarchy take precedence over+  -- those in the hierarchy; ExceptionHandlers is a left-biased monoid.+  return $ mconcat [handlers, moduleHandlers, ifaceHandlers]++getEffectiveCallbackThrows :: Callback -> Generator Bool+getEffectiveCallbackThrows cb = case callbackThrows cb of+  Just b -> return b+  Nothing -> moduleCallbacksThrow <$> askModule >>= \case+    Just b -> return b+    Nothing -> interfaceCallbacksThrow <$> askInterface++getClassExceptionId :: Class -> Generator ExceptionId+getClassExceptionId cls = do+  iface <- askInterface+  fromMaybeM (throwError $ concat+              ["Internal error, exception class ", show cls, " doesn't have an exception ID"]) $+    interfaceExceptionClassId iface cls

@@ -1,1877 +1,32 @@ -- This file is part of Hoppy. ----- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with this program.  If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE CPP #-}---- | The primary data types for specifying C++ interfaces.------ 'Show' instances in this module produce strings of the form @\"\<TypeOfObject--- nameOfObject otherInfo...\>\"@.  They can be used in error messages without--- specifying a noun separately, i.e. write @show cls@ instead of @\"the class--- \" ++ show cls@.-module Foreign.Hoppy.Generator.Spec (-  -- * Interfaces-  Interface,-  ErrorMsg,-  interface,-  interfaceName,-  interfaceModules,-  interfaceNamesToModules,-  interfaceHaskellModuleBase,-  interfaceDefaultHaskellModuleBase,-  interfaceAddHaskellModuleBase,-  -- * C++ includes-  Include,-  includeStd,-  includeLocal,-  includeToString,-  -- * Modules-  Module,-  moduleName,-  moduleHppPath,-  moduleCppPath,-  moduleExports,-  moduleReqs,-  moduleHaskellName,-  makeModule,-  moduleModify,-  moduleModify',-  moduleSetHppPath,-  moduleSetCppPath,-  moduleAddExports,-  moduleAddHaskellName,-  -- * Requirements-  Reqs,-  reqsIncludes,-  reqInclude,-  HasReqs (..),-  addReqs,-  addReqIncludes,-  -- * Names and exports-  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,-  -- * Basic types-  Type (..),-  normalizeType,-  stripConst,-  -- ** Variables-  Variable, makeVariable, varIdentifier, varExtName, varType, varReqs,-  varIsConst, varGetterExtName, varSetterExtName,-  -- ** Enums-  CppEnum, makeEnum, enumIdentifier, enumExtName, enumValueNames, enumReqs,-  -- ** Bitspaces-  Bitspace, makeBitspace, bitspaceExtName, bitspaceType, bitspaceValueNames, bitspaceEnum,-  bitspaceAddEnum, bitspaceCppTypeIdentifier, bitspaceFromCppValueFn, bitspaceToCppValueFn,-  bitspaceAddCppType, bitspaceReqs,-  -- ** Functions-  Purity (..),-  Function, makeFn, fnCName, fnExtName, fnPurity, fnParams, fnReturn, fnReqs,-  -- ** Classes-  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,-  -- *** Conversion to and from foreign values-  ClassConversion (..),-  ClassConversionMode (..),-  classConversionNone,-  classModifyConversion,-  classSetConversion,-  classSetConversionToHeap,-  classSetConversionToGc,-  classSetHaskellConversion,-  ClassHaskellConversion (..),-  -- ** Callbacks-  Callback, makeCallback, callbackExtName, callbackParams, callbackReturn, callbackReqs,-  -- * Addenda-  Addendum (..),-  HasAddendum,-  addAddendumHaskell,-  -- * Haskell imports-  HsModuleName, HsImportSet, HsImportKey (..), HsImportSpecs (..), HsImportName, HsImportVal (..),-  hsWholeModuleImport, hsQualifiedImport, hsImport1, hsImport1', hsImports, hsImports',-  hsImportSetMakeSource,-  -- * Internal to Hoppy-  stringOrIdentifier,-  callbackToTFn,-  -- ** Haskell imports-  makeHsImportSet,-  getHsImportSet,-  hsImportForBits,-  hsImportForInt,-  hsImportForWord,-  hsImportForForeign,-  hsImportForForeignC,-  hsImportForPrelude,-  hsImportForRuntime,-  hsImportForSystemPosixTypes,-  hsImportForUnsafeIO,-  -- ** Error messages-  objToHeapTWrongDirectionErrorMsg,-  tToGcInvalidFormErrorMessage,-  toGcTWrongDirectionErrorMsg,-  ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif-import Control.Arrow ((&&&))-import Control.Monad (liftM2, unless)-#if MIN_VERSION_mtl(2,2,1)-import Control.Monad.Except (MonadError, throwError)-#else-import Control.Monad.Error (MonadError, throwError)-#endif-import Control.Monad.State (MonadState, StateT, execStateT, get, modify)-import Data.Char (isAlpha, isAlphaNum, toUpper)-import Data.Function (on)-import Data.List (intercalate, intersperse)-import qualified Data.Map as M-import Data.Maybe (fromMaybe)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid, mappend, mconcat, mempty)-#endif-import qualified Data.Set as S-import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as Haskell-import Language.Haskell.Syntax (HsType)---- | Indicates strings that are error messages.-type ErrorMsg = String---- | A complete specification of a C++ API.  Generators for different languages,--- including the binding generator for C++, use these to produce their output.-data Interface = Interface-  { interfaceName :: String-    -- ^ The textual name of the interface.-  , interfaceModules :: M.Map String Module-    -- ^ All of the individual modules, by 'moduleName'.-  , interfaceNamesToModules :: M.Map ExtName Module-    -- ^ Maps each 'ExtName' exported by some module to the module that exports-    -- the name.-  , interfaceHaskellModuleBase' :: Maybe [String]-    -- ^ See 'interfaceHaskellModuleBase'.-  }--instance Show Interface where-  show iface = concat ["<Interface ", show (interfaceName iface), ">"]---- | Constructs an 'Interface' from the required parts.  Some validation is--- performed; if the resulting interface would be invalid, an error message is--- returned instead.-interface :: String  -- ^ 'interfaceName'-          -> [Module]  -- ^ 'interfaceModules'-          -> Either ErrorMsg Interface-interface ifName modules = do-  -- TODO Check for duplicate module names.-  -- TODO Check for duplicate module file paths.--  -- Check for multiple modules exporting an ExtName.-  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-    }---- | The name of the parent Haskell module under which a Haskell module will be--- generated for a Hoppy 'Module'.  This is a list of Haskell module path--- components, in other words, @'Data.List.intercalate' "."@ on the list--- produces a Haskell module name.  Defaults to--- 'interfaceDefaultHaskellModuleBase', and may be overridden with--- 'interfaceAddHaskellModuleBase'.-interfaceHaskellModuleBase :: Interface -> [String]-interfaceHaskellModuleBase =-  fromMaybe interfaceDefaultHaskellModuleBase . interfaceHaskellModuleBase'---- | The default Haskell module under which Hoppy modules will be generated.--- This is @Foreign.Hoppy.Generated@, that is:------ > ["Foreign", "Hoppy", "Generated"]-interfaceDefaultHaskellModuleBase :: [String]-interfaceDefaultHaskellModuleBase = ["Foreign", "Hoppy", "Generated"]---- | Sets an interface to generate all of its modules under the given Haskell--- module prefix.  See 'interfaceHaskellModuleBase'.-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-    ]---- | An @#include@ directive in a C++ file.-data Include = Include-  { includeToString :: String-    -- ^ Returns the complete @#include ...@ line for an include, including-    -- trailing newline.-  } deriving (Eq, Ord, Show)---- | Creates an @#include \<...\>@ directive.-includeStd :: String -> Include-includeStd path = Include $ "#include <" ++ path ++ ">\n"---- | Creates an @#include "..."@ directive.-includeLocal :: String -> Include-includeLocal path = Include $ "#include \"" ++ path ++ "\"\n"---- | A portion of functionality in a C++ API.  An 'Interface' is composed of--- multiple modules.  A module will generate a single compilation unit--- containing bindings for all of the module's exports.  The C++ code for a--- 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.-data Module = Module-  { moduleName :: String-    -- ^ The module's name.  A module name must identify a unique module within-    -- an 'Interface'.-  , moduleHppPath :: String-    -- ^ A relative path under a C++ sources root to which the generator will-    -- write a header file for the module's C++ bindings.-  , moduleCppPath :: String-    -- ^ A relative path under a C++ sources root to which the generator will-    -- write a source file for the module's C++ bindings.-  , moduleExports :: M.Map ExtName Export-    -- ^ All of the exports in a module.-  , moduleReqs :: Reqs-    -- ^ Module-level requirements.-  , moduleHaskellName :: Maybe [String]-    -- ^ The generated Haskell module name, underneath the-    -- 'interfaceHaskellModuleBase'.  If absent (by default), the 'moduleName'-    -- is used.  May be modified with 'moduleAddHaskellName'.-  }--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 }---- | Creates an empty module, ready to be configured with 'moduleModify'.-makeModule :: String  -- ^ 'moduleName'-           -> String  -- ^ 'moduleHppPath'-           -> String  -- ^ 'moduleCppPath'-           -> Module-makeModule name hppPath cppPath = Module-  { moduleName = name-  , moduleHppPath = hppPath-  , moduleCppPath = cppPath-  , moduleExports = M.empty-  , moduleReqs = mempty-  , moduleHaskellName = Nothing-  }---- | Extends a module.  To be used with the module state-monad actions in this--- package.-moduleModify :: Module -> StateT Module (Either String) () -> Either ErrorMsg Module-moduleModify = flip execStateT---- | Same as 'moduleModify', but calls 'error' in the case of failure, which is--- okay in for a generator which would abort in this case anyway.-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'---- | Replaces a module's 'moduleHppPath'.-moduleSetHppPath :: MonadState Module m => String -> m ()-moduleSetHppPath path = modify $ \m -> m { moduleHppPath = path }---- | Replaces a module's 'moduleCppPath'.-moduleSetCppPath :: MonadState Module m => String -> m ()-moduleSetCppPath path = modify $ \m -> m { moduleCppPath = path }---- | Adds exports to a module.  An export must only be added to any module at--- most once, and must not be added to multiple modules.-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]---- | Changes a module's 'moduleHaskellName' from the default.  This can only be--- called once on a module.-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, "."]---- | A set of requirements of needed to use an identifier in C++ (function,--- type, etc.), via a set of 'Include's.  The monoid instance has 'mempty' as an--- empty set of includes, and 'mappend' unions two include sets.-data Reqs = Reqs-  { reqsIncludes :: S.Set Include-    -- ^ The includes specified by a 'Reqs'.-  } 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---- | Creates a 'Reqs' that contains the given include.-reqInclude :: Include -> Reqs-reqInclude include = mempty { reqsIncludes = S.singleton include }---- | C++ types that have requirements in order to use them in generated--- bindings.-class HasReqs a where-  {-# MINIMAL getReqs, (setReqs | modifyReqs) #-}--  -- | Returns an object's requirements.-  getReqs :: a -> Reqs--  -- | Replaces an object's requirements with new ones.-  setReqs :: Reqs -> a -> a-  setReqs = modifyReqs . const--  -- | Modifies an object's requirements.-  modifyReqs :: (Reqs -> Reqs) -> a -> a-  modifyReqs f x = setReqs (f $ getReqs x) x---- | Adds to a object's requirements.-addReqs :: HasReqs a => Reqs -> a -> a-addReqs reqs = modifyReqs $ mappend reqs---- | Adds a list of includes to the requirements of an object.-addReqIncludes :: HasReqs a => [Include] -> a -> a-addReqIncludes includes =-  modifyReqs $ mappend mempty { reqsIncludes = S.fromList includes }---- | An external name is a string that generated bindings use to uniquely--- identify an object at runtime.  An external name must start with an--- alphabetic character, and may only contain alphanumeric characters and @'_'@.--- You are free to use whatever naming style you like; case conversions will be--- performed automatically when required.  Hoppy does make use of some--- conventions though, for example with 'Operator's and in the provided bindings--- for the C++ standard library.------ External names must be unique within an interface.  They may not be reused--- between modules.  This assumption is used for symbol naming in compiled--- shared objects and to freely import modules in Haskell bindings.-newtype ExtName = ExtName-  { fromExtName :: String-    -- ^ Returns the string an an 'ExtName' contains.-  } deriving (Eq, Ord)--instance Show ExtName where-  show extName = concat ["$\"", fromExtName extName, "\"$"]---- | Creates an 'ExtName' that contains the given string, erroring if the string--- is an invalid '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---- | Generates an 'ExtName' from an 'Identifier', if the given name is absent.-extNameOrIdentifier :: Identifier -> Maybe ExtName -> ExtName-extNameOrIdentifier ident = fromMaybe $ case identifierParts ident of-  [] -> error "extNameOrIdentifier: Invalid empty identifier."-  parts -> toExtName $ idPartBase $ last parts---- | Like 'extNameOrIdentifier', but works with strings rather than 'ExtName's.-stringOrIdentifier :: Identifier -> Maybe String -> String-stringOrIdentifier ident = fromMaybe $ case identifierParts ident of-  [] -> error "stringOrIdentifier: Invalid empty identifier."-  parts -> idPartBase $ last parts---- | Generates an 'ExtName' from an @'FnName' 'Identifier'@, if the given name--- is absent.-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---- | The C++ name of a function or method.-data FnName name =-  FnName name-  -- ^ A regular, \"alphanumeric\" name.  The exact type depends on what kind of-  -- object is being named.-  | FnOp Operator-    -- ^ An operator name.-  deriving (Eq, Ord)--instance Show name => Show (FnName name) where-  show (FnName name) = concat ["<FnName ", show name, ">"]-  show (FnOp op) = concat ["<FnOp ", show op, ">"]---- | Enables implementing automatic conversions to a @'FnName' t@.-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---- | Overloadable C++ operators.-data Operator =-  OpCall  -- ^ @x(...)@-  | OpComma -- ^ @x, y@-  | OpAssign  -- ^ @x = y@-  | OpArray  -- ^ @x[y]@-  | OpDeref  -- ^ @*x@-  | OpAddress  -- ^ @&x@-  | OpAdd  -- ^ @x + y@-  | OpAddAssign  -- ^ @x += y@-  | OpSubtract  -- ^ @x - y@-  | OpSubtractAssign  -- ^ @x -= y@-  | OpMultiply  -- ^ @x * y@-  | OpMultiplyAssign  -- ^ @x *= y@-  | OpDivide  -- ^ @x / y@-  | OpDivideAssign  -- ^ @x /= y@-  | OpModulo  -- ^ @x % y@-  | OpModuloAssign  -- ^ @x %= y@-  | OpPlus  -- ^ @+x@-  | OpMinus  -- ^ @-x@-  | OpIncPre  -- ^ @++x@-  | OpIncPost  -- ^ @x++@-  | OpDecPre  -- ^ @--x@-  | OpDecPost  -- ^ @x--@-  | OpEq  -- ^ @x == y@-  | OpNe  -- ^ @x != y@-  | OpLt  -- ^ @x < y@-  | OpLe  -- ^ @x <= y@-  | OpGt  -- ^ @x > y@-  | OpGe  -- ^ @x >= y@-  | OpNot  -- ^ @!x@-  | OpAnd  -- ^ @x && y@-  | OpOr  -- ^ @x || y@-  | OpBitNot  -- ^ @~x@-  | OpBitAnd  -- ^ @x & y@-  | OpBitAndAssign  -- ^ @x &= y@-  | OpBitOr  -- ^ @x | y@-  | OpBitOrAssign  -- ^ @x |= y@-  | OpBitXor  -- ^ @x ^ y@-  | OpBitXorAssign  -- ^ @x ^= y@-  | OpShl  -- ^ @x << y@-  | OpShlAssign  -- ^ @x <<= y@-  | OpShr  -- ^ @x >> y@-  | OpShrAssign  -- ^ @x >>= y@-  deriving (Bounded, Enum, Eq, Ord, Show)---- | The arity and syntax of an operator.-data OperatorType =-  UnaryPrefixOperator String  -- ^ Prefix unary operators.  Examples: @!x@, @*x@, @++x@.-  | UnaryPostfixOperator String  -- ^ Postfix unary operators.  Examples: @x--, x++@.-  | BinaryOperator String  -- ^ Infix binary operators.  Examples: @x * y@, @x >>= y@.-  | CallOperator  -- ^ @x(...)@ with arbitrary arity.-  | ArrayOperator  -- ^ @x[y]@, a binary operator with non-infix syntax.--data OperatorInfo = OperatorInfo-  { operatorPreferredExtName'' :: ExtName-  , operatorType' :: OperatorType-  }--makeOperatorInfo :: String -> OperatorType -> OperatorInfo-makeOperatorInfo = OperatorInfo . toExtName---- | Returns a conventional string to use for the 'ExtName' of an operator.-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, "."]---- | Returns a conventional name for an operator, as with--- 'operatorPreferredExtName', but as a string.-operatorPreferredExtName' :: Operator -> String-operatorPreferredExtName' = fromExtName . operatorPreferredExtName---- | Returns the type of an operator.-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, "."]---- | Metadata for operators.------ TODO Test out this missing data.-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."---- | Specifies some C++ object (function or class) to give access to.-data Export =-  ExportVariable Variable  -- ^ Exports a variable.-  | ExportEnum CppEnum  -- ^ Exports an enum.-  | ExportBitspace Bitspace  -- ^ Exports a bitspace.-  | ExportFn Function  -- ^ Exports a function.-  | ExportClass Class  -- ^ Exports a class with all of its contents.-  | ExportCallback Callback  -- ^ Exports a callback.-  deriving (Show)---- | Returns the external name of an export.-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---- | Returns the export's addendum.  'Export' doesn't have a 'HasAddendum'--- instance because you normally wouldn't want to modify the addendum of one.-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---- | A path to some C++ object, including namespaces.  An identifier consists of--- multiple parts separated by @\"::\"@.  Each part has a name string followed--- by an optional template argument list, where each argument gets rendered from--- a 'Type' (non-type arguments for template metaprogramming are not supported).-newtype Identifier = Identifier-  { identifierParts :: [IdPart]-    -- ^ The separate parts of the identifier, between @::@s.-  } 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---- | A single component of an 'Identifier', between @::@s.-data IdPart = IdPart-  { idPartBase :: String-    -- ^ The name within the enclosing scope.-  , idPartArgs :: Maybe [Type]-    -- ^ Template arguments, if present.-  } deriving (Eq, Show)---- | Creates an identifier of the form @a@.-ident :: String -> Identifier-ident a = Identifier [IdPart a Nothing]---- | Creates an identifier of the form @a1::a2::...::aN@.-ident' :: [String] -> Identifier-ident' = Identifier . map (\x -> IdPart x Nothing)---- | Creates an identifier of the form @a::b@.-ident1 :: String -> String -> Identifier-ident1 a b = ident' [a, b]---- | Creates an identifier of the form @a::b::c@.-ident2 :: String -> String -> String -> Identifier-ident2 a b c = ident' [a, b, c]---- | Creates an identifier of the form @a::b::c::d@.-ident3 :: String -> String -> String -> String -> Identifier-ident3 a b c d = ident' [a, b, c, d]---- | Creates an identifier of the form @a::b::c::d::e@.-ident4 :: String -> String -> String -> String -> String -> Identifier-ident4 a b c d e = ident' [a, b, c, d, e]---- | Creates an identifier of the form @a::b::c::d::e::f@.-ident5 :: String -> String -> String -> String -> String -> String -> Identifier-ident5 a b c d e f = ident' [a, b, c, d, e, f]---- | Creates an identifier of the form @a\<...\>@.-identT :: String -> [Type] -> Identifier-identT a ts = Identifier [IdPart a $ Just ts]---- | Creates an identifier with arbitrary many templated and non-templated--- parts.-identT' :: [(String, Maybe [Type])] -> Identifier-identT' = Identifier . map (uncurry IdPart)---- | Creates an identifier of the form @a::b\<...\>@.-ident1T :: String -> String -> [Type] -> Identifier-ident1T a b ts = Identifier [IdPart a Nothing, IdPart b $ Just ts]---- | Creates an identifier of the form @a::b::c\<...\>@.-ident2T :: String -> String -> String -> [Type] -> Identifier-ident2T a b c ts = Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c $ Just ts]---- | Creates an identifier of the form @a::b::c::d\<...\>@.-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]---- | Creates an identifier of the form @a::b::c::d::e\<...\>@.-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]---- | Creates an identifier of the form @a::b::c::d::e::f\<...\>@.-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]---- | A concrete C++ type.  Use the bindings in "Foreign.Hoppy.Generator.Types"--- for values of this type; these data constructors are subject to change--- without notice.-data Type =-    Internal_TVoid-  | Internal_TBool-  | Internal_TChar-  | Internal_TUChar-  | Internal_TShort-  | Internal_TUShort-  | Internal_TInt-  | Internal_TUInt-  | Internal_TLong-  | Internal_TULong-  | Internal_TLLong-  | Internal_TULLong-  | Internal_TFloat-  | Internal_TDouble-  | Internal_TInt8-  | Internal_TInt16-  | Internal_TInt32-  | Internal_TInt64-  | Internal_TWord8-  | Internal_TWord16-  | Internal_TWord32-  | Internal_TWord64-  | Internal_TPtrdiff-  | Internal_TSize-  | Internal_TSSize-  | Internal_TEnum CppEnum-  | Internal_TBitspace Bitspace-  | Internal_TPtr Type-  | Internal_TRef Type-  | Internal_TFn [Type] Type-  | Internal_TCallback Callback-  | Internal_TObj Class-  | Internal_TObjToHeap Class-  | Internal_TToGc Type-  | Internal_TConst Type-  deriving (Eq, Show)---- | Canonicalizes a 'Type' without changing its meaning.  Multiple nested--- 'Internal_TConst's are collapsed into a single one.-normalizeType :: Type -> Type-normalizeType t = case t of-  Internal_TVoid -> t-  Internal_TBool -> t-  Internal_TChar -> t-  Internal_TUChar -> t-  Internal_TShort -> t-  Internal_TUShort -> t-  Internal_TInt -> t-  Internal_TUInt -> t-  Internal_TLong -> t-  Internal_TULong -> t-  Internal_TLLong -> t-  Internal_TULLong -> t-  Internal_TFloat -> t-  Internal_TDouble -> t-  Internal_TInt8 -> t-  Internal_TInt16 -> t-  Internal_TInt32 -> t-  Internal_TInt64 -> t-  Internal_TWord8 -> t-  Internal_TWord16 -> t-  Internal_TWord32 -> t-  Internal_TWord64 -> t-  Internal_TPtrdiff -> t-  Internal_TSize -> t-  Internal_TSSize -> t-  Internal_TEnum _ -> t-  Internal_TBitspace _ -> t-  Internal_TPtr t' -> Internal_TPtr $ normalizeType t'-  Internal_TRef t' -> Internal_TRef $ normalizeType t'-  Internal_TFn paramTypes retType ->-    Internal_TFn (map normalizeType paramTypes) $ normalizeType retType-  Internal_TCallback _ -> t-  Internal_TObj _ -> t-  Internal_TObjToHeap _ -> t-  Internal_TToGc _ -> t-  Internal_TConst (Internal_TConst t') -> normalizeType $ Internal_TConst t'-  Internal_TConst _ -> t---- | Strips leading 'Internal_TConst's off of a type.-stripConst :: Type -> Type-stripConst t = case t of-  Internal_TConst t' -> stripConst t'-  _ -> t---- | A C++ variable.-data Variable = Variable-  { varIdentifier :: Identifier-    -- ^ The identifier used to refer to the variable.-  , varExtName :: ExtName-    -- ^ The variable's external name.-  , varType :: Type-    -- ^ The type of the variable.  This may be-    -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is-    -- read-only.-  , varReqs :: Reqs-    -- ^ Requirements for bindings to use this variable.-  , varAddendum :: Addendum-    -- ^ The variable's 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 }---- | Creates a binding for a C++ variable.-makeVariable :: Identifier -> Maybe ExtName -> Type -> Variable-makeVariable identifier maybeExtName t =-  Variable identifier (extNameOrIdentifier identifier maybeExtName) t mempty mempty---- | Returns whether the variable is constant, i.e. whether its type is--- @'Foreign.Hoppy.Generator.Types.constT' ...@.-varIsConst :: Variable -> Bool-varIsConst v = case varType v of-  Internal_TConst _ -> True-  _ -> False---- | Returns the external name of the getter function for the variable.-varGetterExtName :: Variable -> ExtName-varGetterExtName = toExtName . (++ "_get") . fromExtName . varExtName---- | Returns the external name of the setter function for the variable.-varSetterExtName :: Variable -> ExtName-varSetterExtName = toExtName . (++ "_set") . fromExtName . varExtName---- | A C++ enum declaration.  An enum should actually be enumerable (in the--- sense of Haskell's 'Enum'); if it's not, consider using a 'Bitspace' instead.-data CppEnum = CppEnum-  { enumIdentifier :: Identifier-    -- ^ The identifier used to refer to the enum.-  , enumExtName :: ExtName-    -- ^ The enum's external name.-  , enumValueNames :: [(Int, [String])]-    -- ^ The numeric values and names of the enum values.  A single value's name-    -- 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.-  , enumAddendum :: Addendum-    -- ^ The enum's 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 }---- | Creates a binding for a C++ enum.-makeEnum :: Identifier  -- ^ 'enumIdentifier'-         -> Maybe ExtName-         -- ^ An optional external name; will be automatically derived from-         -- the identifier if absent.-         -> [(Int, [String])]  -- ^ 'enumValueNames'-         -> CppEnum-makeEnum identifier maybeExtName valueNames =-  CppEnum identifier (extNameOrIdentifier identifier maybeExtName) valueNames mempty mempty---- | A C++ numeric space with bitwise operations.  This is similar to a--- 'CppEnum', but in addition to the extra operations, this differs in that--- these values aren't enumerable.------ Additionally, as a kludge for Qtah, a bitspace may have a C++ type--- ('bitspaceCppTypeIdentifier') separate from its numeric type--- ('bitspaceType').  Qt bitspaces aren't raw numbers but are instead type-safe--- @QFlags@ objects that don't implicitly convert from integers, so we need a--- means to do so manually.  Barring general ad-hoc argument and return value--- conversion support, we allow this as follows: when given a C++ type, then a--- bitspace may also have a conversion function between the numeric and C++--- type, in each direction.  If a conversion function is present, it will be--- used for conversions in its respective direction.  The C++ type is not a full--- 'Type', but only an 'Identifier', since additional information is not needed.--- See 'bitspaceAddCppType'.-data Bitspace = Bitspace-  { bitspaceExtName :: ExtName-    -- ^ The bitspace's external name.-  , bitspaceType :: Type-    -- ^ The C++ type used for bits values.  This should be a primitive numeric-    -- type, usually 'Foreign.Hoppy.Generator.Types.intT'.-  , bitspaceValueNames :: [(Int, [String])]-    -- ^ The numeric values and names of the bitspace values.  See-    -- 'enumValueNames'.-  , bitspaceEnum :: Maybe CppEnum-    -- ^ An associated enum, whose values may be converted to values in the-    -- bitspace.-  , bitspaceCppTypeIdentifier :: Maybe Identifier-    -- ^ The optional C++ type for a bitspace.-  , bitspaceToCppValueFn :: Maybe String-    -- ^ The name of a C++ function to convert from 'bitspaceType' to the-    -- bitspace's C++ type.-  , bitspaceFromCppValueFn :: Maybe String-    -- ^ The name of a C++ function to convert from the bitspace's C++ type to-    -- 'bitspaceType'.-  , bitspaceReqs :: Reqs-    -- ^ Requirements for emitting the bindings for a bitspace, i.e. what's-    -- necessary to reference 'bitspaceCppTypeIdentifier',-    -- 'bitspaceFromCppValueFn', and 'bitspaceToCppValueFn'.  'bitspaceType' can-    -- take some numeric types that require includes as well, but you don't need-    -- to list these here.-  , bitspaceAddendum :: Addendum-    -- ^ The bitspace's 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 }---- | Creates a binding for a C++ bitspace.-makeBitspace :: ExtName  -- ^ 'bitspaceExtName'-             -> Type  -- ^ 'bitspaceType'-             -> [(Int, [String])]  -- ^ 'bitspaceValueNames'-             -> Bitspace-makeBitspace extName t valueNames =-  Bitspace extName t valueNames Nothing Nothing Nothing Nothing mempty mempty---- | Associates an enum with the bitspace.  See 'bitspaceEnum'.-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 cppTypeIdentifier toCppValueFn fromCppValueFn@--- associates a C++ type (plus optional conversion functions) with a bitspace.--- At least one conversion should be specified, otherwise adding the C++ type--- will mean nothing.  You should also add use requirements to the bitspace for--- all of these arguments; see 'HasReqs'.-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-        }---- | Whether or not a function may cause side-effects.------ Haskell bindings for pure functions will not be in 'IO', and calls to pure--- functions will be executed non-strictly.  Calls to impure functions will--- execute in the IO monad.------ Member functions for mutable classes should not be made pure, because it is--- difficult in general to control when the call will be made.-data Purity = Nonpure  -- ^ Side-affects are possible.-            | Pure  -- ^ Side-affects will not happen.-            deriving (Eq, Show)---- | A C++ function declaration.-data Function = Function-  { fnCName :: FnName Identifier-    -- ^ The identifier used to call the function.-  , fnExtName :: ExtName-    -- ^ The function's external name.-  , fnPurity :: Purity-    -- ^ Whether the function is pure.-  , fnParams :: [Type]-    -- ^ The function's parameter types.-  , fnReturn :: Type-    -- ^ The function's return type.-  , fnReqs :: Reqs-    -- ^ Requirements for a binding to call the function.-  , fnAddendum :: Addendum-    -- ^ The function's 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 }---- | Creates a binding for a C++ function.-makeFn :: IsFnName Identifier name-       => name-       -> Maybe ExtName-       -- ^ An optional external name; will be automatically derived from-       -- the identifier if absent.-       -> Purity-       -> [Type]  -- ^ Parameter types.-       -> Type  -- ^ Return type.-       -> Function-makeFn cName maybeExtName purity paramTypes retType =-  let fnName = toFnName cName-  in Function fnName-              (extNameOrFnIdentifier fnName maybeExtName)-              purity paramTypes retType mempty mempty---- | A C++ class declaration.  A class's external name is automatically combined--- with the external names of things inside the class, by way of--- 'HasClassyExtName'.-data Class = Class-  { classIdentifier :: Identifier-    -- ^ The identifier used to refer to the class.-  , classExtName :: ExtName-    -- ^ The class's external name.-  , classSuperclasses :: [Class]-    -- ^ The class's public superclasses.-  , classCtors :: [Ctor]-    -- ^ The class's constructors.-  , classDtorIsPublic :: Bool-    -- ^ Whether the class's destructor has public visibility.-  , classMethods :: [Method]-    -- ^ The class's methods.-  , classConversion :: ClassConversion-    -- ^ Behaviour for converting objects to and from foriegn values.-  , classReqs :: Reqs-    -- ^ Requirements for a 'Type' to reference this class.-  , classAddendum :: Addendum-    -- ^ The class's addendum.-  , classIsMonomorphicSuperclass :: Bool-    -- ^ This is true for classes passed through-    -- 'classSetMonomorphicSuperclass'.-  , classIsSubclassOfMonomorphic :: Bool-    -- ^ This is true for classes passed through-    -- 'classSetSubclassOfMonomorphic'.-  }--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 }---- | Creates a binding for a C++ class and its contents.-makeClass :: Identifier-          -> Maybe ExtName-          -- ^ An optional external name; will be automatically derived from the-          -- identifier if absent.-          -> [Class]  -- ^ Superclasses.-          -> [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-  }---- | Adds constructors to a class.-classAddCtors :: [Ctor] -> Class -> Class-classAddCtors ctors cls =-  if null ctors then cls else cls { classCtors = classCtors cls ++ ctors }---- | Marks a class's destructor as private, so that a binding for it won't be--- generated.-classSetDtorPrivate :: Class -> Class-classSetDtorPrivate cls = cls { classDtorIsPublic = False }---- | Explicitly marks a class as being monomorphic (i.e. not having any--- virtual methods or destructors).  By default, Hoppy assumes that a class that--- is derived is also polymorphic, but it can happen that this is not the case.--- Downcasting with @dynamic_cast@ from such classes is not available.  See also--- 'classSetSubclassOfMonomorphic'.-classSetMonomorphicSuperclass :: Class -> Class-classSetMonomorphicSuperclass cls = cls { classIsMonomorphicSuperclass = True }---- | Marks a class as being derived from some monomorphic superclass.  This--- prevents any downcasting to this class.  Generally it is better to use--- 'classSetMonomorphicSuperclass' on the specific superclasses that are--- monomorphic, but in cases where this is not possible, this function can be--- applied to the subclass instead.-classSetSubclassOfMonomorphic :: Class -> Class-classSetSubclassOfMonomorphic cls = cls { classIsSubclassOfMonomorphic = True }---- | Adds methods to a class.-classAddMethods :: [Method] -> Class -> Class-classAddMethods methods cls =-  if null methods then cls else cls { classMethods = classMethods cls ++ methods }---- | When a class object is returned from a function or taken as a parameter by--- value (i.e. with 'Foreign.Hoppy.Generator.Types.objT'), it will be converted--- to or from a foreign (non-C++) object.  Conversion may also be performed--- explicitly.  This data type describes how to perform those conversions.  A--- class may or may not support conversion, for any particular foreign language;--- what is said below only applies to classes that are convertible for a--- language.------ When converting between a C++ value and a foreign value, a pointer to the--- object is passed between C++ and the foreign language.  Then, for each--- foreign language, a binding author can provide pieces of code in that--- language to translate between the pointer and a foreign value (usually by--- invoking the FFI functions generated by Hoppy), and generated bindings will--- perform these conversions automatically.  The code supplied to convert in--- each direction should leave the original object unchanged (and alive, in case--- of manual memory management).  (Internally, during a function call in either--- direction, the side that creates a value is in charge of its lifetime, but--- this is managed by Hoppy.)------ In foreign code, foreign values can be explicitly converted to new C++ (heap)--- objects, and C++ object pointers can be explicitly converted to foreign--- values, via special functions generated for the class.-data ClassConversion = ClassConversion-  { classHaskellConversion :: ClassConversionMode ClassHaskellConversion-    -- ^ Conversions to and from Haskell.--    -- NOTE!  When adding new languages here, add the language to-    -- 'classSetConversionToHeap', and 'classSetConversionToGc' as well if the-    -- language supports garbage collection.-  }---- | Specifies whether (and if so, how) objects of a class get converted to and--- from values in a specific foreign language.-data ClassConversionMode a =-    ClassConversionNone-    -- ^ Indicates that a class __is not__ convertible for a language.  Passing-    -- raw 'Foreign.Hoppy.Generator.Types.objT' values into and out of C++ is-    -- not allowed.-  | ClassConversionManual a-    -- ^ Indicates that a class __is__ convertible for a language.  Passing raw-    -- 'Foreign.Hoppy.Generator.Types.objT' values into and out of C++ is-    -- allowed, and the attached structure describes how to perform the-    -- conversions.-  | ClassConversionToHeap-    -- ^ Indicates that a class __is not__ convertible for a language.-    -- Nevertheless, passing an object from C++ to the foreign language via a-    -- type of @'Foreign.Hoppy.Generator.Types.objT' cls@ is allowed, and-    -- behaves as though the type were-    -- @'Foreign.Hoppy.Generator.Types.objToHeapT' cls@ instead.-  | ClassConversionToGc-    -- ^ Indicates that a class __is not__ convertible for a language.-    -- Nevertheless, passing an object from C++ to the foreign language via a-    -- type of @'Foreign.Hoppy.Generator.Types.objT' cls@ is allowed, and-    -- behaves as though the type were @'Foreign.Hoppy.Generator.Types.toGcT'-    -- ('Foreign.Hoppy.Generator.Types.objT' cls)@ instead.-    ---    -- This should be used for value objects so that you can simply use-    -- @'Foreign.Hoppy.Generator.Types.objT' cls@ in return types, and also-    -- write on @'mkProp' "..." ('Foreign.Hoppy.Generator.Types.objT' cls)@.---- | Encoding parameters for a class that is not encodable or decodable.-classConversionNone :: ClassConversion-classConversionNone = ClassConversion ClassConversionNone---- | Modifies a class's 'ClassConversion' structure with a given function.-classModifyConversion :: (ClassConversion -> ClassConversion) -> Class -> Class-classModifyConversion f cls = cls { classConversion = f $ classConversion cls }---- | Replaces a class's 'ClassConversion' structure.-classSetConversion :: ClassConversion -> Class -> Class-classSetConversion c cls = cls { classConversion = c }---- | Modifies a class's 'ClassConversion' structure by setting all languages--- to use 'ClassConversionToHeap'.-classSetConversionToHeap :: Class -> Class-classSetConversionToHeap cls = flip classModifyConversion cls $ \c ->-  c { classHaskellConversion = ClassConversionToHeap-    }---- | Modifies a class's 'ClassConversion' structure by setting all languages--- that support garbage collection to use 'ClassConversionToGc'.-classSetConversionToGc :: Class -> Class-classSetConversionToGc cls = flip classModifyConversion cls $ \c ->-  c { classHaskellConversion = ClassConversionToGc-    }---- | Replaces a class's 'classHaskellConversion' with a given value.-classSetHaskellConversion :: ClassHaskellConversion -> Class -> Class-classSetHaskellConversion conv = classModifyConversion $ \c ->-  c { classHaskellConversion = ClassConversionManual conv }---- | Controls how conversions between C++ objects and Haskell values happen in--- Haskell bindings.-data ClassHaskellConversion = ClassHaskellConversion-  { classHaskellConversionType :: Haskell.Generator HsType-    -- ^ Produces the Haskell type that represents a value of the corresponding-    -- C++ class.  This generator may add imports, but must not output code or-    -- add exports.-  , classHaskellConversionToCppFn :: Haskell.Generator ()-    -- ^ Produces a Haskell expression that evaluates to a function that takes-    -- an object of the type that 'classHaskellConversionType' generates, and-    -- returns a pointer to a new non-const C++ class object in IO.  The-    -- generator must output code and may add imports, but must not add exports.-  , classHaskellConversionFromCppFn :: Haskell.Generator ()-    -- ^ Produces a Haskell expression that evaluates to a function that takes a-    -- pointer to a const C++ class object, and returns an object of the type-    -- that 'classHaskellConversionType' generates, in IO.  The generator must-    -- output code and may add imports, but must not add exports.-  }---- | Things that live inside of a class, and have the class's external name--- prepended to their own in generated code.  With an external name of @\"bar\"@--- and a class with external name @\"foo\"@, the resulting name will be--- @\"foo_bar\"@.-class HasClassyExtName a where-  -- | Extracts the external name of the object, without the class name added.-  getClassyExtNameSuffix :: a -> ExtName--  -- | Computes the external name to use in generated code, containing both the-  -- class's and object's external names.-  ---  -- See also 'Foreign.Hoppy.Generator.Language.Haskell.General.toHsMethodName'.-  getClassyExtName :: Class -> a -> ExtName-  getClassyExtName cls x =-    toExtName $ concat [fromExtName $ classExtName cls, "_", fromExtName $ getClassyExtNameSuffix x]---- | A C++ class constructor declaration.-data Ctor = Ctor-  { ctorExtName :: ExtName-    -- ^ The constructor's external name.-  , ctorParams :: [Type]-    -- ^ The constructor's parameter types.-  }--instance Show Ctor where-  show ctor = concat ["<Ctor ", show (ctorExtName ctor), " ", show (ctorParams ctor), ">"]--instance HasClassyExtName Ctor where-  getClassyExtNameSuffix = ctorExtName---- | Creates a 'Ctor' with full generality.-makeCtor :: ExtName-         -> [Type]  -- ^ Parameter types.-         -> Ctor-makeCtor = Ctor---- | @mkCtor name@ creates a 'Ctor' whose external name is @className_name@.-mkCtor :: String-       -> [Type]  -- ^ Parameter types.-       -> Ctor-mkCtor = makeCtor . toExtName---- | A C++ class method declaration.------ Any operator function that can be written as a method may have its binding be--- written either as part of the associated class or as a separate entity,--- independently of how the function is declared in C++.-data Method = Method-  { methodImpl :: MethodImpl-    -- ^ The underlying code that the binding calls.-  , methodExtName :: ExtName-    -- ^ The method's external name.-  , methodApplicability :: MethodApplicability-    -- ^ How the method is associated to its class.-  , methodPurity :: Purity-    -- ^ Whether the method is pure.-  , methodParams :: [Type]-    -- ^ The method's parameter types.-  , methodReturn :: Type-    -- ^ The method's return 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---- | The C++ code to which a 'Method' is bound.-data MethodImpl =-  RealMethod (FnName String)-  -- ^ The 'Method' is bound to an actual class method.-  | FnMethod (FnName Identifier)-    -- ^ The 'Method' is bound to a wrapper function.  When wrapping a method-    -- with another function, this is preferrable to just using a 'Function'-    -- binding because a method will still appear to be part of the class in-    -- foreign bindings.-  deriving (Eq, Show)---- | How a method is associated to its class.  A method may be static, const, or--- neither (a regular method).-data MethodApplicability = MNormal | MStatic | MConst-                         deriving (Bounded, Enum, Eq, Show)---- | Whether or not a method is const.-data Constness = Nonconst | Const-               deriving (Bounded, Enum, Eq, Show)---- | Returns the opposite constness value.-constNegate :: Constness -> Constness-constNegate Nonconst = Const-constNegate Const = Nonconst---- | Whether or not a method is static.-data Staticness = Nonstatic | Static-               deriving (Bounded, Enum, Eq, Show)---- | Returns the constness of a method, based on its 'methodApplicability'.-methodConst :: Method -> Constness-methodConst method = case methodApplicability method of-  MConst -> Const-  _ -> Nonconst---- | Returns the staticness of a method, based on its 'methodApplicability'.-methodStatic :: Method -> Staticness-methodStatic method = case methodApplicability method of-  MStatic -> Static-  _ -> Nonstatic---- | Creates a 'Method' with full generality and manual name specification.-makeMethod :: IsFnName String name-           => name  -- ^ The C++ name of the method.-           -> ExtName  -- ^ The external name of the method.-           -> MethodApplicability-           -> Purity-           -> [Type]  -- ^ Parameter types.-           -> Type  -- ^ Return type.-           -> Method-makeMethod name = Method $ RealMethod $ toFnName name---- | Creates a 'Method' that is in fact backed by a C++ non-member function (a--- la 'makeFn'), but appears to be a regular method.  This is useful for--- wrapping a method on the C++ side when its arguments aren't right for binding--- directly.------ A @this@ pointer parameter is __not__ automatically added to the parameter--- list for non-static methods created with @makeFnMethod@.-makeFnMethod :: IsFnName Identifier name-             => name-             -> String-             -> MethodApplicability-             -> Purity-             -> [Type]-             -> Type-             -> Method-makeFnMethod cName foreignName = Method (FnMethod $ toFnName cName) (toExtName foreignName)---- | This function is internal.------ Creates a method similar to 'makeMethod', but with automatic naming.  The--- method's external name will be @className ++ \"_\" ++ cppMethodName@.  If the--- method name is a 'FnOp' then the 'operatorPreferredExtName' will be appeneded--- to the class name.------ For creating multiple bindings to a method, see 'makeMethod''.-makeMethod' :: IsFnName String name-            => name  -- ^ The C++ name of the method.-            -> MethodApplicability-            -> Purity-            -> [Type]  -- ^ Parameter types.-            -> Type  -- ^ Return type.-            -> Method-makeMethod' name = makeMethod''' (toFnName name) Nothing---- | This function is internal.------ Creates a method similar to 'makeMethod'', but with an custom string that--- will be appended to the class name to form the method's external name.  This--- is useful for making multiple bindings to a method, e.g. for overloading and--- optional arguments.-makeMethod'' :: IsFnName String name-             => name  -- ^ The C++ name of the method.-             -> String  -- ^ A foreign name for the method.-             -> MethodApplicability-             -> Purity-             -> [Type]  -- ^ Parameter types.-             -> Type  -- ^ Return type.-             -> Method-makeMethod'' name foreignName = makeMethod''' (toFnName name) $ Just foreignName---- | The implementation of 'makeMethod'' and 'makeMethod'''.-makeMethod''' :: FnName String  -- ^ The C++ name of the method.-              -> Maybe String  -- ^ A foreign name for the method.-              -> MethodApplicability-              -> Purity-              -> [Type]  -- ^ Parameter types.-              -> Type  -- ^ Return 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---- | Creates a nonconst, nonstatic 'Method' for @class::methodName@ and whose--- external name is @class_methodName@.  If the name is an operator, then the--- 'operatorPreferredExtName' will be used in the external name.------ For creating multiple bindings to a method, see 'mkMethod''.-mkMethod :: IsFnName String name-         => name  -- ^ The C++ name of the method.-         -> [Type]  -- ^ Parameter types.-         -> Type  -- ^ Return type.-         -> Method-mkMethod name = makeMethod' name MNormal Nonpure---- | Creates a nonconst, nonstatic 'Method' for method @class::methodName@ and--- whose external name is @class_methodName@.  This enables multiple 'Method's--- with different foreign names (and hence different external names) to bind to--- the same method, e.g. to make use of optional arguments or overloading.  See--- 'mkMethod' for a simpler form.-mkMethod' :: IsFnName String name-          => name  -- ^ The C++ name of the method.-          -> String  -- ^ A foreign name for the method.-          -> [Type]  -- ^ Parameter types.-          -> Type  -- ^ Return type.-          -> Method-mkMethod' cName foreignName = makeMethod'' cName foreignName MNormal Nonpure---- | Same as 'mkMethod', but returns an 'MConst' method.-mkConstMethod :: IsFnName String name => name -> [Type] -> Type -> Method-mkConstMethod name = makeMethod' name MConst Nonpure---- | Same as 'mkMethod'', but returns an 'MConst' method.-mkConstMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> Method-mkConstMethod' cName foreignName = makeMethod'' cName foreignName MConst Nonpure---- | Same as 'mkMethod', but returns an 'MStatic' method.-mkStaticMethod :: IsFnName String name => name -> [Type] -> Type -> Method-mkStaticMethod name = makeMethod' name MStatic Nonpure---- | Same as 'mkMethod'', but returns an 'MStatic' method.-mkStaticMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> Method-mkStaticMethod' cName foreignName = makeMethod'' cName foreignName MStatic Nonpure---- | Used in conjunction with 'mkProp' and friends, this creates a list of--- 'Method's for binding to getter/setter method pairs.  This can be used as--- follows:------ > myClass =--- >   makeClass ... $--- >   [ methods... ] ++--- >   mkProps--- >   [ mkBoolIsProp myClass "adjustable"--- >   , mkProp myClass "maxWidth" intT--- >   ]-mkProps :: [[Method]] -> [Method]-mkProps = concat---- | Creates a getter/setter binding pair for methods:------ > T getFoo() const--- > void setFoo(T)-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] Internal_TVoid-     ]---- | Creates a getter/setter binding pair for static methods:------ > static T getFoo() const--- > static void setFoo(T)-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] Internal_TVoid-     ]---- | Creates a getter/setter binding pair for boolean methods, where the getter--- is prefixed with @is@:------ > bool isFoo() const--- > void setFoo(bool)-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 [] Internal_TBool-     , mkMethod setName [Internal_TBool] Internal_TVoid-     ]---- | Creates a getter/setter binding pair for boolean methods, where the getter--- is prefixed with @has@:------ > bool hasFoo() const--- > void setFoo(bool)-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 [] Internal_TBool-     , mkMethod setName [Internal_TBool] Internal_TVoid-     ]---- | A non-C++ function that can be invoked via a C++ functor.-data Callback = Callback-  { callbackExtName :: ExtName-    -- ^ The callback's external name.-  , callbackParams :: [Type]-    -- ^ The callback's parameter types.-  , callbackReturn :: Type-    -- ^ The callback's return type.-  , callbackReqs :: Reqs-    -- ^ Requirements for the callback.-  , callbackAddendum :: Addendum-    -- ^ The callback's 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 }---- | Creates a binding for constructing callbacks into foreign code.-makeCallback :: ExtName-             -> [Type]  -- ^ Parameter types.-             -> Type  -- ^ Return type.-             -> Callback-makeCallback extName paramTypes retType = Callback extName paramTypes retType mempty mempty---- | Creates a 'Foreign.Hoppy.Generator.Types.fnT' from a callback's parameter--- and return types.-callbackToTFn :: Callback -> Type-callbackToTFn = Internal_TFn <$> callbackParams <*> callbackReturn---- | 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).-data Addendum = Addendum-  { addendumHaskell :: Haskell.Generator ()-    -- ^ Code to be output into the Haskell binding.  May also add imports and-    -- exports.-  }--instance Monoid Addendum where-  mempty = Addendum $ return ()-  mappend (Addendum a) (Addendum b) = Addendum $ a >> b---- | A typeclass for types that have an addendum.-class HasAddendum a where-  {-# MINIMAL getAddendum, (setAddendum | modifyAddendum) #-}--  -- | Returns an object's addendum.-  getAddendum :: a -> Addendum--  -- | Replaces and object's addendum with another.-  setAddendum :: Addendum -> a -> a-  setAddendum addendum = modifyAddendum $ const addendum--  -- | Modified an object's addendum.-  modifyAddendum :: (Addendum -> Addendum) -> a -> a-  modifyAddendum f x = setAddendum (f $ getAddendum x) x---- | Adds a Haskell addendum to an object.-addAddendumHaskell :: HasAddendum a => Haskell.Generator () -> a -> a-addAddendumHaskell gen = modifyAddendum $ \addendum ->-  addendum `mappend` mempty { addendumHaskell = gen }---- | Constructor for an import set.-makeHsImportSet :: M.Map HsImportKey HsImportSpecs -> HsImportSet-makeHsImportSet = HsImportSet---- | Sets all of the import specifications in an import set to be--- @{-#SOURCE#-}@ imports.-hsImportSetMakeSource :: HsImportSet -> HsImportSet-hsImportSetMakeSource (HsImportSet m) =-  HsImportSet $ M.map (\specs -> specs { hsImportSource = True }) m---- | A Haskell module name.-type HsModuleName = String---- | References an occurrence of an import statement, under which bindings can--- be imported.  Only imported specs under equal 'HsImportKey's may be merged.-data HsImportKey = HsImportKey-  { hsImportModule :: HsModuleName-  , hsImportQualifiedName :: Maybe HsModuleName-  } deriving (Eq, Ord, Show)---- | A specification of bindings to import from a module.  If 'Nothing', then--- the entire module is imported.  If @'Just' 'M.empty'@, then only instances--- are imported.-data HsImportSpecs = HsImportSpecs-  { getHsImportSpecs :: Maybe (M.Map HsImportName HsImportVal)-  , hsImportSource :: Bool-  } deriving (Show)---- | Combines two 'HsImportSpecs's into one that imports everything that the two--- did separately.-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---- | An identifier that can be imported from a module.  Symbols may be used here--- when surrounded by parentheses.  Examples are @\"fmap\"@ and @\"(++)\"@.-type HsImportName = String---- | Specifies how a name is imported.-data HsImportVal =-  HsImportVal-  -- ^ The name is imported, and nothing underneath it is.-  | HsImportValSome [HsImportName]-    -- ^ The name is imported, as are specific names underneath it.  This is a-    -- @X (a, b, c)@ import.-  | HsImportValAll-    -- ^ The name is imported, along with all names underneath it.  This is a @X-    -- (..)@ import.-  deriving (Show)---- | An import for the entire contents of a Haskell module.-hsWholeModuleImport :: HsModuleName -> HsImportSet-hsWholeModuleImport moduleName =-  HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $-  HsImportSpecs Nothing False---- | A qualified import of a Haskell module.-hsQualifiedImport :: HsModuleName -> HsModuleName -> HsImportSet-hsQualifiedImport moduleName qualifiedName =-  HsImportSet $ M.singleton (HsImportKey moduleName $ Just qualifiedName) $-  HsImportSpecs Nothing False---- | An import of a single name from a Haskell module.-hsImport1 :: HsModuleName -> HsImportName -> HsImportSet-hsImport1 moduleName valueName = hsImport1' moduleName valueName HsImportVal---- | A detailed import of a single name from a Haskell module.-hsImport1' :: HsModuleName -> HsImportName -> HsImportVal -> HsImportSet-hsImport1' moduleName valueName valueType =-  HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $-  HsImportSpecs (Just $ M.singleton valueName valueType) False---- | An import of multiple names from a Haskell module.-hsImports :: HsModuleName -> [HsImportName] -> HsImportSet-hsImports moduleName names =-  hsImports' moduleName $ map (\name -> (name, HsImportVal)) names---- | A detailed import of multiple names from a Haskell module.-hsImports' :: HsModuleName -> [(HsImportName, HsImportVal)] -> HsImportSet-hsImports' moduleName values =-  HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $-  HsImportSpecs (Just $ M.fromList values) False---- | Imports "Data.Bits" qualified as @HoppyDB@.-hsImportForBits :: HsImportSet-hsImportForBits = hsQualifiedImport "Data.Bits" "HoppyDB"---- | Imports "Data.Int" qualified as @HoppyDI@.-hsImportForInt :: HsImportSet-hsImportForInt = hsQualifiedImport "Data.Int" "HoppyDI"---- | Imports "Data.Word" qualified as @HoppyDW@.-hsImportForWord :: HsImportSet-hsImportForWord = hsQualifiedImport "Data.Word" "HoppyDW"---- | Imports "Foreign" qualified as @HoppyF@.-hsImportForForeign :: HsImportSet-hsImportForForeign = hsQualifiedImport "Foreign" "HoppyF"---- | Imports "Foreign.C" qualified as @HoppyFC@.-hsImportForForeignC :: HsImportSet-hsImportForForeignC = hsQualifiedImport "Foreign.C" "HoppyFC"---- | Imports "Prelude" qualified as @HoppyP@.-hsImportForPrelude :: HsImportSet-hsImportForPrelude = hsQualifiedImport "Prelude" "HoppyP"---- | Imports "Foreign.Hoppy.Runtime" qualified as @HoppyFHR@.-hsImportForRuntime :: HsImportSet-hsImportForRuntime = hsQualifiedImport "Foreign.Hoppy.Runtime" "HoppyFHR"---- | Imports "System.Posix.Types" qualified as @HoppySPT@.-hsImportForSystemPosixTypes :: HsImportSet-hsImportForSystemPosixTypes = hsQualifiedImport "System.Posix.Types" "HoppySPT"---- | Imports "System.IO.Unsafe" qualified as @HoppySIU@.-hsImportForUnsafeIO :: HsImportSet-hsImportForUnsafeIO = hsQualifiedImport "System.IO.Unsafe" "HoppySIU"---- | Returns an error message indicating that--- 'Foreign.Hoppy.Generator.Types.objToHeapT' is used where data is going from a--- foreign language into C++.-objToHeapTWrongDirectionErrorMsg :: Maybe String -> Class -> String-objToHeapTWrongDirectionErrorMsg maybeCaller cls =-  concat [maybe "" (++ ": ") maybeCaller,-          "(TObjToHeap ", show cls, ") cannot be passed into C++",-          maybe "" (const ".") maybeCaller]---- | Returns an error message indicating that--- 'Foreign.Hoppy.Generator.Types.objToHeapT' is used where data is going from a--- foreign language into C++.-tToGcInvalidFormErrorMessage :: Maybe String -> Type -> String-tToGcInvalidFormErrorMessage maybeCaller typeArg =-  concat [maybe "" (++ ": ") maybeCaller,-          "(", show (Internal_TToGc typeArg), ") is an invalid form for TToGc.",-          maybe "" (const ".") maybeCaller]---- | Returns an error message indicating that--- 'Foreign.Hoppy.Generator.Types.toGcT' is used where data is going from a--- foreign language into C++.-toGcTWrongDirectionErrorMsg :: Maybe String -> Type -> String-toGcTWrongDirectionErrorMsg maybeCaller typeArg =-  concat [maybe "" (++ ": ") maybeCaller,-          "(", show (Internal_TToGc typeArg), ") cannot be passed into C++",-          maybe "" (const ".") maybeCaller]+-- Copyright 2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++-- | The primary data types for specifying C++ interfaces.+--+-- 'Show' instances in this module produce strings of the form @\"\<TypeOfObject+-- nameOfObject otherInfo...\>\"@.  They can be used in error messages without+-- specifying a noun separately, i.e. write @show cls@ instead of @\"the class+-- \" ++ show cls@.+module Foreign.Hoppy.Generator.Spec (+  module Foreign.Hoppy.Generator.Spec.Base,+  module Foreign.Hoppy.Generator.Spec.Conversion,+  module Foreign.Hoppy.Generator.Spec.ClassFeature,+  ) where++import Foreign.Hoppy.Generator.Spec.Base+import Foreign.Hoppy.Generator.Spec.ClassFeature+import Foreign.Hoppy.Generator.Spec.Conversion

@@ -0,0 +1,2484 @@+-- This file is part of Hoppy.+--+-- Copyright 2015-2016 Bryan Gardiner <bog@khumba.net>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}++module Foreign.Hoppy.Generator.Spec.Base (+  -- * Interfaces+  Interface,+  ErrorMsg,+  InterfaceOptions (..),+  defaultInterfaceOptions,+  interface,+  interface',+  interfaceName,+  interfaceModules,+  interfaceNamesToModules,+  interfaceHaskellModuleBase,+  interfaceDefaultHaskellModuleBase,+  interfaceAddHaskellModuleBase,+  interfaceHaskellModuleImportNames,+  interfaceExceptionHandlers,+  interfaceCallbacksThrow,+  interfaceSetCallbacksThrow,+  interfaceExceptionClassId,+  interfaceExceptionSupportModule,+  interfaceSetExceptionSupportModule,+  -- * C++ includes+  Include,+  includeStd,+  includeLocal,+  includeToString,+  -- * Modules+  Module,+  moduleName,+  moduleHppPath,+  moduleCppPath,+  moduleExports,+  moduleReqs,+  moduleExceptionHandlers,+  moduleCallbacksThrow,+  moduleSetCallbacksThrow,+  moduleAddendum,+  moduleHaskellName,+  makeModule,+  moduleModify,+  moduleModify',+  moduleSetHppPath,+  moduleSetCppPath,+  moduleAddExports,+  moduleAddHaskellName,+  -- * Requirements+  Reqs,+  reqsIncludes,+  reqInclude,+  HasReqs (..),+  addReqs,+  addReqIncludes,+  -- * Names and exports+  ExtName,+  toExtName,+  isValidExtName,+  fromExtName,+  HasExtNames (..),+  getAllExtNames,+  FnName (..),+  IsFnName (..),+  Operator (..),+  OperatorType (..),+  operatorPreferredExtName,+  operatorPreferredExtName',+  operatorType,+  Export (..),+  exportAddendum,+  Identifier,+  identifierParts,+  IdPart,+  idPartBase,+  idPartArgs,+  ident, ident', ident1, ident2, ident3, ident4, ident5,+  identT, identT', ident1T, ident2T, ident3T, ident4T, ident5T,+  -- * Basic types+  Type (..),+  normalizeType,+  stripConst,+  -- ** Variables+  Variable, makeVariable, varIdentifier, varExtName, varType, varReqs,+  varIsConst, varGetterExtName, varSetterExtName,+  -- ** Enums+  CppEnum, makeEnum, enumIdentifier, enumExtName, enumValueNames, enumReqs,+  enumValuePrefix, enumSetValuePrefix,+  -- ** Bitspaces+  Bitspace, makeBitspace, bitspaceExtName, bitspaceType, bitspaceValueNames, bitspaceEnum,+  bitspaceAddEnum, bitspaceCppTypeIdentifier, bitspaceFromCppValueFn, bitspaceToCppValueFn,+  bitspaceAddCppType, bitspaceReqs,+  bitspaceValuePrefix, bitspaceSetValuePrefix,+  -- ** Functions+  Purity (..),+  Function, makeFn, fnCName, fnExtName, fnPurity, fnParams, fnReturn, fnReqs, fnExceptionHandlers,+  -- ** Classes+  Class, makeClass, classIdentifier, classExtName, classSuperclasses,+  classEntities, classAddEntities, classVariables, classCtors, classMethods,+  classDtorIsPublic, classSetDtorPrivate,+  classConversion, classReqs, classEntityPrefix, classSetEntityPrefix,+  classIsMonomorphicSuperclass, classSetMonomorphicSuperclass,+  classIsSubclassOfMonomorphic, classSetSubclassOfMonomorphic,+  classIsException, classMakeException,+  ClassEntity (..),+  IsClassEntity (..), classEntityExtName, classEntityForeignName, classEntityForeignName',+  ClassVariable,+  makeClassVariable, makeClassVariable_,+  mkClassVariable, mkClassVariable_,+  mkStaticClassVariable, mkStaticClassVariable_,+  classVarCName, classVarExtName, classVarType, classVarStatic, classVarGettable,+  classVarGetterExtName, classVarGetterForeignName,+  classVarSetterExtName, classVarSetterForeignName,+  Ctor, makeCtor, makeCtor_, mkCtor, mkCtor_, ctorExtName, ctorParams, ctorExceptionHandlers,+  Method,+  MethodImpl (..),+  MethodApplicability (..),+  Constness (..),+  constNegate,+  Staticness (..),+  makeMethod, makeMethod_,+  makeFnMethod, makeFnMethod_,+  mkMethod, mkMethod_, mkMethod', mkMethod'_,+  mkConstMethod, mkConstMethod_, mkConstMethod', mkConstMethod'_,+  mkStaticMethod, mkStaticMethod_, mkStaticMethod', mkStaticMethod'_,+  Prop,  -- The data constructor is private.+  mkProp, mkProp_,+  mkStaticProp, mkStaticProp_,+  mkBoolIsProp, mkBoolIsProp_,+  mkBoolHasProp, mkBoolHasProp_,+  methodImpl, methodExtName, methodApplicability, methodPurity, methodParams,+  methodReturn, methodExceptionHandlers, methodConst, methodStatic,+  -- *** Conversion to and from foreign values+  ClassConversion (..),+  classConversionNone,+  classModifyConversion,+  classSetConversion,+  ClassHaskellConversion (..),+  classHaskellConversionNone,+  classSetHaskellConversion,+  -- ** Callbacks+  Callback, makeCallback,+  callbackExtName, callbackParams, callbackReturn, callbackThrows, callbackReqs,+  callbackSetThrows,+  -- * Exceptions+  ExceptionId (..),+  exceptionCatchAllId,+  ExceptionHandler (..),+  ExceptionHandlers (..),+  HandlesExceptions (getExceptionHandlers),+  handleExceptions,+  -- * Addenda+  Addendum (..),+  HasAddendum (..),+  addAddendumHaskell,+  -- * Haskell imports+  HsModuleName, HsImportSet, HsImportKey (..), HsImportSpecs (..), HsImportName, HsImportVal (..),+  hsWholeModuleImport, hsQualifiedImport, hsImport1, hsImport1', hsImports, hsImports',+  hsImportSetMakeSource,+  -- * Internal to Hoppy+  interfaceAllExceptionClasses,+  classFindCopyCtor,+  -- ** Haskell imports+  makeHsImportSet,+  getHsImportSet,+  hsImportForBits,+  hsImportForException,+  hsImportForInt,+  hsImportForWord,+  hsImportForForeign,+  hsImportForForeignC,+  hsImportForMap,+  hsImportForPrelude,+  hsImportForRuntime,+  hsImportForSystemPosixTypes,+  hsImportForTypeable,+  hsImportForUnsafeIO,+  -- ** Error messages+  objToHeapTWrongDirectionErrorMsg,+  tToGcInvalidFormErrorMessage,+  toGcTWrongDirectionErrorMsg,+  ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Arrow ((&&&))+import Control.Monad (liftM2, unless)+#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except (MonadError, throwError)+#else+import Control.Monad.Error (MonadError, throwError)+#endif+import Control.Monad.State (MonadState, StateT, execStateT, get, modify)+import Data.Char (isAlpha, isAlphaNum, toUpper)+import Data.Function (on)+import Data.List (intercalate, intersperse)+import qualified Data.Map as M+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid, mappend, mconcat, mempty)+#endif+import qualified Data.Set as S+import Foreign.Hoppy.Generator.Common+import {-# SOURCE #-} qualified Foreign.Hoppy.Generator.Language.Haskell as Haskell+import Language.Haskell.Syntax (HsType)++-- | Indicates strings that are error messages.+type ErrorMsg = String++-- | A complete specification of a C++ API.  Generators for different languages,+-- including the binding generator for C++, use these to produce their output.+--+-- 'Interface' does not have a 'HandlesExceptions' instance because+-- 'modifyExceptionHandlers' does not work for it (handled exceptions cannot be+-- modified after an 'Interface' is constructed).+data Interface = Interface+  { interfaceName :: String+    -- ^ The textual name of the interface.+  , interfaceModules :: M.Map String Module+    -- ^ All of the individual modules, by 'moduleName'.+  , interfaceNamesToModules :: M.Map ExtName Module+    -- ^ Maps each 'ExtName' exported by some module to the module that exports+    -- the name.+  , interfaceHaskellModuleBase' :: Maybe [String]+    -- ^ See 'interfaceHaskellModuleBase'.+  , interfaceHaskellModuleImportNames :: M.Map Module String+    -- ^ Short qualified module import names that generated modules use to refer+    -- to each other tersely.+  , interfaceExceptionHandlers :: ExceptionHandlers+    -- ^ Exceptions that all functions in the interface may throw.+  , interfaceCallbacksThrow :: Bool+    -- ^ Whether callbacks within the interface support throwing C++ exceptions+    -- from Haskell into C++ during their execution.  This may be overridden by+    -- 'moduleCallbacksThrow' and 'callbackThrows'.+  , interfaceExceptionNamesToIds :: M.Map ExtName ExceptionId+    -- ^ Maps from external names of exception classes to their exception IDs.+  , interfaceExceptionSupportModule :: Maybe Module+    -- ^ 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.+  }++instance Show Interface where+  show iface = concat ["<Interface ", show (interfaceName iface), ">"]++-- | Optional parameters when constructing an 'Interface' with 'interface'.+data InterfaceOptions = InterfaceOptions+  { interfaceOptionsExceptionHandlers :: ExceptionHandlers+  }++-- | Options used by 'interface'.  This contains no exception handlers.+defaultInterfaceOptions :: InterfaceOptions+defaultInterfaceOptions = InterfaceOptions mempty++-- | Constructs an 'Interface' from the required parts.  Some validation is+-- performed; if the resulting interface would be invalid, an error message is+-- returned instead.+--+-- This function passes 'defaultInterfaceOptions' to 'interface''.+interface :: String  -- ^ 'interfaceName'+          -> [Module]  -- ^ 'interfaceModules'+          -> Either ErrorMsg Interface+interface ifName modules = interface' ifName modules defaultInterfaceOptions++-- | Same as 'interface', but accepts some optional arguments.+interface' :: String  -- ^ 'interfaceName'+           -> [Module]  -- ^ 'interfaceModules'+           -> InterfaceOptions+           -> Either ErrorMsg Interface+interface' ifName modules options = do+  -- TODO Check for duplicate module names.+  -- TODO Check for duplicate module file paths.++  -- Check for multiple modules exporting an ExtName.+  let extNamesToModules :: M.Map ExtName [Module]+      extNamesToModules =+        M.unionsWith (++) $+        for modules $ \mod ->+        let extNames = concatMap getAllExtNames $ M.elems $ moduleExports mod+        in M.fromList $ zip extNames $ repeat [mod]++      extNamesInMultipleModules :: [(ExtName, [Module])]+      extNamesInMultipleModules =+        M.toList $+        M.filter (\modules -> case modules of+                     _:_:_ -> True+                     _ -> False)+        extNamesToModules++  unless (null extNamesInMultipleModules) $+    Left $ unlines $+    "Some external name(s) are exported by multiple modules:" :+    map (\(extName, modules) ->+          concat $ "- " : show extName : ": " : intersperse ", " (map show modules))+        extNamesInMultipleModules++  let haskellModuleImportNames =+        M.fromList $+        (\a b f -> zipWith f a b) modules [1..] $+        \mod index -> (mod, 'M' : show index)++  -- Generate a unique exception ID integer for each exception class.  IDs 0 and+  -- 1 are reserved.+  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+    }++-- | The name of the parent Haskell module under which a Haskell module will be+-- generated for a Hoppy 'Module'.  This is a list of Haskell module path+-- components, in other words, @'Data.List.intercalate' "."@ on the list+-- produces a Haskell module name.  Defaults to+-- 'interfaceDefaultHaskellModuleBase', and may be overridden with+-- 'interfaceAddHaskellModuleBase'.+interfaceHaskellModuleBase :: Interface -> [String]+interfaceHaskellModuleBase =+  fromMaybe interfaceDefaultHaskellModuleBase . interfaceHaskellModuleBase'++-- | The default Haskell module under which Hoppy modules will be generated.+-- This is @Foreign.Hoppy.Generated@, that is:+--+-- > ["Foreign", "Hoppy", "Generated"]+interfaceDefaultHaskellModuleBase :: [String]+interfaceDefaultHaskellModuleBase = ["Foreign", "Hoppy", "Generated"]++-- | Sets an interface to generate all of its modules under the given Haskell+-- module prefix.  See 'interfaceHaskellModuleBase'.+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+    ]++-- | Returns the the exception ID for a class in an interface, if it has one+-- (i.e. if it's been marked as an exception class with 'classMakeException').+interfaceExceptionClassId :: Interface -> Class -> Maybe ExceptionId+interfaceExceptionClassId iface cls =+  M.lookup (classExtName cls) $ interfaceExceptionNamesToIds iface++-- | Returns all of the exception classes in an interface.+interfaceAllExceptionClasses :: Interface -> [Class]+interfaceAllExceptionClasses = interfaceAllExceptionClasses' . M.elems . interfaceModules++interfaceAllExceptionClasses' :: [Module] -> [Class]+interfaceAllExceptionClasses' modules =+  flip concatMap modules $ \mod ->+  catMaybes $+  for (M.elems $ moduleExports mod) $ \export -> case export of+    ExportClass cls | classIsException cls -> Just cls+    _ -> Nothing++-- | Changes 'callbackThrows' for all callbacks in an interface that don't have it+-- set explicitly at the module or callback level.+interfaceSetCallbacksThrow :: Bool -> Interface -> Interface+interfaceSetCallbacksThrow b iface = iface { interfaceCallbacksThrow = b }++-- | Sets an interface's exception support module, for interfaces that use+-- exceptions.+interfaceSetExceptionSupportModule :: Module -> Interface -> Interface+interfaceSetExceptionSupportModule mod iface = case interfaceExceptionSupportModule iface of+  Nothing -> iface { interfaceExceptionSupportModule = Just mod }+  Just existingMod ->+    if mod == existingMod+    then iface+    else error $ "interfaceSetExceptionSupportModule: " ++ show iface +++         " already has exception support module " ++ show existingMod +++         ", trying to set " ++ show mod ++ "."++-- | An @#include@ directive in a C++ file.+data Include = Include+  { includeToString :: String+    -- ^ Returns the complete @#include ...@ line for an include, including+    -- trailing newline.+  } deriving (Eq, Ord, Show)++-- | Creates an @#include \<...\>@ directive.+includeStd :: String -> Include+includeStd path = Include $ "#include <" ++ path ++ ">\n"++-- | Creates an @#include "..."@ directive.+includeLocal :: String -> Include+includeLocal path = Include $ "#include \"" ++ path ++ "\"\n"++-- | A portion of functionality in a C++ API.  An 'Interface' is composed of+-- multiple modules.  A module will generate a single compilation unit+-- containing bindings for all of the module's exports.  The C++ code for a+-- 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.+data Module = Module+  { moduleName :: String+    -- ^ The module's name.  A module name must identify a unique module within+    -- an 'Interface'.+  , moduleHppPath :: String+    -- ^ A relative path under a C++ sources root to which the generator will+    -- write a header file for the module's C++ bindings.+  , moduleCppPath :: String+    -- ^ A relative path under a C++ sources root to which the generator will+    -- write a source file for the module's C++ bindings.+  , moduleExports :: M.Map ExtName Export+    -- ^ All of the exports in a module.+  , moduleReqs :: Reqs+    -- ^ Module-level requirements.+  , moduleHaskellName :: Maybe [String]+    -- ^ The generated Haskell module name, underneath the+    -- 'interfaceHaskellModuleBase'.  If absent (by default), the 'moduleName'+    -- is used.  May be modified with 'moduleAddHaskellName'.+  , moduleExceptionHandlers :: ExceptionHandlers+    -- ^ Exceptions that all functions in the module may throw.+  , moduleCallbacksThrow :: Maybe Bool+    -- ^ Whether callbacks exported from the module support exceptions being+    -- thrown during their execution.  When present, this overrides+    -- 'interfaceCallbacksThrow'.  This maybe overridden by 'callbackThrows'.+  , moduleAddendum :: Addendum+    -- ^ The module's addendum.+  }++instance Eq Module where+  (==) = (==) `on` moduleName++instance Ord Module where+  compare = compare `on` moduleName++instance Show Module where+  show m = concat ["<Module ", moduleName m, ">"]++instance HasReqs Module where+  getReqs = moduleReqs+  setReqs reqs m = m { moduleReqs = reqs }++instance HasAddendum Module where+  getAddendum = moduleAddendum+  setAddendum addendum m = m { moduleAddendum = addendum }++instance HandlesExceptions Module where+  getExceptionHandlers = moduleExceptionHandlers+  modifyExceptionHandlers f m = m { moduleExceptionHandlers = f $ moduleExceptionHandlers m }++-- | Creates an empty module, ready to be configured with 'moduleModify'.+makeModule :: String  -- ^ 'moduleName'+           -> String  -- ^ 'moduleHppPath'+           -> String  -- ^ 'moduleCppPath'+           -> 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+  }++-- | Extends a module.  To be used with the module state-monad actions in this+-- package.+moduleModify :: Module -> StateT Module (Either String) () -> Either ErrorMsg Module+moduleModify = flip execStateT++-- | Same as 'moduleModify', but calls 'error' in the case of failure, which is+-- okay in for a generator which would abort in this case anyway.+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'++-- | Replaces a module's 'moduleHppPath'.+moduleSetHppPath :: MonadState Module m => String -> m ()+moduleSetHppPath path = modify $ \m -> m { moduleHppPath = path }++-- | Replaces a module's 'moduleCppPath'.+moduleSetCppPath :: MonadState Module m => String -> m ()+moduleSetCppPath path = modify $ \m -> m { moduleCppPath = path }++-- | Adds exports to a module.  An export must only be added to any module at+-- most once, and must not be added to multiple modules.+moduleAddExports :: (MonadError String m, MonadState Module m) => [Export] -> m ()+moduleAddExports exports = do+  m <- get+  let existingExports = moduleExports m+      newExports = M.fromList $ map (getPrimaryExtName &&& id) exports+      duplicateNames = (S.intersection `on` M.keysSet) existingExports newExports+  if S.null duplicateNames+    then modify $ \m -> m { moduleExports = existingExports `mappend` newExports }+    else throwError $ concat+         ["moduleAddExports: ", show m, " defines external names multiple times: ",+          show duplicateNames]++-- | Changes a module's 'moduleHaskellName' from the default.  This can only be+-- called once on a module.+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, "."]++-- | Changes 'callbackThrows' for all callbacks in a module that don't have it+-- set explicitly.+moduleSetCallbacksThrow :: MonadState Module m => Maybe Bool -> m ()+moduleSetCallbacksThrow b = modify $ \m -> m { moduleCallbacksThrow = b }++-- | A set of requirements of needed to use an identifier in C++ (function,+-- type, etc.), via a set of 'Include's.  The monoid instance has 'mempty' as an+-- empty set of includes, and 'mappend' unions two include sets.+data Reqs = Reqs+  { reqsIncludes :: S.Set Include+    -- ^ The includes specified by a 'Reqs'.+  } 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++-- | Creates a 'Reqs' that contains the given include.+reqInclude :: Include -> Reqs+reqInclude include = mempty { reqsIncludes = S.singleton include }++-- | C++ types that have requirements in order to use them in generated+-- bindings.+class HasReqs a where+  {-# MINIMAL getReqs, (setReqs | modifyReqs) #-}++  -- | Returns an object's requirements.+  getReqs :: a -> Reqs++  -- | Replaces an object's requirements with new ones.+  setReqs :: Reqs -> a -> a+  setReqs = modifyReqs . const++  -- | Modifies an object's requirements.+  modifyReqs :: (Reqs -> Reqs) -> a -> a+  modifyReqs f x = setReqs (f $ getReqs x) x++-- | Adds to a object's requirements.+addReqs :: HasReqs a => Reqs -> a -> a+addReqs reqs = modifyReqs $ mappend reqs++-- | Adds a list of includes to the requirements of an object.+addReqIncludes :: HasReqs a => [Include] -> a -> a+addReqIncludes includes =+  modifyReqs $ mappend mempty { reqsIncludes = S.fromList includes }++-- | An external name is a string that generated bindings use to uniquely+-- identify an object at runtime.  An external name must start with an+-- alphabetic character, and may only contain alphanumeric characters and @'_'@.+-- You are free to use whatever naming style you like; case conversions will be+-- performed automatically when required.  Hoppy does make use of some+-- conventions though, for example with 'Operator's and in the provided bindings+-- for the C++ standard library.+--+-- External names must be unique within an interface.  They may not be reused+-- between modules.  This assumption is used for symbol naming in compiled+-- shared objects and to freely import modules in Haskell bindings.+newtype ExtName = ExtName+  { fromExtName :: String+    -- ^ Returns the string an an 'ExtName' contains.+  } deriving (Eq, Monoid, Ord)++instance Show ExtName where+  show extName = concat ["$\"", fromExtName extName, "\"$"]++-- | Creates an 'ExtName' that contains the given string, erroring if the string+-- is an invalid 'ExtName'.+toExtName :: String -> ExtName+toExtName str = case str of+  -- Keep this logic in sync with isValidExtName.+  [] -> 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++-- | Returns true if the given string is represents a valid 'ExtName'.+isValidExtName :: String -> Bool+isValidExtName str = case str of+  -- Keep this logic in sync with toExtName.+  [] -> False+  c:cs -> isAlpha c && all ((||) <$> isAlphaNum <*> (== '_')) cs++-- | Generates an 'ExtName' from an 'Identifier', if the given name is absent.+extNameOrIdentifier :: Identifier -> Maybe ExtName -> ExtName+extNameOrIdentifier ident = fromMaybe $ case identifierParts ident of+  [] -> error "extNameOrIdentifier: Invalid empty identifier."+  parts -> toExtName $ idPartBase $ last parts++-- | Generates an 'ExtName' from an @'FnName' 'Identifier'@, if the given name+-- is absent.+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++-- | Generates an 'ExtName' from a string, if the given name is absent.+extNameOrString :: String -> Maybe ExtName -> ExtName+extNameOrString str = fromMaybe $ toExtName str++-- | Types that have an external name, and also optionally have nested entities+-- with external names as well.  See 'getAllExtNames'.+class HasExtNames a where+  -- | Returns the external name by which a given entity is referenced.+  getPrimaryExtName :: a -> ExtName++  -- | Returns external names nested within the given entity.  Does not include+  -- the primary external name.+  getNestedExtNames :: a -> [ExtName]+  getNestedExtNames _ = []++-- | Returns a list of all of the external names an entity contains.  This+-- combines both 'getPrimaryExtName' and 'getNestedExtNames'.+getAllExtNames :: HasExtNames a => a -> [ExtName]+getAllExtNames x = getPrimaryExtName x : getNestedExtNames x++-- | The C++ name of a function or method.+data FnName name =+  FnName name+  -- ^ A regular, \"alphanumeric\" name.  The exact type depends on what kind of+  -- object is being named.+  | FnOp Operator+    -- ^ An operator name.+  deriving (Eq, Ord)++instance Show name => Show (FnName name) where+  show (FnName name) = concat ["<FnName ", show name, ">"]+  show (FnOp op) = concat ["<FnOp ", show op, ">"]++-- | Enables implementing automatic conversions to a @'FnName' t@.+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++-- | Overloadable C++ operators.+data Operator =+  OpCall  -- ^ @x(...)@+  | OpComma -- ^ @x, y@+  | OpAssign  -- ^ @x = y@+  | OpArray  -- ^ @x[y]@+  | OpDeref  -- ^ @*x@+  | OpAddress  -- ^ @&x@+  | OpAdd  -- ^ @x + y@+  | OpAddAssign  -- ^ @x += y@+  | OpSubtract  -- ^ @x - y@+  | OpSubtractAssign  -- ^ @x -= y@+  | OpMultiply  -- ^ @x * y@+  | OpMultiplyAssign  -- ^ @x *= y@+  | OpDivide  -- ^ @x / y@+  | OpDivideAssign  -- ^ @x /= y@+  | OpModulo  -- ^ @x % y@+  | OpModuloAssign  -- ^ @x %= y@+  | OpPlus  -- ^ @+x@+  | OpMinus  -- ^ @-x@+  | OpIncPre  -- ^ @++x@+  | OpIncPost  -- ^ @x++@+  | OpDecPre  -- ^ @--x@+  | OpDecPost  -- ^ @x--@+  | OpEq  -- ^ @x == y@+  | OpNe  -- ^ @x != y@+  | OpLt  -- ^ @x < y@+  | OpLe  -- ^ @x <= y@+  | OpGt  -- ^ @x > y@+  | OpGe  -- ^ @x >= y@+  | OpNot  -- ^ @!x@+  | OpAnd  -- ^ @x && y@+  | OpOr  -- ^ @x || y@+  | OpBitNot  -- ^ @~x@+  | OpBitAnd  -- ^ @x & y@+  | OpBitAndAssign  -- ^ @x &= y@+  | OpBitOr  -- ^ @x | y@+  | OpBitOrAssign  -- ^ @x |= y@+  | OpBitXor  -- ^ @x ^ y@+  | OpBitXorAssign  -- ^ @x ^= y@+  | OpShl  -- ^ @x << y@+  | OpShlAssign  -- ^ @x <<= y@+  | OpShr  -- ^ @x >> y@+  | OpShrAssign  -- ^ @x >>= y@+  deriving (Bounded, Enum, Eq, Ord, Show)++-- | The arity and syntax of an operator.+data OperatorType =+  UnaryPrefixOperator String  -- ^ Prefix unary operators.  Examples: @!x@, @*x@, @++x@.+  | UnaryPostfixOperator String  -- ^ Postfix unary operators.  Examples: @x--, x++@.+  | BinaryOperator String  -- ^ Infix binary operators.  Examples: @x * y@, @x >>= y@.+  | CallOperator  -- ^ @x(...)@ with arbitrary arity.+  | ArrayOperator  -- ^ @x[y]@, a binary operator with non-infix syntax.++data OperatorInfo = OperatorInfo+  { operatorPreferredExtName'' :: ExtName+  , operatorType' :: OperatorType+  }++makeOperatorInfo :: String -> OperatorType -> OperatorInfo+makeOperatorInfo = OperatorInfo . toExtName++-- | Returns a conventional string to use for the 'ExtName' of an operator.+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, "."]++-- | Returns a conventional name for an operator, as with+-- 'operatorPreferredExtName', but as a string.+operatorPreferredExtName' :: Operator -> String+operatorPreferredExtName' = fromExtName . operatorPreferredExtName++-- | Returns the type of an operator.+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, "."]++-- | Metadata for operators.+--+-- TODO Test out this missing data.+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."++-- | Specifies some C++ object (function or class) to give access to.+data Export =+  ExportVariable Variable  -- ^ Exports a variable.+  | ExportEnum CppEnum  -- ^ Exports an enum.+  | ExportBitspace Bitspace  -- ^ Exports a bitspace.+  | ExportFn Function  -- ^ Exports a function.+  | ExportClass Class  -- ^ Exports a class with all of its contents.+  | ExportCallback Callback  -- ^ Exports a callback.+  deriving (Show)++instance HasExtNames Export where+  getPrimaryExtName x = case x of+    ExportVariable v -> getPrimaryExtName v+    ExportEnum e -> getPrimaryExtName e+    ExportBitspace b -> getPrimaryExtName b+    ExportFn f -> getPrimaryExtName f+    ExportClass cls -> getPrimaryExtName cls+    ExportCallback cb -> getPrimaryExtName cb++  getNestedExtNames x = case x of+    ExportVariable v -> getNestedExtNames v+    ExportEnum e -> getNestedExtNames e+    ExportBitspace b -> getNestedExtNames b+    ExportFn f -> getNestedExtNames f+    ExportClass cls -> getNestedExtNames cls+    ExportCallback cb -> getNestedExtNames cb++-- | Returns the export's addendum.  'Export' doesn't have a 'HasAddendum'+-- instance because you normally wouldn't want to modify the addendum of one.+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++-- | A path to some C++ object, including namespaces.  An identifier consists of+-- multiple parts separated by @\"::\"@.  Each part has a name string followed+-- by an optional template argument list, where each argument gets rendered from+-- a 'Type' (non-type arguments for template metaprogramming are not supported).+newtype Identifier = Identifier+  { identifierParts :: [IdPart]+    -- ^ The separate parts of the identifier, between @::@s.+  } 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++-- | A single component of an 'Identifier', between @::@s.+data IdPart = IdPart+  { idPartBase :: String+    -- ^ The name within the enclosing scope.+  , idPartArgs :: Maybe [Type]+    -- ^ Template arguments, if present.+  } deriving (Eq, Show)++-- | Creates an identifier of the form @a@.+ident :: String -> Identifier+ident a = Identifier [IdPart a Nothing]++-- | Creates an identifier of the form @a1::a2::...::aN@.+ident' :: [String] -> Identifier+ident' = Identifier . map (\x -> IdPart x Nothing)++-- | Creates an identifier of the form @a::b@.+ident1 :: String -> String -> Identifier+ident1 a b = ident' [a, b]++-- | Creates an identifier of the form @a::b::c@.+ident2 :: String -> String -> String -> Identifier+ident2 a b c = ident' [a, b, c]++-- | Creates an identifier of the form @a::b::c::d@.+ident3 :: String -> String -> String -> String -> Identifier+ident3 a b c d = ident' [a, b, c, d]++-- | Creates an identifier of the form @a::b::c::d::e@.+ident4 :: String -> String -> String -> String -> String -> Identifier+ident4 a b c d e = ident' [a, b, c, d, e]++-- | Creates an identifier of the form @a::b::c::d::e::f@.+ident5 :: String -> String -> String -> String -> String -> String -> Identifier+ident5 a b c d e f = ident' [a, b, c, d, e, f]++-- | Creates an identifier of the form @a\<...\>@.+identT :: String -> [Type] -> Identifier+identT a ts = Identifier [IdPart a $ Just ts]++-- | Creates an identifier with arbitrary many templated and non-templated+-- parts.+identT' :: [(String, Maybe [Type])] -> Identifier+identT' = Identifier . map (uncurry IdPart)++-- | Creates an identifier of the form @a::b\<...\>@.+ident1T :: String -> String -> [Type] -> Identifier+ident1T a b ts = Identifier [IdPart a Nothing, IdPart b $ Just ts]++-- | Creates an identifier of the form @a::b::c\<...\>@.+ident2T :: String -> String -> String -> [Type] -> Identifier+ident2T a b c ts = Identifier [IdPart a Nothing, IdPart b Nothing, IdPart c $ Just ts]++-- | Creates an identifier of the form @a::b::c::d\<...\>@.+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]++-- | Creates an identifier of the form @a::b::c::d::e\<...\>@.+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]++-- | Creates an identifier of the form @a::b::c::d::e::f\<...\>@.+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]++-- | A concrete C++ type.  Use the bindings in "Foreign.Hoppy.Generator.Types"+-- for values of this type; these data constructors are subject to change+-- without notice.+data Type =+    Internal_TVoid+  | Internal_TBool+  | Internal_TChar+  | Internal_TUChar+  | Internal_TShort+  | Internal_TUShort+  | Internal_TInt+  | Internal_TUInt+  | Internal_TLong+  | Internal_TULong+  | Internal_TLLong+  | Internal_TULLong+  | Internal_TFloat+  | Internal_TDouble+  | Internal_TInt8+  | Internal_TInt16+  | Internal_TInt32+  | Internal_TInt64+  | Internal_TWord8+  | Internal_TWord16+  | Internal_TWord32+  | Internal_TWord64+  | Internal_TPtrdiff+  | Internal_TSize+  | Internal_TSSize+  | Internal_TEnum CppEnum+  | Internal_TBitspace Bitspace+  | Internal_TPtr Type+  | Internal_TRef Type+  | Internal_TFn [Type] Type+  | Internal_TCallback Callback+  | Internal_TObj Class+  | Internal_TObjToHeap Class+  | Internal_TToGc Type+  | Internal_TConst Type+  deriving (Eq, Show)++-- | Canonicalizes a 'Type' without changing its meaning.  Multiple nested+-- 'Internal_TConst's are collapsed into a single one.+normalizeType :: Type -> Type+normalizeType t = case t of+  Internal_TVoid -> t+  Internal_TBool -> t+  Internal_TChar -> t+  Internal_TUChar -> t+  Internal_TShort -> t+  Internal_TUShort -> t+  Internal_TInt -> t+  Internal_TUInt -> t+  Internal_TLong -> t+  Internal_TULong -> t+  Internal_TLLong -> t+  Internal_TULLong -> t+  Internal_TFloat -> t+  Internal_TDouble -> t+  Internal_TInt8 -> t+  Internal_TInt16 -> t+  Internal_TInt32 -> t+  Internal_TInt64 -> t+  Internal_TWord8 -> t+  Internal_TWord16 -> t+  Internal_TWord32 -> t+  Internal_TWord64 -> t+  Internal_TPtrdiff -> t+  Internal_TSize -> t+  Internal_TSSize -> t+  Internal_TEnum _ -> t+  Internal_TBitspace _ -> t+  Internal_TPtr t' -> Internal_TPtr $ normalizeType t'+  Internal_TRef t' -> Internal_TRef $ normalizeType t'+  Internal_TFn paramTypes retType ->+    Internal_TFn (map normalizeType paramTypes) $ normalizeType retType+  Internal_TCallback _ -> t+  Internal_TObj _ -> t+  Internal_TObjToHeap _ -> t+  Internal_TToGc _ -> t+  Internal_TConst (Internal_TConst t') -> normalizeType $ Internal_TConst t'+  Internal_TConst _ -> t++-- | Strips leading 'Internal_TConst's off of a type.+stripConst :: Type -> Type+stripConst t = case t of+  Internal_TConst t' -> stripConst t'+  _ -> t++-- | A C++ variable.+data Variable = Variable+  { varIdentifier :: Identifier+    -- ^ The identifier used to refer to the variable.+  , varExtName :: ExtName+    -- ^ The variable's external name.+  , varType :: Type+    -- ^ The variable's type.  This may be+    -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is+    -- read-only.+  , varReqs :: Reqs+    -- ^ Requirements for bindings to use this variable.+  , varAddendum :: Addendum+    -- ^ The variable's addendum.+  }++instance Eq Variable where+  (==) = (==) `on` varExtName++instance Show Variable where+  show v = concat ["<Variable ", show (varExtName v), " ", show (varType v), ">"]++instance HasExtNames Variable where+  getPrimaryExtName = varExtName+  getNestedExtNames v = [varGetterExtName v, varSetterExtName v]++instance HasReqs Variable where+  getReqs = varReqs+  setReqs reqs v = v { varReqs = reqs }++instance HasAddendum Variable where+  getAddendum = varAddendum+  setAddendum addendum v = v { varAddendum = addendum }++-- | Creates a binding for a C++ variable.+makeVariable :: Identifier -> Maybe ExtName -> Type -> Variable+makeVariable identifier maybeExtName t =+  Variable identifier (extNameOrIdentifier identifier maybeExtName) t mempty mempty++-- | Returns whether the variable is constant, i.e. whether its type is+-- @'Foreign.Hoppy.Generator.Types.constT' ...@.+varIsConst :: Variable -> Bool+varIsConst v = case varType v of+  Internal_TConst _ -> True+  _ -> False++-- | Returns the external name of the getter function for the variable.+varGetterExtName :: Variable -> ExtName+varGetterExtName = toExtName . (++ "_get") . fromExtName . varExtName++-- | Returns the external name of the setter function for the variable.+varSetterExtName :: Variable -> ExtName+varSetterExtName = toExtName . (++ "_set") . fromExtName . varExtName++-- | A C++ enum declaration.  An enum should actually be enumerable (in the+-- sense of Haskell's 'Enum'); if it's not, consider using a 'Bitspace' instead.+data CppEnum = CppEnum+  { enumIdentifier :: Identifier+    -- ^ The identifier used to refer to the enum.+  , enumExtName :: ExtName+    -- ^ The enum's external name.+  , enumValueNames :: [(Int, [String])]+    -- ^ The numeric values and names of the enum values.  A single value's name+    -- 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.+  , enumAddendum :: Addendum+    -- ^ The enum's addendum.+  , enumValuePrefix :: String+    -- ^ The prefix applied to value names ('enumValueNames') when determining+    -- the names of values in foreign languages.  This defaults to the external+    -- name of the enum, plus an underscore.+    --+    -- See 'enumSetValuePrefix'.+  }++instance Eq CppEnum where+  (==) = (==) `on` enumExtName++instance Show CppEnum where+  show e = concat ["<Enum ", show (enumExtName e), " ", show (enumIdentifier e), ">"]++instance HasExtNames CppEnum where+  getPrimaryExtName = enumExtName++instance HasReqs CppEnum where+  getReqs = enumReqs+  setReqs reqs e = e { enumReqs = reqs }++instance HasAddendum CppEnum where+  getAddendum = enumAddendum+  setAddendum addendum e = e { enumAddendum = addendum }++-- | Creates a binding for a C++ enum.+makeEnum :: Identifier  -- ^ 'enumIdentifier'+         -> Maybe ExtName+         -- ^ An optional external name; will be automatically derived from+         -- the identifier if absent.+         -> [(Int, [String])]  -- ^ 'enumValueNames'+         -> CppEnum+makeEnum identifier maybeExtName valueNames =+  let extName = extNameOrIdentifier identifier maybeExtName+  in CppEnum+     identifier+     extName+     valueNames+     mempty+     mempty+     (fromExtName extName ++ "_")++-- | Sets the prefix applied to the names of enum values' identifiers in foreign+-- languages.+--+-- See 'enumValuePrefix'.+enumSetValuePrefix :: String -> CppEnum -> CppEnum+enumSetValuePrefix prefix enum = enum { enumValuePrefix = prefix }++-- | A C++ numeric space with bitwise operations.  This is similar to a+-- 'CppEnum', but in addition to the extra operations, this differs in that+-- these values aren't enumerable.+--+-- Additionally, as a kludge for Qtah, a bitspace may have a C++ type+-- ('bitspaceCppTypeIdentifier') separate from its numeric type+-- ('bitspaceType').  Qt bitspaces aren't raw numbers but are instead type-safe+-- @QFlags@ objects that don't implicitly convert from integers, so we need a+-- means to do so manually.  Barring general ad-hoc argument and return value+-- conversion support, we allow this as follows: when given a C++ type, then a+-- bitspace may also have a conversion function between the numeric and C+++-- type, in each direction.  If a conversion function is present, it will be+-- used for conversions in its respective direction.  The C++ type is not a full+-- 'Type', but only an 'Identifier', since additional information is not needed.+-- See 'bitspaceAddCppType'.+data Bitspace = Bitspace+  { bitspaceExtName :: ExtName+    -- ^ The bitspace's external name.+  , bitspaceType :: Type+    -- ^ The C++ type used for bits values.  This should be a primitive numeric+    -- type, usually 'Foreign.Hoppy.Generator.Types.intT'.+  , bitspaceValueNames :: [(Int, [String])]+    -- ^ The numeric values and names of the bitspace values.  See+    -- 'enumValueNames'.+  , bitspaceEnum :: Maybe CppEnum+    -- ^ An associated enum, whose values may be converted to values in the+    -- bitspace.+  , bitspaceCppTypeIdentifier :: Maybe Identifier+    -- ^ The optional C++ type for a bitspace.+  , bitspaceToCppValueFn :: Maybe String+    -- ^ The name of a C++ function to convert from 'bitspaceType' to the+    -- bitspace's C++ type.+  , bitspaceFromCppValueFn :: Maybe String+    -- ^ The name of a C++ function to convert from the bitspace's C++ type to+    -- 'bitspaceType'.+  , bitspaceReqs :: Reqs+    -- ^ Requirements for emitting the bindings for a bitspace, i.e. what's+    -- necessary to reference 'bitspaceCppTypeIdentifier',+    -- 'bitspaceFromCppValueFn', and 'bitspaceToCppValueFn'.  'bitspaceType' can+    -- take some numeric types that require includes as well, but you don't need+    -- to list these here.+  , bitspaceAddendum :: Addendum+    -- ^ The bitspace's addendum.+  , bitspaceValuePrefix :: String+    -- ^ The prefix applied to value names ('bitspaceValueNames') when+    -- determining the names of values in foreign languages.  This defaults to+    -- the external name of the bitspace, plus an underscore.+    --+    -- See 'bitspaceSetValuePrefix'.+  }++instance Eq Bitspace where+  (==) = (==) `on` bitspaceExtName++instance Show Bitspace where+  show e = concat ["<Bitspace ", show (bitspaceExtName e), " ", show (bitspaceType e), ">"]++instance HasExtNames Bitspace where+  getPrimaryExtName = bitspaceExtName++instance HasReqs Bitspace where+  getReqs = bitspaceReqs+  setReqs reqs b = b { bitspaceReqs = reqs }++instance HasAddendum Bitspace where+  getAddendum = bitspaceAddendum+  setAddendum addendum bs = bs { bitspaceAddendum = addendum }++-- | Creates a binding for a C++ bitspace.+makeBitspace :: ExtName  -- ^ 'bitspaceExtName'+             -> Type  -- ^ 'bitspaceType'+             -> [(Int, [String])]  -- ^ 'bitspaceValueNames'+             -> Bitspace+makeBitspace extName t valueNames =+  Bitspace extName t valueNames Nothing Nothing Nothing Nothing mempty mempty+  (fromExtName extName ++ "_")++-- | Sets the prefix applied to the names of enum values' identifiers in foreign+-- languages.+--+-- See 'enumValuePrefix'.+bitspaceSetValuePrefix :: String -> Bitspace -> Bitspace+bitspaceSetValuePrefix prefix bitspace = bitspace { bitspaceValuePrefix = prefix }++-- | Associates an enum with the bitspace.  See 'bitspaceEnum'.+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 cppTypeIdentifier toCppValueFn fromCppValueFn@+-- associates a C++ type (plus optional conversion functions) with a bitspace.+-- At least one conversion should be specified, otherwise adding the C++ type+-- will mean nothing.  You should also add use requirements to the bitspace for+-- all of these arguments; see 'HasReqs'.+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+        }++-- | Whether or not a function may cause side-effects.+--+-- Haskell bindings for pure functions will not be in 'IO', and calls to pure+-- functions will be executed non-strictly.  Calls to impure functions will+-- execute in the IO monad.+--+-- Member functions for mutable classes should not be made pure, because it is+-- difficult in general to control when the call will be made.+data Purity = Nonpure  -- ^ Side-affects are possible.+            | Pure  -- ^ Side-affects will not happen.+            deriving (Eq, Show)++-- | A C++ function declaration.+data Function = Function+  { fnCName :: FnName Identifier+    -- ^ The identifier used to call the function.+  , fnExtName :: ExtName+    -- ^ The function's external name.+  , fnPurity :: Purity+    -- ^ Whether the function is pure.+  , fnParams :: [Type]+    -- ^ The function's parameter types.+  , fnReturn :: Type+    -- ^ The function's return type.+  , fnReqs :: Reqs+    -- ^ Requirements for a binding to call the function.+  , fnExceptionHandlers :: ExceptionHandlers+    -- ^ Exceptions that the function might throw.+  , fnAddendum :: Addendum+    -- ^ The function's addendum.+  }++instance Show Function where+  show fn =+    concat ["<Function ", show (fnExtName fn), " ", show (fnCName fn),+            show (fnParams fn), " ", show (fnReturn fn), ">"]++instance HasExtNames Function where+  getPrimaryExtName = fnExtName++instance HasReqs Function where+  getReqs = fnReqs+  setReqs reqs fn = fn { fnReqs = reqs }++instance HandlesExceptions Function where+  getExceptionHandlers = fnExceptionHandlers+  modifyExceptionHandlers f fn = fn { fnExceptionHandlers = f $ fnExceptionHandlers fn }++instance HasAddendum Function where+  getAddendum = fnAddendum+  setAddendum addendum fn = fn { fnAddendum = addendum }++-- | Creates a binding for a C++ function.+makeFn :: IsFnName Identifier name+       => name+       -> Maybe ExtName+       -- ^ An optional external name; will be automatically derived from+       -- the identifier if absent.+       -> Purity+       -> [Type]  -- ^ Parameter types.+       -> Type  -- ^ Return type.+       -> Function+makeFn cName maybeExtName purity paramTypes retType =+  let fnName = toFnName cName+  in Function fnName+              (extNameOrFnIdentifier fnName maybeExtName)+              purity paramTypes retType mempty mempty mempty++-- | 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.+data Class = Class+  { classIdentifier :: Identifier+    -- ^ The identifier used to refer to the class.+  , classExtName :: ExtName+    -- ^ The class's external name.+  , classSuperclasses :: [Class]+    -- ^ The class's public superclasses.+  , classEntities :: [ClassEntity]+    -- ^ The class's entities.+  , classDtorIsPublic :: Bool+    -- ^ The class's methods.+  , classConversion :: ClassConversion+    -- ^ Behaviour for converting objects to and from foriegn values.+  , classReqs :: Reqs+    -- ^ Requirements for a 'Type' to reference this class.+  , classAddendum :: Addendum+    -- ^ The class's addendum.+  , classIsMonomorphicSuperclass :: Bool+    -- ^ This is true for classes passed through+    -- 'classSetMonomorphicSuperclass'.+  , classIsSubclassOfMonomorphic :: Bool+    -- ^ This is true for classes passed through+    -- 'classSetSubclassOfMonomorphic'.+  , classIsException :: Bool+    -- ^ Whether to support using the class as a C++ exception.+  , classEntityPrefix :: String+    -- ^ The prefix applied to the external names of entities (methods, etc.)+    -- within this class when determining the names of foreign languages'+    -- corresponding bindings.  This defaults to the external name of the class,+    -- plus an underscore.  Changing this allows you to potentially have+    -- entities with the same foreign name in separate modules.  This may be the+    -- empty string, in which case the foreign name will simply be the external+    -- name of the entity.+    --+    -- This does __not__ affect the things' external names themselves; external+    -- names must still be unique in an interface.  For instance, a method with+    -- external name @bar@ in a class with external name @Flab@ and prefix+    -- @Flob_@ will use the effective external name @Flab_bar@, but the+    -- generated name in say Haskell would be @Flob_bar@.+    --+    -- See 'IsClassEntity' and 'classSetEntityPrefix'.+  }++instance Eq Class where+  (==) = (==) `on` classExtName++instance Ord Class where+  compare = compare `on` classExtName++instance Show Class where+  show cls =+    concat ["<Class ", show (classExtName cls), " ", show (classIdentifier cls), ">"]++instance HasExtNames Class where+  getPrimaryExtName = classExtName++  getNestedExtNames cls = concatMap (classEntityExtNames cls) $ classEntities cls++instance HasReqs Class where+  getReqs = classReqs+  setReqs reqs cls = cls { classReqs = reqs }++instance HasAddendum Class where+  getAddendum = classAddendum+  setAddendum addendum cls = cls { classAddendum = addendum }++-- | Creates a binding for a C++ class and its contents.+makeClass :: Identifier+          -> Maybe ExtName+          -- ^ An optional external name; will be automatically derived from the+          -- identifier if absent.+          -> [Class]  -- ^ Superclasses.+          -> [ClassEntity]+          -> Class+makeClass identifier maybeExtName supers entities =+  let extName = extNameOrIdentifier identifier maybeExtName+  in Class+     { classIdentifier = identifier+     , classExtName = extName+     , classSuperclasses = supers+     , classEntities = entities+     , classDtorIsPublic = True+     , classConversion = classConversionNone+     , classReqs = mempty+     , classAddendum = mempty+     , classIsMonomorphicSuperclass = False+     , classIsSubclassOfMonomorphic = False+     , classIsException = False+     , classEntityPrefix = fromExtName extName ++ "_"+     }++-- | Sets the prefix applied to foreign languages' entities generated from+-- methods, etc. within the class.+--+-- See 'IsClassEntity' and 'classEntityPrefix'.+classSetEntityPrefix :: String -> Class -> Class+classSetEntityPrefix prefix cls = cls { classEntityPrefix = prefix }++-- | Adds constructors to a class.+classAddEntities :: [ClassEntity] -> Class -> Class+classAddEntities ents cls =+  if null ents then cls else cls { classEntities = classEntities cls ++ ents }++-- | Returns all of the class's variables.+classVariables :: Class -> [ClassVariable]+classVariables = mapMaybe pickVar . classEntities+  where pickVar ent = case ent of+          CEVar v -> Just v+          CECtor _ -> Nothing+          CEMethod _ -> Nothing+          CEProp _ -> Nothing++-- | Returns all of the class's constructors.+classCtors :: Class -> [Ctor]+classCtors = mapMaybe pickCtor . classEntities+  where pickCtor ent = case ent of+          CEVar _ -> Nothing+          CECtor ctor -> Just ctor+          CEMethod _ -> Nothing+          CEProp _ -> Nothing++-- | Returns all of the class's methods, including methods generated from+-- 'Prop's.+classMethods :: Class -> [Method]+classMethods = concatMap pickMethods . classEntities+  where pickMethods ent = case ent of+          CEVar _ -> []+          CECtor _ -> []+          CEMethod m -> [m]+          CEProp (Prop ms) -> ms++-- | Marks a class's destructor as private, so that a binding for it won't be+-- generated.+classSetDtorPrivate :: Class -> Class+classSetDtorPrivate cls = cls { classDtorIsPublic = False }++-- | Explicitly marks a class as being monomorphic (i.e. not having any+-- virtual methods or destructors).  By default, Hoppy assumes that a class that+-- is derived is also polymorphic, but it can happen that this is not the case.+-- Downcasting with @dynamic_cast@ from such classes is not available.  See also+-- 'classSetSubclassOfMonomorphic'.+classSetMonomorphicSuperclass :: Class -> Class+classSetMonomorphicSuperclass cls = cls { classIsMonomorphicSuperclass = True }++-- | Marks a class as being derived from some monomorphic superclass.  This+-- prevents any downcasting to this class.  Generally it is better to use+-- 'classSetMonomorphicSuperclass' on the specific superclasses that are+-- monomorphic, but in cases where this is not possible, this function can be+-- applied to the subclass instead.+classSetSubclassOfMonomorphic :: Class -> Class+classSetSubclassOfMonomorphic cls = cls { classIsSubclassOfMonomorphic = True }++-- | Marks a class as being used as an exception.  This makes the class+-- throwable and catchable.+classMakeException :: Class -> Class+classMakeException cls = case classIsException cls of+  False -> cls { classIsException = True }+  True -> cls++-- | Separately from passing object handles between C++ and foreign languages,+-- objects can also be made to implicitly convert to native values in foreign+-- languages.  A single such type may be associated with any C++ class for each+-- foreign language.  The foreign type and the conversion process in each+-- direction are specified using this object.  Converting a C++ object to a+-- foreign value is also called decoding, and vice versa is called encoding.  A+-- class may be convertible in one direction and not the other.+--+-- To use these implicit conversions, instead of specifying an object handle+-- type such as+-- @'Foreign.Hoppy.Generator.Types.ptrT' . 'Foreign.Hoppy.Generator.Types.objT'@+-- or+-- @'Foreign.Hoppy.Generator.Types.refT' . 'Foreign.Hoppy.Generator.Types.objT'@,+-- use 'Foreign.Hoppy.Generator.Types.objT' directly.+--+-- The subfields in this object specify how to do conversions between C++ and+-- foreign languages.+data ClassConversion = ClassConversion+  { classHaskellConversion :: ClassHaskellConversion+    -- ^ Conversions to and from Haskell.++    -- NOTE!  When adding new languages here, add the language to+    -- 'classSetConversionToHeap', and 'classSetConversionToGc' as well if the+    -- language supports garbage collection.+  }++-- | Conversion behaviour for a class that is not convertible.+classConversionNone :: ClassConversion+classConversionNone = ClassConversion classHaskellConversionNone++-- | Modifies a class's 'ClassConversion' structure with a given function.+classModifyConversion :: (ClassConversion -> ClassConversion) -> Class -> Class+classModifyConversion f cls =+  let cls' = cls { classConversion = f $ classConversion cls }+      conv = classConversion cls'+      haskellConv = classHaskellConversion conv+  in case undefined of+    _ | (isJust (classHaskellConversionToCppFn haskellConv) ||+         isJust (classHaskellConversionFromCppFn haskellConv)) &&+        isNothing (classHaskellConversionType haskellConv) ->+      error $ "classModifyConversion: " ++ show cls' +++      " was given a Haskell-to-C++ or C++-to-Haskell conversion function" +++      " but no Haskell type.  Please provide a classHaskellConversionType."+    _ -> cls'++-- | Replaces a class's 'ClassConversion' structure.+classSetConversion :: ClassConversion -> Class -> Class+classSetConversion c = classModifyConversion $ const c++-- | Controls how conversions between C++ objects and Haskell values happen in+-- Haskell bindings.+data ClassHaskellConversion = ClassHaskellConversion+  { classHaskellConversionType :: Maybe (Haskell.Generator HsType)+    -- ^ Produces the Haskell type that represents a value of the corresponding+    -- C++ class.  This generator may add imports, but must not output code or+    -- add exports.+  , classHaskellConversionToCppFn :: Maybe (Haskell.Generator ())+    -- ^ Produces a Haskell expression that evaluates to a function that takes+    -- an object of the type that 'classHaskellConversionType' generates, and+    -- returns a non-const handle for a new C++ object in IO.  The generator+    -- must output code and may add imports, but must not add exports.+    --+    -- If this field is present, then 'classHaskellConversionType' must also be+    -- present.+  , classHaskellConversionFromCppFn :: Maybe (Haskell.Generator ())+    -- ^ Produces a Haskell expression that evaluates to a function that takes a+    -- const handle for a C++ object, and returns an value of the type that+    -- 'classHaskellConversionType' generates, in IO.  The generator must output+    -- code and may add imports, but must not add exports.+    --+    -- If this field is present, then 'classHaskellConversionType' must also be+    -- present.+  }++-- | Conversion behaviour for a class that is not convertible to or from+-- Haskell.+classHaskellConversionNone :: ClassHaskellConversion+classHaskellConversionNone =+  ClassHaskellConversion+  { classHaskellConversionType = Nothing+  , classHaskellConversionToCppFn = Nothing+  , classHaskellConversionFromCppFn = Nothing+  }++-- | Replaces a class's 'classHaskellConversion' with a given value.+classSetHaskellConversion :: ClassHaskellConversion -> Class -> Class+classSetHaskellConversion conv = classModifyConversion $ \c ->+  c { classHaskellConversion = conv }++-- | Things that live inside of a class, and have the class's external name+-- prepended to their own in generated code.  With an external name of @\"bar\"@+-- and a class with external name @\"foo\"@, the resulting name will be+-- @\"foo_bar\"@.+--+-- See 'classEntityPrefix' and 'classSetEntityPrefix'.+class IsClassEntity a where+  -- | Extracts the external name of the object, without the class name added.+  classEntityExtNameSuffix :: a -> ExtName++-- | Computes the external name to use in generated code, containing both the+-- class's and object's external names.  This is the concatenation of the+-- class's and entity's external names, separated by an underscore.+classEntityExtName :: IsClassEntity a => Class -> a -> ExtName+classEntityExtName cls x =+  toExtName $ fromExtName (classExtName cls) ++ "_" ++ fromExtName (classEntityExtNameSuffix x)++-- | Computes the name under which a class entity is to be exposed in foreign+-- languages.  This is the concatenation of a class's entity prefix, and the+-- external name of the entity.+classEntityForeignName :: IsClassEntity a => Class -> a -> ExtName+classEntityForeignName cls x =+  classEntityForeignName' cls $ classEntityExtNameSuffix x++-- | Computes the name under which a class entity is to be exposed in foreign+-- languages, given a class and an entity's external name.  The result is the+-- concatenation of a class's entity prefix, and the external name of the+-- entity.+classEntityForeignName' :: Class -> ExtName -> ExtName+classEntityForeignName' cls extName =+  toExtName $ classEntityPrefix cls ++ fromExtName extName++-- | A C++ entity that belongs to a class.+data ClassEntity =+    CEVar ClassVariable+  | CECtor Ctor+  | CEMethod Method+  | CEProp Prop++-- | Returns all of the names in a 'ClassEntity' within the corresponding+-- 'Class'.+classEntityExtNames :: Class -> ClassEntity -> [ExtName]+classEntityExtNames cls ent = case ent of+  CEVar v -> [classEntityExtName cls v]+  CECtor ctor -> [classEntityExtName cls ctor]+  CEMethod m -> [classEntityExtName cls m]+  CEProp (Prop methods) -> map (classEntityExtName cls) methods++-- | A C++ member variable.+data ClassVariable = ClassVariable+  { classVarCName :: String+    -- ^ The variable's C++ name.+  , classVarExtName :: ExtName+    -- ^ The variable's external name.+  , classVarType :: Type+    -- ^ The variable's type.  This may be+    -- 'Foreign.Hoppy.Generator.Types.constT' to indicate that the variable is+    -- read-only.+  , classVarStatic :: Staticness+    -- ^ Whether the variable is static (i.e. whether it exists once in the+    -- class itself and not in each instance).+  , classVarGettable :: Bool+    -- ^ Whether the variable should have an accompanying getter. Note this+    -- exists only for disabling getters on callback variables - as there is+    -- currently no functionality to pass callbacks out of c+++  }++instance Show ClassVariable where+  show v =+    concat ["<ClassVariable ",+            show $ classVarCName v, " ",+            show $ classVarExtName v, " ",+            show $ classVarStatic v, " ",+            show $ classVarType v, ">"]++instance IsClassEntity ClassVariable where+  classEntityExtNameSuffix = classVarExtName++-- | Creates a 'ClassVariable' with full generality and manual name specification.+--+-- The result is wrapped in a 'CEVar'.  For an unwrapped value, use+-- 'makeClassVariable_'.+makeClassVariable :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassEntity+makeClassVariable cName maybeExtName tp static gettable =+  CEVar $ makeClassVariable_ cName maybeExtName tp static gettable++-- | The unwrapped version of 'makeClassVariable'.+makeClassVariable_ :: String -> Maybe ExtName -> Type -> Staticness -> Bool -> ClassVariable+makeClassVariable_ cName maybeExtName =+  ClassVariable cName $ extNameOrString cName maybeExtName++-- | Creates a 'ClassVariable' for a nonstatic class variable for+-- @class::varName@ whose external name is @class_varName@.+--+-- The result is wrapped in a 'CEVar'.  For an unwrapped value, use+-- 'mkClassVariable_'.+mkClassVariable :: String -> Type -> ClassEntity+mkClassVariable = (CEVar .) . mkClassVariable_++-- | The unwrapped version of 'mkClassVariable'.+mkClassVariable_ :: String -> Type -> ClassVariable+mkClassVariable_ cName t = makeClassVariable_ cName Nothing t Nonstatic True++-- | Same as 'mkClassVariable', but returns a static variable instead.+--+-- The result is wrapped in a 'CEVar'.  For an unwrapped value, use+-- 'mkStaticClassVariable_'.+mkStaticClassVariable :: String -> Type -> ClassEntity+mkStaticClassVariable = (CEVar .) . mkStaticClassVariable_++-- | The unwrapped version of 'mkStaticClassVariable'.+mkStaticClassVariable_ :: String -> Type -> ClassVariable+mkStaticClassVariable_ cName t = makeClassVariable_ cName Nothing t Static True++-- | Returns the external name of the getter function for the class variable.+classVarGetterExtName :: Class -> ClassVariable -> ExtName+classVarGetterExtName cls v =+  toExtName $ fromExtName (classEntityExtName cls v) ++ "_get"++-- | Returns the foreign name of the getter function for the class variable.+classVarGetterForeignName :: Class -> ClassVariable -> ExtName+classVarGetterForeignName cls v =+  toExtName $ fromExtName (classEntityForeignName cls v) ++ "_get"++-- | Returns the external name of the setter function for the class variable.+classVarSetterExtName :: Class -> ClassVariable -> ExtName+classVarSetterExtName cls v =+  toExtName $ fromExtName (classEntityExtName cls v) ++ "_set"++-- | Returns the foreign name of the setter function for the class variable.+classVarSetterForeignName :: Class -> ClassVariable -> ExtName+classVarSetterForeignName cls v =+  toExtName $ fromExtName (classEntityForeignName cls v) ++ "_set"++-- | A C++ class constructor declaration.+data Ctor = Ctor+  { ctorExtName :: ExtName+    -- ^ The constructor's external name.+  , ctorParams :: [Type]+    -- ^ The constructor's parameter types.+  , ctorExceptionHandlers :: ExceptionHandlers+    -- ^ Exceptions that the constructor may throw.+  }++instance Show Ctor where+  show ctor = concat ["<Ctor ", show (ctorExtName ctor), " ", show (ctorParams ctor), ">"]++instance HandlesExceptions Ctor where+  getExceptionHandlers = ctorExceptionHandlers+  modifyExceptionHandlers f ctor = ctor { ctorExceptionHandlers = f $ ctorExceptionHandlers ctor }++instance IsClassEntity Ctor where+  classEntityExtNameSuffix = ctorExtName++-- | Creates a 'Ctor' with full generality.+--+-- The result is wrapped in a 'CECtor'.  For an unwrapped value, use+-- 'makeCtor_'.+makeCtor :: ExtName+         -> [Type]  -- ^ Parameter types.+         -> ClassEntity+makeCtor = (CECtor .) . makeCtor_++-- | The unwrapped version of 'makeCtor'.+makeCtor_ :: ExtName -> [Type] -> Ctor+makeCtor_ extName paramTypes = Ctor extName paramTypes mempty++-- | @mkCtor name@ creates a 'Ctor' whose external name is @className_name@.+--+-- The result is wrapped in a 'CECtor'.  For an unwrapped value, use+-- 'makeCtor_'.+mkCtor :: String+       -> [Type]  -- ^ Parameter types.+       -> ClassEntity+mkCtor = (CECtor .) . mkCtor_++-- | The unwrapped version of 'mkCtor'.+mkCtor_ :: String -> [Type] -> Ctor+mkCtor_ = makeCtor_ . toExtName++-- | Searches a class for a copy constructor, returning it if found.+classFindCopyCtor :: Class -> Maybe Ctor+classFindCopyCtor cls = case mapMaybe check $ classEntities cls of+  [ctor] -> Just ctor+  _ -> Nothing+  where check entity = case entity of+          CECtor ctor ->+            let params = map (stripConst . normalizeType) (ctorParams ctor)+            in if params == [Internal_TObj cls] ||+                  params == [Internal_TRef $ Internal_TConst $ Internal_TObj cls]+            then Just ctor+            else Nothing+          _ -> Nothing++-- | A C++ class method declaration.+--+-- Any operator function that can be written as a method may have its binding be+-- written either as part of the associated class or as a separate entity,+-- independently of how the function is declared in C++.+data Method = Method+  { methodImpl :: MethodImpl+    -- ^ The underlying code that the binding calls.+  , methodExtName :: ExtName+    -- ^ The method's external name.+  , methodApplicability :: MethodApplicability+    -- ^ How the method is associated to its class.+  , methodPurity :: Purity+    -- ^ Whether the method is pure.+  , methodParams :: [Type]+    -- ^ The method's parameter types.+  , methodReturn :: Type+    -- ^ The method's return type.+  , methodExceptionHandlers :: ExceptionHandlers+    -- ^ Exceptions that the method might throw.+  }++instance Show Method where+  show method =+    concat ["<Method ", show (methodExtName method), " ",+            case methodImpl method of+              RealMethod name -> show name+              FnMethod name -> show name, " ",+            show (methodApplicability method), " ",+            show (methodPurity method), " ",+            show (methodParams method), " ",+            show (methodReturn method), ">"]++instance HandlesExceptions Method where+  getExceptionHandlers = methodExceptionHandlers++  modifyExceptionHandlers f method =+    method { methodExceptionHandlers = f $ methodExceptionHandlers method }++instance IsClassEntity Method where+  classEntityExtNameSuffix = methodExtName++-- | The C++ code to which a 'Method' is bound.+data MethodImpl =+  RealMethod (FnName String)+  -- ^ The 'Method' is bound to an actual class method.+  | FnMethod (FnName Identifier)+    -- ^ The 'Method' is bound to a wrapper function.  When wrapping a method+    -- with another function, this is preferrable to just using a 'Function'+    -- binding because a method will still appear to be part of the class in+    -- foreign bindings.+  deriving (Eq, Show)++-- | How a method is associated to its class.  A method may be static, const, or+-- neither (a regular method).+data MethodApplicability = MNormal | MStatic | MConst+                         deriving (Bounded, Enum, Eq, Show)++-- | Whether or not a method is const.+data Constness = Nonconst | Const+               deriving (Bounded, Enum, Eq, Show)++-- | Returns the opposite constness value.+constNegate :: Constness -> Constness+constNegate Nonconst = Const+constNegate Const = Nonconst++-- | Whether or not a method is static.+data Staticness = Nonstatic | Static+               deriving (Bounded, Enum, Eq, Show)++-- | Returns the constness of a method, based on its 'methodApplicability'.+methodConst :: Method -> Constness+methodConst method = case methodApplicability method of+  MConst -> Const+  _ -> Nonconst++-- | Returns the staticness of a method, based on its 'methodApplicability'.+methodStatic :: Method -> Staticness+methodStatic method = case methodApplicability method of+  MStatic -> Static+  _ -> Nonstatic++-- | Creates a 'Method' with full generality and manual name specification.+--+-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use+-- 'makeMethod_'.+makeMethod :: IsFnName String name+           => name  -- ^ The C++ name of the method.+           -> ExtName  -- ^ The external name of the method.+           -> MethodApplicability+           -> Purity+           -> [Type]  -- ^ Parameter types.+           -> Type  -- ^ Return type.+           -> ClassEntity+makeMethod = (((((CEMethod .) .) .) .) .) . makeMethod_++-- | The unwrapped version of 'makeMethod'.+makeMethod_ :: IsFnName String name+            => name+            -> ExtName+            -> MethodApplicability+            -> Purity+            -> [Type]+            -> Type+            -> Method+makeMethod_ cName extName appl purity paramTypes retType =+  Method (RealMethod $ toFnName cName) extName appl purity paramTypes retType mempty++-- | Creates a 'Method' that is in fact backed by a C++ non-member function (a+-- la 'makeFn'), but appears to be a regular method.  This is useful for+-- wrapping a method on the C++ side when its arguments aren't right for binding+-- directly.+--+-- A @this@ pointer parameter is __not__ automatically added to the parameter+-- list for non-static methods created with @makeFnMethod@.+--+-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use+-- 'makeFnMethod_'.+makeFnMethod :: IsFnName Identifier name+             => name+             -> String+             -> MethodApplicability+             -> Purity+             -> [Type]+             -> Type+             -> ClassEntity+makeFnMethod = (((((CEMethod .) .) .) .) .) . makeFnMethod_++-- | The unwrapped version of 'makeFnMethod'.+makeFnMethod_ :: IsFnName Identifier name+              => name+              -> String+              -> MethodApplicability+              -> Purity+              -> [Type]+              -> Type+              -> Method+makeFnMethod_ cName foreignName appl purity paramTypes retType =+  Method (FnMethod $ toFnName cName) (toExtName foreignName)+         appl purity paramTypes retType mempty++-- | This function is internal.+--+-- Creates a method similar to 'makeMethod', but with automatic naming.  The+-- method's external name will be @className ++ \"_\" ++ cppMethodName@.  If the+-- method name is a 'FnOp' then the 'operatorPreferredExtName' will be appeneded+-- to the class name.+--+-- For creating multiple bindings to a method, see 'makeMethod''.+makeMethod' :: IsFnName String name+            => name  -- ^ The C++ name of the method.+            -> MethodApplicability+            -> Purity+            -> [Type]  -- ^ Parameter types.+            -> Type  -- ^ Return type.+            -> Method+makeMethod' name = makeMethod''' (toFnName name) Nothing++-- | This function is internal.+--+-- Creates a method similar to 'makeMethod'', but with an custom string that+-- will be appended to the class name to form the method's external name.  This+-- is useful for making multiple bindings to a method, e.g. for overloading and+-- optional arguments.+makeMethod'' :: IsFnName String name+             => name  -- ^ The C++ name of the method.+             -> String  -- ^ A foreign name for the method.+             -> MethodApplicability+             -> Purity+             -> [Type]  -- ^ Parameter types.+             -> Type  -- ^ Return type.+             -> Method+makeMethod'' name foreignName = makeMethod''' (toFnName name) $ Just foreignName++-- | The implementation of 'makeMethod'' and 'makeMethod'''.+makeMethod''' :: FnName String  -- ^ The C++ name of the method.+              -> Maybe String  -- ^ A foreign name for the method.+              -> MethodApplicability+              -> Purity+              -> [Type]  -- ^ Parameter types.+              -> Type  -- ^ Return 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++-- | Creates a nonconst, nonstatic 'Method' for @class::methodName@ and whose+-- external name is @class_methodName@.  If the name is an operator, then the+-- 'operatorPreferredExtName' will be used in the external name.+--+-- For creating multiple bindings to a method, see 'mkMethod''.+--+-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use+-- 'mkMethod_'.+mkMethod :: IsFnName String name+         => name  -- ^ The C++ name of the method.+         -> [Type]  -- ^ Parameter types.+         -> Type  -- ^ Return type.+         -> ClassEntity+mkMethod = ((CEMethod .) .) . mkMethod_++-- | The unwrapped version of 'mkMethod'.+mkMethod_ :: IsFnName String name+          => name+          -> [Type]+          -> Type+          -> Method+mkMethod_ name = makeMethod' name MNormal Nonpure++-- | Creates a nonconst, nonstatic 'Method' for method @class::methodName@ and+-- whose external name is @class_methodName@.  This enables multiple 'Method's+-- with different foreign names (and hence different external names) to bind to+-- the same method, e.g. to make use of optional arguments or overloading.  See+-- 'mkMethod' for a simpler form.+--+-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use+-- 'mkMethod'_'.+mkMethod' :: IsFnName String name+          => name  -- ^ The C++ name of the method.+          -> String  -- ^ A foreign name for the method.+          -> [Type]  -- ^ Parameter types.+          -> Type  -- ^ Return type.+          -> ClassEntity+mkMethod' = (((CEMethod .) .) .) . mkMethod'_++-- | The unwrapped version of 'mkMethod''.+mkMethod'_ :: IsFnName String name+           => name+           -> String+           -> [Type]+           -> Type+           -> Method+mkMethod'_ cName foreignName = makeMethod'' cName foreignName MNormal Nonpure++-- | Same as 'mkMethod', but returns an 'MConst' method.+--+-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use+-- 'mkConstMethod_'.+mkConstMethod :: IsFnName String name => name -> [Type] -> Type -> ClassEntity+mkConstMethod = ((CEMethod .) .) . mkConstMethod_++-- | The unwrapped version of 'mkConstMethod'.+mkConstMethod_ :: IsFnName String name => name -> [Type] -> Type -> Method+mkConstMethod_ name = makeMethod' name MConst Nonpure++-- | Same as 'mkMethod'', but returns an 'MConst' method.+--+-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use+-- 'mkConstMethod'_'.+mkConstMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> ClassEntity+mkConstMethod' = (((CEMethod .) .) .) . mkConstMethod'_++-- | The unwrapped version of 'mkConstMethod''.+mkConstMethod'_ :: IsFnName String name => name -> String -> [Type] -> Type -> Method+mkConstMethod'_ cName foreignName = makeMethod'' cName foreignName MConst Nonpure++-- | Same as 'mkMethod', but returns an 'MStatic' method.+--+-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use+-- 'mkStaticMethod_'.+mkStaticMethod :: IsFnName String name => name -> [Type] -> Type -> ClassEntity+mkStaticMethod = ((CEMethod .) .) . mkStaticMethod_++-- | The unwrapped version of 'mkStaticMethod'.+mkStaticMethod_ :: IsFnName String name => name -> [Type] -> Type -> Method+mkStaticMethod_ name = makeMethod' name MStatic Nonpure++-- | Same as 'mkMethod'', but returns an 'MStatic' method.+--+-- The result is wrapped in a 'CEMethod'.  For an unwrapped value, use+-- 'mkStaticMethod'_'.+mkStaticMethod' :: IsFnName String name => name -> String -> [Type] -> Type -> ClassEntity+mkStaticMethod' = (((CEMethod .) .) .) . mkStaticMethod'_++-- | The unwrapped version of 'mkStaticMethod''.+mkStaticMethod'_ :: IsFnName String name => name -> String -> [Type] -> Type -> Method+mkStaticMethod'_ cName foreignName = makeMethod'' cName foreignName MStatic Nonpure++-- | A \"property\" getter/setter pair.+newtype Prop = Prop [Method]++-- | Creates a getter/setter binding pair for methods:+--+-- > T foo() const+-- > void setFoo(T)+--+-- The result is wrapped in a 'CEProp'.  For an unwrapped value, use+-- 'mkProp_'.+mkProp :: String -> Type -> ClassEntity+mkProp = (CEProp .) . mkProp_++-- | The unwrapped version of 'mkProp'.+mkProp_ :: String -> Type -> Prop+mkProp_ name t =+  let c:cs = name+      setName = 's' : 'e' : 't' : toUpper c : cs+  in Prop [ mkConstMethod_ name [] t+          , mkMethod_ setName [t] Internal_TVoid+          ]++-- | Creates a getter/setter binding pair for static methods:+--+-- > static T foo() const+-- > static void setFoo(T)+mkStaticProp :: String -> Type -> ClassEntity+mkStaticProp = (CEProp .) . mkStaticProp_++-- | The unwrapped version of 'mkStaticProp'.+mkStaticProp_ :: String -> Type -> Prop+mkStaticProp_ name t =+  let c:cs = name+      setName = 's' : 'e' : 't' : toUpper c : cs+  in Prop [ mkStaticMethod_ name [] t+          , mkStaticMethod_ setName [t] Internal_TVoid+          ]++-- | Creates a getter/setter binding pair for boolean methods, where the getter+-- is prefixed with @is@:+--+-- > bool isFoo() const+-- > void setFoo(bool)+--+-- The result is wrapped in a 'CEProp'.  For an unwrapped value, use+-- 'mkBoolIsProp_'.+mkBoolIsProp :: String -> ClassEntity+mkBoolIsProp = CEProp . mkBoolIsProp_++-- | The unwrapped version of 'mkBoolIsProp'.+mkBoolIsProp_ :: String -> Prop+mkBoolIsProp_ name =+  let c:cs = name+      name' = toUpper c : cs+      isName = 'i':'s':name'+      setName = 's':'e':'t':name'+  in Prop [ mkConstMethod_ isName [] Internal_TBool+          , mkMethod_ setName [Internal_TBool] Internal_TVoid+          ]++-- | Creates a getter/setter binding pair for boolean methods, where the getter+-- is prefixed with @has@:+--+-- > bool hasFoo() const+-- > void setFoo(bool)+--+-- The result is wrapped in a 'CEProp'.  For an unwrapped value, use+-- 'mkBoolHasProp_'.+mkBoolHasProp :: String -> ClassEntity+mkBoolHasProp = CEProp . mkBoolHasProp_++-- | The unwrapped version of 'mkBoolHasProp'.+mkBoolHasProp_ :: String -> Prop+mkBoolHasProp_ name =+  let c:cs = name+      name' = toUpper c : cs+      hasName = 'h':'a':'s':name'+      setName = 's':'e':'t':name'+  in Prop [ mkConstMethod_ hasName [] Internal_TBool+          , mkMethod_ setName [Internal_TBool] Internal_TVoid+          ]++-- | A non-C++ function that can be invoked via a C++ functor or function+-- pointer.+data Callback = Callback+  { callbackExtName :: ExtName+    -- ^ The callback's external name.+  , callbackParams :: [Type]+    -- ^ The callback's parameter types.+  , callbackReturn :: Type+    -- ^ The callback's return type.+  , callbackThrows :: Maybe Bool+    -- ^ Whether the callback supports throwing C++ exceptions from Haskell into+    -- C++ during its execution.  When absent, the value is inherited from+    -- 'moduleCallbacksThrow' and 'interfaceCallbacksThrow'.+  , callbackReqs :: Reqs+    -- ^ Requirements for the callback.+  , callbackAddendum :: Addendum+    -- ^ The callback's addendum.+  }++instance Eq Callback where+  (==) = (==) `on` callbackExtName++instance Show Callback where+  show cb =+    concat ["<Callback ", show (callbackExtName cb), " ", show (callbackParams cb), " ",+            show (callbackReturn cb)]++instance HasExtNames Callback where+  getPrimaryExtName = callbackExtName++instance HasReqs Callback where+  getReqs = callbackReqs+  setReqs reqs cb = cb { callbackReqs = reqs }++instance HasAddendum Callback where+  getAddendum = callbackAddendum+  setAddendum addendum cb = cb { callbackAddendum = addendum }++-- | Creates a binding for constructing callbacks into foreign code.+makeCallback :: ExtName+             -> [Type]  -- ^ Parameter types.+             -> Type  -- ^ Return type.+             -> Callback+makeCallback extName paramTypes retType =+  Callback extName paramTypes retType Nothing mempty mempty++-- | Sets whether a callback supports handling thrown C++ exceptions and passing+-- them into C++.+callbackSetThrows :: Bool -> Callback -> Callback+callbackSetThrows value cb = cb { callbackThrows = Just value }++-- | Each exception class has a unique exception ID.+newtype ExceptionId = ExceptionId+  { getExceptionId :: Int  -- ^ Internal.+  } deriving (Eq, Show)++-- | The exception ID that represents the catch-all type.+exceptionCatchAllId :: ExceptionId+exceptionCatchAllId = ExceptionId 1++-- | The lowest exception ID to be used for classes.+exceptionFirstFreeId :: Int+exceptionFirstFreeId = getExceptionId exceptionCatchAllId + 1++-- | Indicates the ability to handle a certain type of C++ exception.+data ExceptionHandler =+    CatchClass Class+    -- ^ Indicates that instances of the given class are handled (including+    -- derived types).+  | CatchAll+    -- ^ Indicates that all C++ exceptions are handled, i.e. @catch (...)@.+  deriving (Eq, Ord)++-- | Represents a list of exception handlers to be used for a body of code.+-- Order is important; a 'CatchAll' will prevent all subsequent handlers from+-- being invoked.+data ExceptionHandlers = ExceptionHandlers+  { exceptionHandlersList :: [ExceptionHandler]+    -- ^ Extracts the list of exception handlers.+  }++instance Monoid ExceptionHandlers where+  mempty = ExceptionHandlers []++  mappend e1 e2 =+    ExceptionHandlers+    (S.toList $ S.fromList $ exceptionHandlersList e1 ++ exceptionHandlersList e2)++-- | Types that can handle exceptions.+class HandlesExceptions a where+  -- | Extracts the exception handlers for an object.+  getExceptionHandlers :: a -> ExceptionHandlers++  -- | Modifies an object's exception handlers with a given function.+  modifyExceptionHandlers :: (ExceptionHandlers -> ExceptionHandlers) -> a -> a++-- | Appends additional exception handlers to an object.+handleExceptions :: HandlesExceptions a => [ExceptionHandler] -> a -> a+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).+data Addendum = Addendum+  { addendumHaskell :: Haskell.Generator ()+    -- ^ Code to be output into the Haskell binding.  May also add imports and+    -- exports.+  }++instance Monoid Addendum where+  mempty = Addendum $ return ()+  mappend (Addendum a) (Addendum b) = Addendum $ a >> b++-- | A typeclass for types that have an addendum.+class HasAddendum a where+  {-# MINIMAL getAddendum, (setAddendum | modifyAddendum) #-}++  -- | Returns an object's addendum.+  getAddendum :: a -> Addendum++  -- | Replaces and object's addendum with another.+  setAddendum :: Addendum -> a -> a+  setAddendum addendum = modifyAddendum $ const addendum++  -- | Modified an object's addendum.+  modifyAddendum :: (Addendum -> Addendum) -> a -> a+  modifyAddendum f x = setAddendum (f $ getAddendum x) x++-- | Adds a Haskell addendum to an object.+addAddendumHaskell :: HasAddendum a => Haskell.Generator () -> a -> a+addAddendumHaskell gen = modifyAddendum $ \addendum ->+  addendum `mappend` mempty { addendumHaskell = gen }++-- | Constructor for an import set.+makeHsImportSet :: M.Map HsImportKey HsImportSpecs -> HsImportSet+makeHsImportSet = HsImportSet++-- | Sets all of the import specifications in an import set to be+-- @{-#SOURCE#-}@ imports.+hsImportSetMakeSource :: HsImportSet -> HsImportSet+hsImportSetMakeSource (HsImportSet m) =+  HsImportSet $ M.map (\specs -> specs { hsImportSource = True }) m++-- | A Haskell module name.+type HsModuleName = String++-- | References an occurrence of an import statement, under which bindings can+-- be imported.  Only imported specs under equal 'HsImportKey's may be merged.+data HsImportKey = HsImportKey+  { hsImportModule :: HsModuleName+  , hsImportQualifiedName :: Maybe HsModuleName+  } deriving (Eq, Ord, Show)++-- | A specification of bindings to import from a module.  If 'Nothing', then+-- the entire module is imported.  If @'Just' 'M.empty'@, then only instances+-- are imported.+data HsImportSpecs = HsImportSpecs+  { getHsImportSpecs :: Maybe (M.Map HsImportName HsImportVal)+  , hsImportSource :: Bool+  } deriving (Show)++-- | Combines two 'HsImportSpecs's into one that imports everything that the two+-- did separately.+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++-- | An identifier that can be imported from a module.  Symbols may be used here+-- when surrounded by parentheses.  Examples are @\"fmap\"@ and @\"(++)\"@.+type HsImportName = String++-- | Specifies how a name is imported.+data HsImportVal =+  HsImportVal+  -- ^ The name is imported, and nothing underneath it is.+  | HsImportValSome [HsImportName]+    -- ^ The name is imported, as are specific names underneath it.  This is a+    -- @X (a, b, c)@ import.+  | HsImportValAll+    -- ^ The name is imported, along with all names underneath it.  This is a @X+    -- (..)@ import.+  deriving (Show)++-- | An import for the entire contents of a Haskell module.+hsWholeModuleImport :: HsModuleName -> HsImportSet+hsWholeModuleImport moduleName =+  HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $+  HsImportSpecs Nothing False++-- | A qualified import of a Haskell module.+hsQualifiedImport :: HsModuleName -> HsModuleName -> HsImportSet+hsQualifiedImport moduleName qualifiedName =+  HsImportSet $ M.singleton (HsImportKey moduleName $ Just qualifiedName) $+  HsImportSpecs Nothing False++-- | An import of a single name from a Haskell module.+hsImport1 :: HsModuleName -> HsImportName -> HsImportSet+hsImport1 moduleName valueName = hsImport1' moduleName valueName HsImportVal++-- | A detailed import of a single name from a Haskell module.+hsImport1' :: HsModuleName -> HsImportName -> HsImportVal -> HsImportSet+hsImport1' moduleName valueName valueType =+  HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $+  HsImportSpecs (Just $ M.singleton valueName valueType) False++-- | An import of multiple names from a Haskell module.+hsImports :: HsModuleName -> [HsImportName] -> HsImportSet+hsImports moduleName names =+  hsImports' moduleName $ map (\name -> (name, HsImportVal)) names++-- | A detailed import of multiple names from a Haskell module.+hsImports' :: HsModuleName -> [(HsImportName, HsImportVal)] -> HsImportSet+hsImports' moduleName values =+  HsImportSet $ M.singleton (HsImportKey moduleName Nothing) $+  HsImportSpecs (Just $ M.fromList values) False++-- | Imports "Data.Bits" qualified as @HoppyDB@.+hsImportForBits :: HsImportSet+hsImportForBits = hsQualifiedImport "Data.Bits" "HoppyDB"++-- | Imports "Control.Exception" qualified as @HoppyCE@.+hsImportForException :: HsImportSet+hsImportForException = hsQualifiedImport "Control.Exception" "HoppyCE"++-- | Imports "Data.Int" qualified as @HoppyDI@.+hsImportForInt :: HsImportSet+hsImportForInt = hsQualifiedImport "Data.Int" "HoppyDI"++-- | Imports "Data.Word" qualified as @HoppyDW@.+hsImportForWord :: HsImportSet+hsImportForWord = hsQualifiedImport "Data.Word" "HoppyDW"++-- | Imports "Foreign" qualified as @HoppyF@.+hsImportForForeign :: HsImportSet+hsImportForForeign = hsQualifiedImport "Foreign" "HoppyF"++-- | Imports "Foreign.C" qualified as @HoppyFC@.+hsImportForForeignC :: HsImportSet+hsImportForForeignC = hsQualifiedImport "Foreign.C" "HoppyFC"++-- | Imports "Data.Map" qualified as @HoppyDM@.+hsImportForMap :: HsImportSet+hsImportForMap = hsQualifiedImport "Data.Map" "HoppyDM"++-- | Imports "Prelude" qualified as @HoppyP@.+hsImportForPrelude :: HsImportSet+hsImportForPrelude = hsQualifiedImport "Prelude" "HoppyP"++-- | Imports "Foreign.Hoppy.Runtime" qualified as @HoppyFHR@.+hsImportForRuntime :: HsImportSet+hsImportForRuntime = hsQualifiedImport "Foreign.Hoppy.Runtime" "HoppyFHR"++-- | Imports "System.Posix.Types" qualified as @HoppySPT@.+hsImportForSystemPosixTypes :: HsImportSet+hsImportForSystemPosixTypes = hsQualifiedImport "System.Posix.Types" "HoppySPT"++-- | Imports "Data.Typeable" qualified as @HoppyDT@.+hsImportForTypeable :: HsImportSet+hsImportForTypeable = hsQualifiedImport "Data.Typeable" "HoppyDT"++-- | Imports "System.IO.Unsafe" qualified as @HoppySIU@.+hsImportForUnsafeIO :: HsImportSet+hsImportForUnsafeIO = hsQualifiedImport "System.IO.Unsafe" "HoppySIU"++-- | Returns an error message indicating that+-- 'Foreign.Hoppy.Generator.Types.objToHeapT' is used where data is going from a+-- foreign language into C++.+objToHeapTWrongDirectionErrorMsg :: Maybe String -> Class -> String+objToHeapTWrongDirectionErrorMsg maybeCaller cls =+  concat [maybe "" (++ ": ") maybeCaller,+          "(TObjToHeap ", show cls, ") cannot be passed into C++",+          maybe "" (const ".") maybeCaller]++-- | Returns an error message indicating that+-- 'Foreign.Hoppy.Generator.Types.objToHeapT' is used where data is going from a+-- foreign language into C++.+tToGcInvalidFormErrorMessage :: Maybe String -> Type -> String+tToGcInvalidFormErrorMessage maybeCaller typeArg =+  concat [maybe "" (++ ": ") maybeCaller,+          "(", show (Internal_TToGc typeArg), ") is an invalid form for TToGc.",+          maybe "" (const ".") maybeCaller]++-- | Returns an error message indicating that+-- 'Foreign.Hoppy.Generator.Types.toGcT' is used where data is going from a+-- foreign language into C++.+toGcTWrongDirectionErrorMsg :: Maybe String -> Type -> String+toGcTWrongDirectionErrorMsg maybeCaller typeArg =+  concat [maybe "" (++ ": ") maybeCaller,+          "(", show (Internal_TToGc typeArg), ") cannot be passed into C++",+          maybe "" (const ".") maybeCaller]