{-# LANGUAGE TemplateHaskell #-}

-- | This module provides TH splices that generate FFI wrappers and
-- 'ToFunPtr' instances that are called in different modules to paralellize
-- compilation and compile time code generation.
--
module HsBindgen.Runtime.TH.Types (
    -- * Types
    allPrimTypes
  , allPtrTypes
  , allIOTypes
    -- * Common Types
  , commonPrimTypes
  , commonPtrTypes
  , commonReturnTypes
    -- * Generate the instances
  , generateInstance
  ) where

import Data.Void (Void)
import Foreign qualified as F
import Foreign.C.Types
import GHC.Ptr qualified as Ptr
import Language.Haskell.TH

import HsBindgen.Runtime.Internal.FunPtr.Class

-- | Get primitive marshallable types
--
allPrimTypes :: [Q Type]
allPrimTypes :: [Q Type]
allPrimTypes =
  [ [t| CChar      |]
  , [t| CSChar     |]
  , [t| CUChar     |]
  , [t| CInt       |]
  , [t| CUInt      |]
  , [t| CShort     |]
  , [t| CUShort    |]
  , [t| CLong      |]
  , [t| CULong     |]
  , [t| CPtrdiff   |]
  , [t| CSize      |]
  , [t| CLLong     |]
  , [t| CULLong    |]
  , [t| CBool      |]
  , [t| CFloat     |]
  , [t| CDouble    |]
  , [t| Int        |]
  ]

-- | Get pointer types for all primitive types
--
allPtrTypes :: [Q Type]
allPtrTypes :: [Q Type]
allPtrTypes = [t| Ptr.Ptr Void |]
            Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [ [t| Ptr.Ptr $Q Type
t |]
              | Q Type
t <- [Q Type]
allPrimTypes
              ]

-- | Get IO types for all primitive types
--
allIOTypes :: [Q Type]
allIOTypes :: [Q Type]
allIOTypes = [t| IO () |]
           Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [ [t| IO $Q Type
t |]
             | Q Type
t <- [Q Type]
allPrimTypes
             ]

-- | A list of the most common primitive types found in C callbacks.
--
commonPrimTypes :: [Q Type]
commonPrimTypes :: [Q Type]
commonPrimTypes =
  [ [t| CChar   |]
  , [t| CInt    |]
  , [t| CUInt   |]
  , [t| CDouble |]
  , [t| CFloat  |]
  ]

-- | Common pointer types, including the crucial @void*@ and @char*@.
--
commonPtrTypes :: [Q Type]
commonPtrTypes :: [Q Type]
commonPtrTypes =
  [ [t| Ptr.Ptr Void  |]
  , [t| Ptr.Ptr CChar |]
  , [t| Ptr.Ptr CInt  |]
  ]

-- | The most common return types for callbacks are @void@ and integer status
-- codes.
--
commonReturnTypes :: [Q Type]
commonReturnTypes :: [Q Type]
commonReturnTypes =
  [ [t| IO ()   |]
  , [t| IO CInt |]
  ]

-- | Generate a foreign import wrapper and 'ToFunPtr' instance for a
-- particular type
--
generateInstance :: Q Type -> Q [Dec]
generateInstance :: Q Type -> Q [Dec]
generateInstance Q Type
funTyQ = do
  Type
funTy <- Q Type
funTyQ

  Name
wrapperName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String
"wrapper_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
sanitizeTypeName (Type -> String
forall a. Show a => a -> String
show Type
funTy))
  Name
dynamicName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String
"dynamic_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
sanitizeTypeName (Type -> String
forall a. Show a => a -> String
show Type
funTy))

  Dec
foreignImportWrapper <- Callconv -> Safety -> String -> Name -> Q Type -> Q Dec
forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> String -> Name -> m Type -> m Dec
forImpD Callconv
CCall
                                  Safety
Safe
                                  String
"wrapper"
                                  Name
wrapperName
                                  [t| $Q Type
funTyQ -> IO (F.FunPtr $Q Type
funTyQ) |]

  Dec
foreignImportDynamic <- Callconv -> Safety -> String -> Name -> Q Type -> Q Dec
forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> String -> Name -> m Type -> m Dec
forImpD Callconv
CCall
                                  Safety
Safe
                                  String
"dynamic"
                                  Name
dynamicName
                                  [t| F.FunPtr $Q Type
funTyQ -> $Q Type
funTyQ |]

  Dec
toFunPtrInstance <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
                                [t| ToFunPtr $Q Type
funTyQ |]
                                [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName String
"toFunPtr")
                                  [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
wrapperName)) []
                                  ]
                                ]

  Dec
fromFunPtrInstance <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
                                  [t| FromFunPtr $Q Type
funTyQ |]
                                  [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName String
"fromFunPtr")
                                    [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
dynamicName)) []
                                    ]
                                  ]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Dec
foreignImportWrapper
         , Dec
foreignImportDynamic
         , Dec
toFunPtrInstance
         , Dec
fromFunPtrInstance
         ]
  where
    -- | Sanitize type name for use in generated names
    sanitizeTypeName :: String -> String
    sanitizeTypeName :: String -> String
sanitizeTypeName = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
sanitizeChar
      where
        sanitizeChar :: Char -> String
sanitizeChar Char
c
          | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char
'a'..Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9']) = [Char
c]
          | Bool
otherwise = String
"_"