-- This file is part of Hoppy.
--
-- Copyright 2015-2021 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 FilePath FilePath
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 FilePath Generation
generate Interface
iface ComputedInterfaceData
computed = do
  -- Build the partial generation of each module.
  [(Module, Partial)]
modPartials <- [Module]
-> (Module -> Either FilePath (Module, Partial))
-> Either FilePath [(Module, Partial)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map FilePath Module -> [Module]
forall k a. Map k a -> [a]
M.elems (Map FilePath Module -> [Module])
-> Map FilePath Module -> [Module]
forall a b. (a -> b) -> a -> b
$ Interface -> Map FilePath Module
interfaceModules Interface
iface) ((Module -> Either FilePath (Module, Partial))
 -> Either FilePath [(Module, Partial)])
-> (Module -> Either FilePath (Module, Partial))
-> Either FilePath [(Module, Partial)]
forall a b. (a -> b) -> a -> b
$ \Module
m ->
    (,) Module
m (Partial -> (Module, Partial))
-> Either FilePath Partial -> Either FilePath (Module, Partial)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interface
-> ComputedInterfaceData
-> Module
-> Generator ()
-> Either FilePath Partial
forall a.
Interface
-> ComputedInterfaceData
-> Module
-> Generator a
-> Either FilePath 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 FilePath Partial
partialsByHsName = [(FilePath, Partial)] -> Map FilePath Partial
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(FilePath, Partial)] -> Map FilePath Partial)
-> [(FilePath, Partial)] -> Map FilePath Partial
forall a b. (a -> b) -> a -> b
$ ((Module, Partial) -> (FilePath, Partial))
-> [(Module, Partial)] -> [(FilePath, Partial)]
forall a b. (a -> b) -> [a] -> [b]
map ((Partial -> FilePath
partialModuleHsName (Partial -> FilePath)
-> (Partial -> Partial) -> Partial -> (FilePath, Partial)
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 -> (FilePath, Partial))
-> ((Module, Partial) -> Partial)
-> (Module, Partial)
-> (FilePath, 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 ((FilePath -> Map FilePath Partial -> Maybe Partial)
-> Map FilePath Partial -> FilePath -> Maybe Partial
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> Map FilePath Partial -> Maybe Partial
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map FilePath Partial
partialsByHsName (FilePath -> Maybe Partial)
-> (HsImportKey -> FilePath) -> HsImportKey -> Maybe Partial
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsImportKey -> FilePath
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

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

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

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

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

        setSourceImports :: S.Set HsModuleName -> Partial -> Partial
        setSourceImports :: Set FilePath -> Partial -> Partial
setSourceImports Set FilePath
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 FilePath -> HsImportKey -> HsImportSpecs -> HsImportSpecs
setSourceImportIfIn Set FilePath
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 :: HsImportSet
outputImports = HsImportSet
imports' }
          in Partial
p { partialOutput :: Output
partialOutput = Output
output' }

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

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

prependExtensionsPrefix :: String
prependExtensionsPrefix :: FilePath
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).
  [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"{-# LANGUAGE " FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
intersperse FilePath
", " [FilePath]
extensions [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
" #-}\n"]
  where extensions :: [FilePath]
extensions =
          [ FilePath
"FlexibleContexts"
          , FilePath
"FlexibleInstances"
          , FilePath
"ForeignFunctionInterface"
          , FilePath
"MonoLocalBinds"
          , FilePath
"MultiParamTypeClasses"
          , FilePath
"ScopedTypeVariables"
          , FilePath
"TypeSynonymInstances"
          , FilePath
"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
  FilePath -> Generator ()
addExport FilePath
"exceptionDb'"
  HsImportSet -> Generator ()
addImports HsImportSet
hsImportForRuntime
  Generator ()
ln
  FilePath -> Generator ()
sayLn FilePath
"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 [FilePath -> FilePath -> HsImportSet
hsImport1 FilePath
"Prelude" FilePath
"($)",
                          HsImportSet
hsImportForMap]
    FilePath -> Generator ()
sayLn FilePath
"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
        [] -> FilePath -> Generator ()
sayLn FilePath
"[]"
        [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 FilePath)) ExceptionId
-> Maybe ExceptionId
-> ReaderT Env (WriterT Output (Except FilePath)) ExceptionId
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (FilePath
-> ReaderT Env (WriterT Output (Except FilePath)) ExceptionId
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FilePath
 -> ReaderT Env (WriterT Output (Except FilePath)) ExceptionId)
-> FilePath
-> ReaderT Env (WriterT Output (Except FilePath)) ExceptionId
forall a b. (a -> b) -> a -> b
$ FilePath
"sayExceptionSupport: Internal error, " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Class -> FilePath
forall a. Show a => a -> FilePath
show Class
cls FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                          FilePath
" has no exception ID.") (Maybe ExceptionId
 -> ReaderT Env (WriterT Output (Except FilePath)) ExceptionId)
-> Maybe ExceptionId
-> ReaderT Env (WriterT Output (Except FilePath)) ExceptionId
forall a b. (a -> b) -> a -> b
$
              Interface -> Class -> Maybe ExceptionId
interfaceExceptionClassId Interface
iface Class
cls
            FilePath
typeName <- Constness -> Class -> Generator FilePath
toHsDataTypeName Constness
Nonconst Class
cls
            [FilePath] -> Generator ()
saysLn [if Bool
first then FilePath
"[ (" else FilePath
", (",
                    FilePath
"HoppyFHR.ExceptionId ", Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ ExceptionId -> Int
getExceptionId ExceptionId
exceptionId,
                    FilePath
", HoppyFHR.cppExceptionInfo (HoppyP.undefined :: ",
                    FilePath
typeName, FilePath
"))"]
          FilePath -> Generator ()
sayLn FilePath
"]"