-- This file is part of Hoppy.
--
-- Copyright 2015-2018 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 #-}

-- | Internal portion of the Haskell code generator.
module Foreign.Hoppy.Generator.Language.Haskell.Internal (
  Generation,
  generate,
  generatedFiles,
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>), pure)
#endif
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" (overlapping instances are used here too).
  --
  -- GeneralizedNewtypeDeriving is to enable automatic deriving of
  -- Data.Bits.Bits instances for bitspace newtypes.
  concat $ "{-# LANGUAGE " : intersperse ", " extensions ++ [" #-}\n"]
  where extensions =
          [ "FlexibleContexts"
          , "FlexibleInstances"
          , "ForeignFunctionInterface"
          , "GeneralizedNewtypeDeriving"
          , "MonoLocalBinds"
          , "MultiParamTypeClasses"
          , "ScopedTypeVariables"
          , "TypeSynonymInstances"
          , "UndecidableInstances"
          ]

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]
      when (hsHsNumType /= hsCNumType) $ do
        saysLn ["instance ", className, " (", prettyPrint hsHsNumType, ") where"]
        indent $ saysLn [toFnName, " = ", hsTypeName, " . HoppyFHR.coerceIntegral"]
      saysLn ["instance ", className, " ", hsTypeName, " where"]
      indent $ saysLn [toFnName, " = HoppyP.id"]

      -- 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, ")"]
      when (hsHsNumType /= 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'

        exceptionHandling <-
          if catches
          then do iface <- askInterface
                  currentModule <- askModule
                  let exceptionSupportModule = interfaceExceptionSupportModule iface
                  when (exceptionSupportModule /= Just currentModule) $
                    addImports . hsWholeModuleImport . getModuleName iface =<<
                    fromMaybeM (throwError
                                "Internal error, an exception support module is not available")
                    exceptionSupportModule
                  addImports $ mconcat [hsImport1 "Prelude" "($)", hsImportForRuntime]
                  return "HoppyFHR.internalHandleExceptions exceptionDb' $"
          else return ""

        let callWords = exceptionHandling : 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]

        -- Generate the *_newFunPtr function.
        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'

        -- Generate the *_new function.
        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]
        ctorName <-
          maybe (throwError $ tToGcInvalidFormErrorMessage Nothing t')
                (toHsDataCtorName Unmanaged Nonconst) $
          case stripConst t' of
            Internal_TObj cls -> Just cls
            Internal_TRef (Internal_TConst (Internal_TObj cls)) -> Just cls
            Internal_TRef (Internal_TObj cls) -> Just cls
            Internal_TPtr (Internal_TConst (Internal_TObj cls)) -> Just cls
            Internal_TPtr (Internal_TObj cls) -> Just cls
            _ -> Nothing
        saysLn ["HoppyFHR.toGc (", ctorName, " ", 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 ["instance {-# OVERLAPPABLE #-} ", hsPtrClassName, " a => ", hsValueClassName, " a",
            if doDecls then " where" else ""]
    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 ["instance {-# OVERLAPPING #-} ", hsValueClassName, " (", prettyPrint hsType, ")",
                if doDecls then " where" else ""]
        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') $ \(to, from) ->
                      -- We're upcasting, so 'from' is the subclass.
                      toHsCastPrimitiveName from from to
                    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 higher 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