-- This file is part of Hoppy.
--
-- Copyright 2015-2024 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, 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.Language.Haskell
import System.FilePath ((<.>), pathSeparator)

-- | The in-memory result of generating Haskell code for an interface.
newtype Generation = Generation
  { Generation -> Map ErrorMsg ErrorMsg
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 -> ComputedInterfaceData -> Either ErrorMsg Generation
generate :: Interface -> ComputedInterfaceData -> Either ErrorMsg Generation
generate Interface
iface ComputedInterfaceData
computed = do
  -- Build the partial generation of each module.
  [(Module, Partial)]
modPartials <- [Module]
-> (Module -> Either ErrorMsg (Module, Partial))
-> Either ErrorMsg [(Module, Partial)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map ErrorMsg Module -> [Module]
forall k a. Map k a -> [a]
M.elems (Map ErrorMsg Module -> [Module])
-> Map ErrorMsg Module -> [Module]
forall a b. (a -> b) -> a -> b
$ Interface -> Map ErrorMsg Module
interfaceModules Interface
iface) ((Module -> Either ErrorMsg (Module, Partial))
 -> Either ErrorMsg [(Module, Partial)])
-> (Module -> Either ErrorMsg (Module, Partial))
-> Either ErrorMsg [(Module, Partial)]
forall a b. (a -> b) -> a -> b
$ \Module
m ->
    (,) Module
m (Partial -> (Module, Partial))
-> Either ErrorMsg Partial -> Either ErrorMsg (Module, Partial)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interface
-> ComputedInterfaceData
-> Module
-> Generator ()
-> Either ErrorMsg Partial
forall a.
Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either ErrorMsg Partial
execGenerator Interface
iface ComputedInterfaceData
computed Module
m (Module -> Generator ()
generateSource Module
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 :: Map ErrorMsg Partial
partialsByHsName = [(ErrorMsg, Partial)] -> Map ErrorMsg Partial
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ErrorMsg, Partial)] -> Map ErrorMsg Partial)
-> [(ErrorMsg, Partial)] -> Map ErrorMsg Partial
forall a b. (a -> b) -> a -> b
$ ((Module, Partial) -> (ErrorMsg, Partial))
-> [(Module, Partial)] -> [(ErrorMsg, Partial)]
forall a b. (a -> b) -> [a] -> [b]
map ((Partial -> ErrorMsg
partialModuleHsName (Partial -> ErrorMsg)
-> (Partial -> Partial) -> Partial -> (ErrorMsg, Partial)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Partial -> Partial
forall a. a -> a
id) (Partial -> (ErrorMsg, Partial))
-> ((Module, Partial) -> Partial)
-> (Module, Partial)
-> (ErrorMsg, Partial)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module, Partial) -> Partial
forall a b. (a, b) -> b
snd) [(Module, Partial)]
modPartials

      sccInput :: [((Module, Partial), Partial, [Partial])]
      sccInput :: [((Module, Partial), Partial, [Partial])]
sccInput = [(Module, Partial)]
-> ((Module, Partial) -> ((Module, Partial), Partial, [Partial]))
-> [((Module, Partial), Partial, [Partial])]
forall a b. [a] -> (a -> b) -> [b]
for [(Module, Partial)]
modPartials (((Module, Partial) -> ((Module, Partial), Partial, [Partial]))
 -> [((Module, Partial), Partial, [Partial])])
-> ((Module, Partial) -> ((Module, Partial), Partial, [Partial]))
-> [((Module, Partial), Partial, [Partial])]
forall a b. (a -> b) -> a -> b
$ \x :: (Module, Partial)
x@(Module
_, Partial
p) ->
        ((Module, Partial)
x, Partial
p,
         (HsImportKey -> Maybe Partial) -> [HsImportKey] -> [Partial]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((ErrorMsg -> Map ErrorMsg Partial -> Maybe Partial)
-> Map ErrorMsg Partial -> ErrorMsg -> Maybe Partial
forall a b c. (a -> b -> c) -> b -> a -> c
flip ErrorMsg -> Map ErrorMsg Partial -> Maybe Partial
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map ErrorMsg Partial
partialsByHsName (ErrorMsg -> Maybe Partial)
-> (HsImportKey -> ErrorMsg) -> HsImportKey -> Maybe Partial
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsImportKey -> ErrorMsg
hsImportModule) ([HsImportKey] -> [Partial]) -> [HsImportKey] -> [Partial]
forall a b. (a -> b) -> a -> b
$
         Map HsImportKey HsImportSpecs -> [HsImportKey]
forall k a. Map k a -> [k]
M.keys (Map HsImportKey HsImportSpecs -> [HsImportKey])
-> Map HsImportKey HsImportSpecs -> [HsImportKey]
forall a b. (a -> b) -> a -> b
$ HsImportSet -> Map HsImportKey HsImportSpecs
getHsImportSet (HsImportSet -> Map HsImportKey HsImportSpecs)
-> HsImportSet -> Map HsImportKey HsImportSpecs
forall a b. (a -> b) -> a -> b
$ Output -> HsImportSet
outputImports (Output -> HsImportSet) -> Output -> HsImportSet
forall a b. (a -> b) -> a -> b
$ Partial -> Output
partialOutput Partial
p)

      sccs :: [SCC (Module, Partial)]
      sccs :: [SCC (Module, Partial)]
sccs = [((Module, Partial), Partial, [Partial])]
-> [SCC (Module, Partial)]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [((Module, Partial), Partial, [Partial])]
sccInput

  [(ErrorMsg, ErrorMsg)]
fileContents <- WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
-> Either ErrorMsg [(ErrorMsg, ErrorMsg)]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
 -> Either ErrorMsg [(ErrorMsg, ErrorMsg)])
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
-> Either ErrorMsg [(ErrorMsg, ErrorMsg)]
forall a b. (a -> b) -> a -> b
$ [SCC (Module, Partial)]
-> (SCC (Module, Partial)
    -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SCC (Module, Partial)]
sccs ((SCC (Module, Partial)
  -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
 -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
-> (SCC (Module, Partial)
    -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
forall a b. (a -> b) -> a -> b
$ \case
    AcyclicSCC (Module
_, Partial
p) -> [(ErrorMsg, ErrorMsg)]
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Partial -> ErrorMsg -> (ErrorMsg, ErrorMsg)
finishPartial Partial
p ErrorMsg
"hs"]
    CyclicSCC [(Module, Partial)]
mps -> do
      let cycleModNames :: Set ErrorMsg
cycleModNames = [ErrorMsg] -> Set ErrorMsg
forall a. Ord a => [a] -> Set a
S.fromList ([ErrorMsg] -> Set ErrorMsg) -> [ErrorMsg] -> Set ErrorMsg
forall a b. (a -> b) -> a -> b
$ ((Module, Partial) -> ErrorMsg)
-> [(Module, Partial)] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (Partial -> ErrorMsg
partialModuleHsName (Partial -> ErrorMsg)
-> ((Module, Partial) -> Partial) -> (Module, Partial) -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module, Partial) -> Partial
forall a b. (a, b) -> b
snd) [(Module, Partial)]
mps
      [(Module, Partial)]
-> ((Module, Partial)
    -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Module, Partial)]
mps (((Module, Partial)
  -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
 -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
-> ((Module, Partial)
    -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
forall a b. (a -> b) -> a -> b
$ \(Module
m, Partial
p) -> do
        -- Create a boot partial.
        Partial
pBoot <- Either ErrorMsg Partial
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) Partial
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [(ErrorMsg, ErrorMsg)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either ErrorMsg Partial
 -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) Partial)
-> Either ErrorMsg Partial
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) Partial
forall a b. (a -> b) -> a -> b
$ Interface
-> ComputedInterfaceData
-> Module
-> Generator ()
-> Either ErrorMsg Partial
forall a.
Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either ErrorMsg Partial
execGenerator Interface
iface ComputedInterfaceData
computed Module
m (Module -> Generator ()
generateBootSource Module
m)

        -- Change the source and boot partials so that all imports of modules in
        -- this cycle are {-# SOURCE #-} imports.
        let p' :: Partial
p' = Set ErrorMsg -> Partial -> Partial
setSourceImports Set ErrorMsg
cycleModNames Partial
p
            pBoot' :: Partial
pBoot' = Set ErrorMsg -> Partial -> Partial
setSourceImports Set ErrorMsg
cycleModNames Partial
pBoot

        -- Emit the completed partials.
        [(ErrorMsg, ErrorMsg)]
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Partial -> ErrorMsg -> (ErrorMsg, ErrorMsg)
finishPartial Partial
p' ErrorMsg
"hs", Partial -> ErrorMsg -> (ErrorMsg, ErrorMsg)
finishPartial Partial
pBoot' ErrorMsg
"hs-boot"]

  Generation -> Either ErrorMsg Generation
forall a. a -> Either ErrorMsg a
forall (m :: * -> *) a. Monad m => a -> m a
return (Generation -> Either ErrorMsg Generation)
-> Generation -> Either ErrorMsg Generation
forall a b. (a -> b) -> a -> b
$ Map ErrorMsg ErrorMsg -> Generation
Generation (Map ErrorMsg ErrorMsg -> Generation)
-> Map ErrorMsg ErrorMsg -> Generation
forall a b. (a -> b) -> a -> b
$ [(ErrorMsg, ErrorMsg)] -> Map ErrorMsg ErrorMsg
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(ErrorMsg, ErrorMsg)]
fileContents

  where finishPartial :: Partial -> String -> (FilePath, String)
        finishPartial :: Partial -> ErrorMsg -> (ErrorMsg, ErrorMsg)
finishPartial Partial
p ErrorMsg
fileExt =
          (Char -> Char -> ErrorMsg -> ErrorMsg
forall a. Eq a => a -> a -> [a] -> [a]
listSubst Char
'.' Char
pathSeparator (Partial -> ErrorMsg
partialModuleHsName Partial
p) ErrorMsg -> ErrorMsg -> ErrorMsg
<.> ErrorMsg
fileExt,
           ErrorMsg -> ErrorMsg
prependExtensions (ErrorMsg -> ErrorMsg) -> ErrorMsg -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Partial -> ErrorMsg
renderPartial Partial
p)

        setSourceImports :: S.Set HsModuleName -> Partial -> Partial
        setSourceImports :: Set ErrorMsg -> Partial -> Partial
setSourceImports Set ErrorMsg
modulesToSourceImport Partial
p =
          let output :: Output
output = Partial -> Output
partialOutput Partial
p
              imports :: HsImportSet
imports = Output -> HsImportSet
outputImports Output
output
              imports' :: HsImportSet
imports' = Map HsImportKey HsImportSpecs -> HsImportSet
makeHsImportSet (Map HsImportKey HsImportSpecs -> HsImportSet)
-> Map HsImportKey HsImportSpecs -> HsImportSet
forall a b. (a -> b) -> a -> b
$
                         (HsImportKey -> HsImportSpecs -> HsImportSpecs)
-> Map HsImportKey HsImportSpecs -> Map HsImportKey HsImportSpecs
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey (Set ErrorMsg -> HsImportKey -> HsImportSpecs -> HsImportSpecs
setSourceImportIfIn Set ErrorMsg
modulesToSourceImport) (Map HsImportKey HsImportSpecs -> Map HsImportKey HsImportSpecs)
-> Map HsImportKey HsImportSpecs -> Map HsImportKey HsImportSpecs
forall a b. (a -> b) -> a -> b
$
                         HsImportSet -> Map HsImportKey HsImportSpecs
getHsImportSet HsImportSet
imports
              output' :: Output
output' = Output
output { outputImports = imports' }
          in Partial
p { partialOutput = output' }

        setSourceImportIfIn :: S.Set HsModuleName -> HsImportKey -> HsImportSpecs -> HsImportSpecs
        setSourceImportIfIn :: Set ErrorMsg -> HsImportKey -> HsImportSpecs -> HsImportSpecs
setSourceImportIfIn Set ErrorMsg
modulesToSourceImport HsImportKey
key HsImportSpecs
specs =
          if HsImportKey -> ErrorMsg
hsImportModule HsImportKey
key ErrorMsg -> Set ErrorMsg -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set ErrorMsg
modulesToSourceImport
          then HsImportSpecs
specs { hsImportSource = True }
          else HsImportSpecs
specs

prependExtensions :: String -> String
prependExtensions :: ErrorMsg -> ErrorMsg
prependExtensions = (ErrorMsg
prependExtensionsPrefix ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++)

prependExtensionsPrefix :: String
prependExtensionsPrefix :: ErrorMsg
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).
  [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ErrorMsg] -> ErrorMsg) -> [ErrorMsg] -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"{-# LANGUAGE " ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
intersperse ErrorMsg
", " [ErrorMsg]
extensions [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg
" #-}\n"]
  where extensions :: [ErrorMsg]
extensions =
          [ ErrorMsg
"FlexibleContexts"
          , ErrorMsg
"FlexibleInstances"
          , ErrorMsg
"ForeignFunctionInterface"
          , ErrorMsg
"MonoLocalBinds"
          , ErrorMsg
"MultiParamTypeClasses"
          , ErrorMsg
"ScopedTypeVariables"
          , ErrorMsg
"TypeSynonymInstances"
          , ErrorMsg
"UndecidableInstances"
          ]

generateSource :: Module -> Generator ()
generateSource :: Module -> Generator ()
generateSource Module
m = do
  Map ExtName Export -> (Export -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Module -> Map ExtName Export
moduleExports Module
m) ((Export -> Generator ()) -> Generator ())
-> (Export -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ SayExportMode -> Export -> Generator ()
sayExport SayExportMode
SayExportForeignImports
  Map ExtName Export -> (Export -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Module -> Map ExtName Export
moduleExports Module
m) ((Export -> Generator ()) -> Generator ())
-> (Export -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ SayExportMode -> Export -> Generator ()
sayExport SayExportMode
SayExportDecls

  Interface
iface <- Generator Interface
askInterface
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Interface -> Maybe Module
interfaceExceptionSupportModule Interface
iface Maybe Module -> Maybe Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> Maybe Module
forall a. a -> Maybe a
Just Module
m) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    Bool -> Generator ()
sayExceptionSupport Bool
True

  Addendum -> Generator ()
addendumHaskell (Addendum -> Generator ()) -> Addendum -> Generator ()
forall a b. (a -> b) -> a -> b
$ Module -> Addendum
forall a. HasAddendum a => a -> Addendum
getAddendum Module
m

generateBootSource :: Module -> Generator ()
generateBootSource :: Module -> Generator ()
generateBootSource Module
m = do
  Map ExtName Export -> (Export -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Module -> Map ExtName Export
moduleExports Module
m) ((Export -> Generator ()) -> Generator ())
-> (Export -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ SayExportMode -> Export -> Generator ()
sayExport SayExportMode
SayExportBoot

  Interface
iface <- Generator Interface
askInterface
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Interface -> Maybe Module
interfaceExceptionSupportModule Interface
iface Maybe Module -> Maybe Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> Maybe Module
forall a. a -> Maybe a
Just Module
m) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    Bool -> Generator ()
sayExceptionSupport Bool
False

sayExport :: SayExportMode -> Export -> Generator ()
sayExport :: SayExportMode -> Export -> Generator ()
sayExport SayExportMode
mode Export
export = do
  SayExportMode -> Export -> Generator ()
forall a. Exportable a => SayExportMode -> a -> Generator ()
sayExportHaskell SayExportMode
mode Export
export

  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SayExportMode
mode SayExportMode -> SayExportMode -> Bool
forall a. Eq a => a -> a -> Bool
== SayExportMode
SayExportDecls) (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$
    Addendum -> Generator ()
addendumHaskell (Addendum -> Generator ()) -> Addendum -> Generator ()
forall a b. (a -> b) -> a -> b
$ Export -> Addendum
forall a. HasAddendum a => a -> Addendum
getAddendum Export
export

-- | Outputs the @ExceptionDb@ needed by all Haskell gateway functions that deal
-- with exceptions.
sayExceptionSupport :: Bool -> Generator ()
sayExceptionSupport :: Bool -> Generator ()
sayExceptionSupport Bool
doDecls = do
  Interface
iface <- Generator Interface
askInterface
  ErrorMsg -> Generator ()
addExport ErrorMsg
"exceptionDb'"
  HsImportSet -> Generator ()
addImports HsImportSet
hsImportForRuntime
  Generator ()
ln
  ErrorMsg -> Generator ()
sayLn ErrorMsg
"exceptionDb' :: HoppyFHR.ExceptionDb"
  Bool -> Generator () -> Generator ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doDecls (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
    HsImportSet -> Generator ()
addImports (HsImportSet -> Generator ()) -> HsImportSet -> Generator ()
forall a b. (a -> b) -> a -> b
$ [HsImportSet] -> HsImportSet
forall a. Monoid a => [a] -> a
mconcat [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)",
                          HsImportSet
hsImportForMap]
    ErrorMsg -> Generator ()
sayLn ErrorMsg
"exceptionDb' = HoppyFHR.ExceptionDb $ HoppyDM.fromList"
    Generator () -> Generator ()
forall a. Generator a -> Generator a
indent (Generator () -> Generator ()) -> Generator () -> Generator ()
forall a b. (a -> b) -> a -> b
$ do
      let classes :: [Class]
classes = Interface -> [Class]
interfaceAllExceptionClasses Interface
iface
      case [Class]
classes of
        [] -> ErrorMsg -> Generator ()
sayLn ErrorMsg
"[]"
        [Class]
_ -> do
          HsImportSet -> Generator ()
addImports HsImportSet
hsImportForPrelude
          [(Class, Bool)] -> ((Class, Bool) -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Class] -> [Bool] -> [(Class, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Class]
classes (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False)) (((Class, Bool) -> Generator ()) -> Generator ())
-> ((Class, Bool) -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \(Class
cls, Bool
first) -> do
            ExceptionId
exceptionId <-
              ReaderT Env (WriterT Output (Except ErrorMsg)) ExceptionId
-> Maybe ExceptionId
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ExceptionId
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ExceptionId
forall a.
ErrorMsg -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ExceptionId)
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ExceptionId
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"sayExceptionSupport: Internal error, " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++ Class -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Class
cls ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. [a] -> [a] -> [a]
++
                          ErrorMsg
" has no exception ID.") (Maybe ExceptionId
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ExceptionId)
-> Maybe ExceptionId
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ExceptionId
forall a b. (a -> b) -> a -> b
$
              Interface -> Class -> Maybe ExceptionId
interfaceExceptionClassId Interface
iface Class
cls
            ErrorMsg
typeName <- Constness -> Class -> Generator ErrorMsg
toHsDataTypeName Constness
Nonconst Class
cls
            [ErrorMsg] -> Generator ()
saysLn [if Bool
first then ErrorMsg
"[ (" else ErrorMsg
", (",
                    ErrorMsg
"HoppyFHR.ExceptionId ", Int -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Int -> ErrorMsg) -> Int -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ ExceptionId -> Int
getExceptionId ExceptionId
exceptionId,
                    ErrorMsg
", HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ",
                    ErrorMsg
typeName, ErrorMsg
"))"]
          ErrorMsg -> Generator ()
sayLn ErrorMsg
"]"