module GHC.Types.ForeignStubs
( ForeignStubs (..)
, CHeader(..)
, CStub(..)
, initializerCStub
, finalizerCStub
, appendStubC
)
where
import 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 { getCStub :: SDoc
, getInitializers :: [CLabel]
, getFinalizers :: [CLabel]
}
emptyCStub :: CStub
emptyCStub = CStub empty [] []
instance Monoid CStub where
mempty = emptyCStub
instance Semigroup CStub where
CStub a0 b0 c0 <> CStub a1 b1 c1 =
CStub (a0 $$ a1) (b0 ++ b1) (c0 ++ c1)
functionCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub platform clbl declarations body =
CStub body' [] []
where
body' = vcat
[ declarations
, hsep [text "void", pprCLabel platform CStyle clbl, text "(void)"]
, braces body
]
initializerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub platform clbl declarations body =
functionCStub platform clbl declarations body
`mappend` CStub empty [clbl] []
finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
finalizerCStub platform clbl declarations body =
functionCStub platform clbl declarations body
`mappend` CStub empty [] [clbl]
newtype CHeader = CHeader { getCHeader :: SDoc }
instance Monoid CHeader where
mempty = CHeader empty
mconcat = coerce vcat
instance Semigroup CHeader where
(<>) = coerce ($$)
data ForeignStubs
= NoStubs
| ForeignStubs CHeader CStub
appendStubC :: ForeignStubs -> CStub -> ForeignStubs
appendStubC NoStubs c_code = ForeignStubs mempty c_code
appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c `mappend` c_code)