-- | Foreign export stubs
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Types.ForeignStubs
   ( ForeignStubs (..)
   , CHeader(..)
   , CStub(..)
   , initializerCStub
   , finalizerCStub
   , appendStubC
   )
where

import {-# SOURCE #-} GHC.Cmm.CLabel

import GHC.Platform
import GHC.Utils.Outputable
import Data.List ((++))
import Data.Monoid
import Data.Semigroup
import Data.Coerce

data CStub = CStub { CStub -> SDoc
getCStub :: SDoc
                   , CStub -> [CLabel]
getInitializers :: [CLabel]
                     -- ^ Initializers to be run at startup
                     -- See Note [Initializers and finalizers in Cmm] in
                     -- "GHC.Cmm.InitFini".
                   , CStub -> [CLabel]
getFinalizers :: [CLabel]
                     -- ^ Finalizers to be run at shutdown
                   }

emptyCStub :: CStub
emptyCStub :: CStub
emptyCStub = SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
forall doc. IsOutput doc => doc
empty [] []

instance Monoid CStub where
  mempty :: CStub
mempty = CStub
emptyCStub

instance Semigroup CStub where
  CStub SDoc
a0 [CLabel]
b0 [CLabel]
c0 <> :: CStub -> CStub -> CStub
<> CStub SDoc
a1 [CLabel]
b1 [CLabel]
c1 =
      SDoc -> [CLabel] -> [CLabel] -> CStub
CStub (SDoc
a0 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
a1) ([CLabel]
b0 [CLabel] -> [CLabel] -> [CLabel]
forall a. [a] -> [a] -> [a]
++ [CLabel]
b1) ([CLabel]
c0 [CLabel] -> [CLabel] -> [CLabel]
forall a. [a] -> [a] -> [a]
++ [CLabel]
c1)

functionCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body =
    SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
body' [] []
  where
    body' :: SDoc
body' = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
        [ SDoc
declarations
        , [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void", Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
clbl, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(void)"]
        , SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces SDoc
body
        ]

-- | @initializerCStub fn_nm decls body@ is a 'CStub' containing C initializer
-- function (e.g. an entry of the @.init_array@ section) named
-- @fn_nm@ with the given body and the given set of declarations.
initializerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body =
    Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body
    CStub -> CStub -> CStub
forall a. Monoid a => a -> a -> a
`mappend` SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
forall doc. IsOutput doc => doc
empty [CLabel
clbl] []

-- | @finalizerCStub fn_nm decls body@ is a 'CStub' containing C finalizer
-- function (e.g. an entry of the @.fini_array@ section) named
-- @fn_nm@ with the given body and the given set of declarations.
finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
finalizerCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body =
    Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body
    CStub -> CStub -> CStub
forall a. Monoid a => a -> a -> a
`mappend` SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
forall doc. IsOutput doc => doc
empty [] [CLabel
clbl]

newtype CHeader = CHeader { CHeader -> SDoc
getCHeader :: SDoc }

instance Monoid CHeader where
  mempty :: CHeader
mempty = SDoc -> CHeader
CHeader SDoc
forall doc. IsOutput doc => doc
empty
  mconcat :: [CHeader] -> CHeader
mconcat = ([SDoc] -> SDoc) -> [CHeader] -> CHeader
forall a b. Coercible a b => a -> b
coerce (forall doc. IsDoc doc => [doc] -> doc
vcat @SDoc)

instance Semigroup CHeader where
    <> :: CHeader -> CHeader -> CHeader
(<>) = (SDoc -> SDoc -> SDoc) -> CHeader -> CHeader -> CHeader
forall a b. Coercible a b => a -> b
coerce (forall doc. IsDoc doc => doc -> doc -> doc
($$) @SDoc)

-- | Foreign export stubs
data ForeignStubs
  = NoStubs
      -- ^ We don't have any stubs
  | ForeignStubs CHeader CStub
      -- ^ There are some stubs. Parameters:
      --
      --  1) Header file prototypes for
      --     "foreign exported" functions
      --
      --  2) C stubs to use when calling
      --     "foreign exported" functions

appendStubC :: ForeignStubs -> CStub -> ForeignStubs
appendStubC :: ForeignStubs -> CStub -> ForeignStubs
appendStubC ForeignStubs
NoStubs         CStub
c_code = CHeader -> CStub -> ForeignStubs
ForeignStubs CHeader
forall a. Monoid a => a
mempty CStub
c_code
appendStubC (ForeignStubs CHeader
h CStub
c) CStub
c_code = CHeader -> CStub -> ForeignStubs
ForeignStubs CHeader
h (CStub
c CStub -> CStub -> CStub
forall a. Monoid a => a -> a -> a
`mappend` CStub
c_code)