common/util/Foreign/CPP/HsStruct/HsOption.hs

-- Copyright (c) Facebook, Inc. and its affiliates.

{-# LANGUAGE TemplateHaskell #-}
module Foreign.CPP.HsStruct.HsOption
  ( HsOption(..)
  , deriveHsOptionUnsafe
  ) where

import Data.Char (isAlphaNum)
import Foreign
import Language.Haskell.TH

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

-- HsOption --------------------------------------------------------------------

newtype HsOption a = HsOption
  { hsOption :: Maybe a
  }

-- | This is a Template Haskell function which is used in conjunction with
-- @HS_OPTION_H@ and @HS_OPTION_CPP@ from "HsOption.h" to generate instances for
-- `HsOption T` for your type `T`
deriveHsOptionUnsafe
  :: String -> Int -> Int -> TypeQ -> Q [Dec]
deriveHsOptionUnsafe cppType sizeVal alignmentVal hsType = do
  optionTypeStr <-
    map (\i -> if isAlphaNum i then i else '_') . pprint <$> optionType

  -- instance Addressable (HsOption <TYPE>)
  addressableInst <- instanceD
    (cxt [])
    [t| Addressable $optionType |]
    []

  let
    -- sizeOf _ = #{size DummyHsOption<NAME>}
    sizeOfFn = funD (mkName "sizeOf")
      [ clause [wildP] (normalB $ litE $ integerL $ fromIntegral sizeVal) [] ]

    -- alignment _ = #{alignment DummyHsOption<NAME>}
    alignmentFn = funD (mkName "alignment")
      [ clause [wildP] (normalB $
          litE $ integerL $ fromIntegral alignmentVal) []
      ]

    -- poke = error "HsOption <TYPE> not pokeable"
    pokeFn = funD (mkName "poke")
      [ clause [] (normalB $
            varE (mkName "error") `appE`
            stringE (optionTypeStr ++ " not pokeable")
          )
          []
      ]

    pN = mkName "p"
    ptrN = mkName "ptr"
    peekN = mkName "peek"
    -- peek p = do
    --   ptr <- peekByteOff p 0  -- assume beginning of struct
    --   HsOption <$> maybePeek peek ptr
    peekFn = funD peekN
      [clause [varP pN] (normalB $ doE
        [ bindS
          (varP ptrN )
          (varE (mkName "peekByteOff") `appE` varE pN `appE` litE (integerL 0))
        , noBindS (infixApp
          (conE $ mkName "HsOption")
          (varE $ mkName "fmap")
          (varE (mkName "maybePeek") `appE` varE peekN `appE` varE ptrN)
          )
        ]) []]

  --  instance Storable (HsOption <TYPE>) where
  storableInst <- instanceD
    (cxt [])
    [t| Storable $optionType |]
    [sizeOfFn, alignmentFn, pokeFn, peekFn]

  --  $(deriveMarshallableUnsafe "<NAME>" [t| HsOption <TYPE> |])
  marshallable <- deriveMarshallableUnsafe cppName optionType

  let
    cppCtorName = "option_ctorHsOption" ++ cppType
    -- cppCtor = "void " ++ cppCtorName ++ "(void*, " ++ cppType ++ "*)"
    hsCtorName = mkName $ "c_ctor" ++ optionTypeStr

  -- foreign import ccall unsafe "<cppCtorName>"
  --   c_ctor<TYPE> :: Ptr (HsOption <TYPE>) -> Ptr <TYPE> -> IO ()
  ctorImport <- forImpD cCall unsafe cppCtorName hsCtorName
      [t| Ptr $optionType -> Ptr $hsType -> IO () |]

  let
    cppNewName = "option_newHsOption" ++ cppType
    -- cppNew = "void* " ++ cppNewName ++ "(" ++ cppType ++ "*)"
    hsNewName = mkName $ "c_new" ++ optionTypeStr

-- foreign import ccall unsafe "<cppNewName>"
--   c_new<TYPE> :: Ptr <TYPE> -> IO (Ptr (HsOption <TYPE>))
  newImport <- forImpD cCall unsafe cppNewName hsNewName
      [t| Ptr $hsType -> IO (Ptr $optionType) |]

  hsT <- hsType
  isDestructible <- isInstance (mkName "Destructible") [hsT]

  let
    optN = mkName "HsOption"
    nothingN = mkName "Nothing"
    justN = mkName "Just"
    vN = mkName "v"

    withFn = if isDestructible then "withCxxObject" else "with"

    -- newValue (HsOption Nothing) = newDefault
    -- newValue (HsOption (Just v)) =
    --   withCxxObject v $ c_newOption
    newValueFn = funD (mkName "newValue")
      [ clause [conP optN [conP nothingN []]] (normalB $
          varE (mkName "newDefault")) [],
        clause [conP optN [conP justN [varP vN]]] (normalB $
          infixApp
          (varE (mkName withFn) `appE` varE vN)
          (varE (mkName "$"))
          (varE hsNewName)
          ) []
      ]

    -- constructValue p (HsOption Nothing) = constructDefault p
    -- constructValue p (HsOption (Just v)) =
    --   withCxxObject v $ c_ctorOption p
    constructValueFn = funD (mkName "constructValue")
      [ clause [varP pN, conP optN [conP nothingN []]] (normalB $
          varE (mkName "constructDefault") `appE` varE pN) [],
        clause [varP pN, conP optN [conP justN [varP vN]]] (normalB $
          infixApp
          (varE (mkName withFn) `appE` varE vN)
          (varE (mkName "$"))
          (varE hsCtorName `appE` varE pN)
          ) []
      ]

  --  instance Constructible (HsOption <TYPE>) where
  constructibleInst <- instanceD
    (cxt [])
    [t| Constructible $optionType |]
    [newValueFn, constructValueFn]

  return $
    [ addressableInst
    , storableInst
    , ctorImport
    , newImport
    , constructibleInst
    ] ++ marshallable
  where
    optionType = [t| HsOption $hsType |]
    cppName = "HsOption" ++ cppType