HsStdTuple.hs

{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

{-# LANGUAGE TemplateHaskell #-}
module Foreign.CPP.HsStruct.HsStdTuple
  ( deriveHsStdTupleUnsafe
  , HsStdTuple(..)
  ) where

import Data.List (foldl')
import Control.Monad (forM, unless)
import Foreign
import Language.Haskell.TH

import Foreign.CPP.Addressable
import Foreign.CPP.Marshallable


newtype HsStdTuple a = HsStdTuple { unHsStdTuple :: a }

deriveHsStdTupleUnsafe
  :: String -> Int -> Int -> TypeQ -> Q [Dec]
deriveHsStdTupleUnsafe cppType sizeVal alignmentVal hsType = do
  hsStdTupleType <- [t| HsStdTuple |]
  hsTRaw <- hsType
  let
    (hsT, tupleType) = case hsTRaw of
      (AppT a b) | a == hsStdTupleType -> (b, hsType)
      _ -> (hsTRaw, [t| HsStdTuple $hsType |])
    (numTypes, hsTypes) = unfoldTupleT hsT

  unless (numTypes > 0) $
    fail "StdTuple must be a tuple with 1 or more underlying types"

  hsTypesDestructible <-
    forM hsTypes $ \t -> isInstance (mkName "Destructible") [t]

  addressableInst <- instanceD
    (cxt [])
    [t| Addressable $tupleType |]
    []

  let
    sizeOfFn = funD (mkName "sizeOf")
      [ clause [wildP] (normalB $ litE $ integerL $ fromIntegral sizeVal) [] ]

    alignmentFn = funD (mkName "alignment")
      [ clause [wildP] (normalB $
          litE $ integerL $ fromIntegral alignmentVal) []
      ]

    ptrN = mkName "ptr"
    pNames = take numTypes $ idxNames "p"
    vNames = take numTypes $ idxNames "v"
    pvZipped = zip pNames vNames
    pCasted = map (\p -> parensE $ varE castPtrN `appE` varE p) pNames

    hsPokeName = mkName $ "c_poke_" ++ cppName
    cppPokeName = "std_tuple_poke_" ++ cppName

    nestedPokeFns = nestPokeFns (zip3 vNames pNames hsTypesDestructible) $ doE
      -- c_poke* FFI call
      [ noBindS (foldl' appE
          (varE hsPokeName `appE` [| castPtr ptr|] `appE` [|nullPtr|])
          pCasted
        )
      ]

    pokeFn = funD (mkName "poke")
      [ clause [varP ptrN, conP (mkName "HsStdTuple") [tupP (map varP vNames)]]
          (normalB nestedPokeFns) []
      ]

    hsPeekName = mkName $ "c_peek_" ++ cppName
    cppPeekName = "std_tuple_peek_" ++ cppName

    nestedPeekFns = nestPeekFns (zip pNames hsTypesDestructible) $
      doE $
        -- c_peek* FFI call
        [noBindS (foldl' appE
            (varE hsPeekName `appE` [| castPtr ptr|] `appE` [|nullPtr|])
            pCasted
          )
        ] ++
        -- N peeks
        map (\(p, v) -> bindS (varP v) (varE (mkName "peek") `appE` varE p))
          pvZipped ++
        -- tuple construction
        [noBindS (varE (mkName "return") `appE`
          parensE (conE (mkName "HsStdTuple") `appE` tupE (map varE vNames)))
        ]

    peekFn = funD (mkName "peek")
      [ clause [varP ptrN] (normalB nestedPeekFns) []
      ]

  storableInst <- instanceD
    (cxt [])
    [t| Storable $tupleType |]
    [sizeOfFn, alignmentFn, pokeFn, peekFn]

  peekImport <- forImpD cCall unsafe cppPeekName hsPeekName $
    -- Ptr () -> Ptr () -> <<< all tuple types >>> -> IO ()
    foldl' (\b a -> [t| $a -> $b |]) [t| IO () |] $
      map (\a -> [t| Ptr $a |]) ([t|()|] : [t| ()|] : map return hsTypes)

  pokeImport <- forImpD cCall unsafe cppPokeName hsPokeName $
    -- Ptr () -> Ptr () -> <<< all tuple types >>> -> IO ()
    foldl' (\b a -> [t| $a -> $b |]) [t| IO () |] $
      map (\a -> [t| Ptr $a |]) ([t|()|] : [t| ()|] : map return hsTypes)

  constructibleInst <- instanceD
    (cxt [])
    [t| Constructible $tupleType |]
    []

  return
    [ addressableInst
    , storableInst
    , constructibleInst
    , peekImport
    , pokeImport
    ]
  where
    unfoldTupleT :: Type -> (Int, [Type])
    unfoldTupleT (AppT a b) = let
      (i, ts) = unfoldTupleT a
      in (i, ts ++ [b])
    unfoldTupleT (TupleT i) = (i, [])
    unfoldTupleT n = (1, [n])

    castPtrN = mkName "castPtr"
    cppName = cppType

    idxNames c = map (\i -> mkName (c ++ show i)) [0::Int ..]

    nestPeekFns :: [(Name, Bool)] -> ExpQ -> ExpQ
    nestPeekFns [] base = base
    nestPeekFns ((p, isDestructible):ts) base =
      varE (mkName allocFn) `appE` lamE [varP p] (nestPeekFns ts base)
      where
        allocFn = if isDestructible then "withDefaultCxxObject" else "alloca"

    nestPokeFns :: [(Name, Name, Bool)] -> ExpQ -> ExpQ
    nestPokeFns [] base = base
    nestPokeFns ((v, p, isDestructible):ts) base =
      varE (mkName withObjFn) `appE` varE v `appE`
        lamE [varP p] (nestPokeFns ts base)
      where
        withObjFn = if isDestructible then "withCxxObject" else "with"