-- 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 C++ code generator.
module Foreign.Hoppy.Generator.Language.Cpp.Internal (
  Generation,
  generate,
  generatedFiles,
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (when)
import Control.Monad.Writer (execWriterT, tell)
import Control.Monad.Trans (lift)
import Data.Foldable (forM_)
#if !MIN_VERSION_base(4,8,0)
import Data.Functor ((<$))
#endif
import qualified Data.Map as M
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mappend, mconcat, mempty)
#endif
import Foreign.Hoppy.Generator.Common
import Foreign.Hoppy.Generator.Language.Cpp
import Foreign.Hoppy.Generator.Spec
import Foreign.Hoppy.Generator.Types

-- | The in-memory result of generating C++ 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 C++ 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 =
  ([(ErrorMsg, ErrorMsg)] -> Generation)
-> Either ErrorMsg [(ErrorMsg, ErrorMsg)]
-> Either ErrorMsg Generation
forall a b. (a -> b) -> Either ErrorMsg a -> Either ErrorMsg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map ErrorMsg ErrorMsg -> Generation
Generation (Map ErrorMsg ErrorMsg -> Generation)
-> ([(ErrorMsg, ErrorMsg)] -> Map ErrorMsg ErrorMsg)
-> [(ErrorMsg, ErrorMsg)]
-> Generation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ErrorMsg, ErrorMsg)] -> Map ErrorMsg ErrorMsg
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList) (Either ErrorMsg [(ErrorMsg, ErrorMsg)]
 -> Either ErrorMsg Generation)
-> Either ErrorMsg [(ErrorMsg, ErrorMsg)]
-> Either ErrorMsg Generation
forall a b. (a -> b) -> a -> b
$
  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
$
  [Module]
-> (Module -> 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_ (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 -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
 -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
-> (Module -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ())
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
forall a b. (a -> b) -> a -> b
$ \Module
m -> do
    let headerGuard :: ErrorMsg
headerGuard = [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"HOPPY_MODULE_", Interface -> ErrorMsg
interfaceName Interface
iface, ErrorMsg
"_", Module -> ErrorMsg
moduleName Module
m]
    ErrorMsg
header <- Either ErrorMsg ErrorMsg
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ErrorMsg
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 ErrorMsg
 -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ErrorMsg)
-> Either ErrorMsg ErrorMsg
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ErrorMsg
forall a b. (a -> b) -> a -> b
$ Interface
-> ComputedInterfaceData
-> Module
-> Maybe ErrorMsg
-> Generator ()
-> Either ErrorMsg ErrorMsg
forall a.
Interface
-> ComputedInterfaceData
-> Module
-> Maybe ErrorMsg
-> Generator a
-> Either ErrorMsg ErrorMsg
execGenerator Interface
iface ComputedInterfaceData
computed Module
m (ErrorMsg -> Maybe ErrorMsg
forall a. a -> Maybe a
Just ErrorMsg
headerGuard) Generator ()
sayModuleHeader
    [(ErrorMsg, ErrorMsg)]
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Module -> ErrorMsg
moduleHppPath Module
m, ErrorMsg
header)]
    ErrorMsg
source <- Either ErrorMsg ErrorMsg
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ErrorMsg
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 ErrorMsg
 -> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ErrorMsg)
-> Either ErrorMsg ErrorMsg
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ErrorMsg
forall a b. (a -> b) -> a -> b
$ Interface
-> ComputedInterfaceData
-> Module
-> Maybe ErrorMsg
-> Generator ()
-> Either ErrorMsg ErrorMsg
forall a.
Interface
-> ComputedInterfaceData
-> Module
-> Maybe ErrorMsg
-> Generator a
-> Either ErrorMsg ErrorMsg
execGenerator Interface
iface ComputedInterfaceData
computed Module
m Maybe ErrorMsg
forall a. Maybe a
Nothing Generator ()
sayModuleSource
    [(ErrorMsg, ErrorMsg)]
-> WriterT [(ErrorMsg, ErrorMsg)] (Either ErrorMsg) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Module -> ErrorMsg
moduleCppPath Module
m, ErrorMsg
source)]

sayModuleHeader :: Generator ()
sayModuleHeader :: Generator ()
sayModuleHeader = do
  Module
m <- ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Module
forall (m :: * -> *). MonadReader Env m => m Module
askModule
  Reqs -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Reqs -> m ()
addReqsM (Reqs -> Generator ()) -> Reqs -> Generator ()
forall a b. (a -> b) -> a -> b
$ Module -> Reqs
moduleReqs Module
m
  (Export -> Generator ()) -> [Export] -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SayExportMode -> Export -> Generator ()
forall a. Exportable a => SayExportMode -> a -> Generator ()
sayExportCpp SayExportMode
SayHeader) ([Export] -> Generator ()) -> [Export] -> Generator ()
forall a b. (a -> b) -> a -> b
$ Map ExtName Export -> [Export]
forall k a. Map k a -> [a]
M.elems (Map ExtName Export -> [Export]) -> Map ExtName Export -> [Export]
forall a b. (a -> b) -> a -> b
$ Module -> Map ExtName Export
moduleExports Module
m

  Interface
iface <- ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Interface
forall (m :: * -> *). MonadReader Env m => m 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

sayModuleSource :: Generator ()
sayModuleSource :: Generator ()
sayModuleSource = do
  Module
m <- ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Module
forall (m :: * -> *). MonadReader Env m => m Module
askModule
  Include -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Include -> m ()
addInclude (Include -> Generator ()) -> Include -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Include
includeLocal (ErrorMsg -> Include) -> ErrorMsg -> Include
forall a b. (a -> b) -> a -> b
$ Module -> ErrorMsg
moduleHppPath Module
m
  (Export -> Generator ()) -> [Export] -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SayExportMode -> Export -> Generator ()
forall a. Exportable a => SayExportMode -> a -> Generator ()
sayExportCpp SayExportMode
SaySource) ([Export] -> Generator ()) -> [Export] -> Generator ()
forall a b. (a -> b) -> a -> b
$ Map ExtName Export -> [Export]
forall k a. Map k a -> [a]
M.elems (Map ExtName Export -> [Export]) -> Map ExtName Export -> [Export]
forall a b. (a -> b) -> a -> b
$ Module -> Map ExtName Export
moduleExports Module
m

  Interface
iface <- ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Interface
forall (m :: * -> *). MonadReader Env m => m 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

-- | Outputs interface-wide code needed to support exceptions.  Currently, this
-- comprises the function for rethrowing in C++ an exception transferred from
-- a foreign language.
sayExceptionSupport :: Bool -> Generator ()
sayExceptionSupport :: Bool -> Generator ()
sayExceptionSupport Bool
sayBody =
  ErrorMsg
-> [ErrorMsg] -> Type -> Maybe (Generator ()) -> Generator ()
sayFunction ErrorMsg
exceptionRethrowFnName
              [ErrorMsg
"excId", ErrorMsg
"voidPtr"]
              ([Type] -> Type -> Type
fnT [Type
intT, Type -> Type
ptrT Type
voidT] Type
voidT) (Maybe (Generator ()) -> Generator ())
-> Maybe (Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$
  if Bool -> Bool
not Bool
sayBody
  then Maybe (Generator ())
forall a. Maybe a
Nothing
  else Generator () -> Maybe (Generator ())
forall a. a -> Maybe a
Just (Generator () -> Maybe (Generator ()))
-> Generator () -> Maybe (Generator ())
forall a b. (a -> b) -> a -> b
$ do
    Interface
iface <- ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Interface
forall (m :: * -> *). MonadReader Env m => m Interface
askInterface
    let excClasses :: [Class]
excClasses = Interface -> [Class]
interfaceAllExceptionClasses Interface
iface

    [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
says [ErrorMsg
"switch (excId) {\n"]

    [Class] -> (Class -> Generator ()) -> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Class]
excClasses ((Class -> Generator ()) -> Generator ())
-> (Class -> Generator ()) -> Generator ()
forall a b. (a -> b) -> a -> b
$ \Class
cls -> do
      Int
excId <- (ExceptionId -> Int)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Int
forall a b.
(a -> b)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExceptionId -> Int
getExceptionId (ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
 -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Int)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Int
forall a b. (a -> b) -> a -> b
$
               ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
-> Maybe ExceptionId
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (ErrorMsg
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
forall a. ErrorMsg -> Generator a
abort (ErrorMsg
 -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId)
-> ErrorMsg
-> ReaderT Env (WriterT [Chunk] (Either 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
"should have an exception ID, but doesn't.") (Maybe ExceptionId
 -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId)
-> Maybe ExceptionId
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) ExceptionId
forall a b. (a -> b) -> a -> b
$
               Interface -> Class -> Maybe ExceptionId
interfaceExceptionClassId Interface
iface Class
cls
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
says [ErrorMsg
"case ", Int -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Int
excId, ErrorMsg
": {\n"]
      ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
sayVar ErrorMsg
"excPtr" Maybe [ErrorMsg]
forall a. Maybe a
Nothing (Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
say ErrorMsg
" = reinterpret_cast<" Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
        Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [ErrorMsg] -> Type -> m ()
sayType Maybe [ErrorMsg]
forall a. Maybe a
Nothing (Type -> Type
ptrT (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Class -> Type
objT Class
cls) Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
says [ErrorMsg
">(voidPtr);\n"]
      ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
sayVar ErrorMsg
"exc" Maybe [ErrorMsg]
forall a. Maybe a
Nothing (Class -> Type
objT Class
cls) Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
say ErrorMsg
" = *excPtr;\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
say ErrorMsg
"delete excPtr;\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
say ErrorMsg
"throw exc;\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
say ErrorMsg
"}\n"

    ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
say ErrorMsg
"}\n"
    [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
says [ErrorMsg
"throw \"Internal Hoppy error, ", ErrorMsg
exceptionRethrowFnName,
          ErrorMsg
" got an unknown exception ID.\";\n"]