Stdlib.hs

-- | Standard library external binding specification
--
-- This /private/ module may only be used by "HsBindgen.BindingSpec".
--
-- Intended for qualified import.
--
-- > import HsBindgen.BindingSpec.Private.Stdlib qualified as Stdlib
--
-- If you change this file, note that:
--
-- - The types for these bindings are defined in @HsBindgen.Runtime.Prelude@ in
--   the @hs-bindgen-runtime@ library, in the same order.
--
-- - The types for these bindings are tested in
--   @standard_library_external_binding_specs.h@ in the same order.
module HsBindgen.BindingSpec.Private.Stdlib (
    -- * Binding specification
    bindingSpec
  ) where

import Data.Map.Strict qualified as Map
import Data.Set qualified as Set

import HsBindgen.Backend.Runtime qualified as Runtime
import HsBindgen.BindingSpec.Private.Common
import HsBindgen.BindingSpec.Private.V1 qualified as BindingSpec
import HsBindgen.Errors
import HsBindgen.Imports
import HsBindgen.Instances qualified as Inst
import HsBindgen.IR.C qualified as C
import HsBindgen.Language.Haskell qualified as Hs

{-------------------------------------------------------------------------------
  Binding specification
-------------------------------------------------------------------------------}

-- | All standard library bindings
--
-- These bindings include types defined in @base@ as well as
-- @hs-bindgen-runtime@
bindingSpec :: BindingSpec.UnresolvedBindingSpec
bindingSpec = BindingSpec.BindingSpec{
      moduleName = Runtime.moduleName Runtime.LibC
    , cTypes     = bindingSpecCTypes
    , hsTypes    = bindingSpecHsTypes
    }
  where
    bindingSpecCTypes  :: CTypeMap
    bindingSpecHsTypes :: HsTypeMap
    (bindingSpecCTypes, bindingSpecHsTypes) = mkMaps $
         boolTypes
      ++ integralTypes
      ++ floatingTypes
      ++ stdTypes
      ++ nonLocalJumpTypes
      ++ wcharTypes
      ++ timeTypes
      ++ fileTypes
      ++ signalTypes

    boolTypes :: [(CTypeKV, HsTypeKV)]
    boolTypes = [
        mkTypeN "macro bool" "CBool" intI (Just $ mkFFITypeLibC "CBool") ["stdbool.h"]
      ]

    -- Note that the \"least\" and \"fast\" types (such as @int_least32_t@)
    -- /cannot/ be defined in the standard library because their implementations
    -- differ across different @libc@ implementations, and users may choose
    -- which @libc@ to use when running @hs-bindgen@.
    integralTypes :: [(CTypeKV, HsTypeKV)]
    integralTypes =
      let aux (t, hsIdentifier, ffiType) =
            mkTypeN t hsIdentifier intI (Just ffiType) ["inttypes.h", "stdint.h"]
      in  map aux [
              ("int8_t",    "Int8"    , mkFFITypeLibC "Int8")
            , ("int16_t",   "Int16"   , mkFFITypeLibC "Int16")
            , ("int32_t",   "Int32"   , mkFFITypeLibC "Int32")
            , ("int64_t",   "Int64"   , mkFFITypeLibC "Int64")
            , ("uint8_t",   "Word8"   , mkFFITypeLibC "Word8")
            , ("uint16_t",  "Word16"  , mkFFITypeLibC "Word16")
            , ("uint32_t",  "Word32"  , mkFFITypeLibC "Word32")
            , ("uint64_t",  "Word64"  , mkFFITypeLibC "Word64")
            , ("intmax_t",  "CIntMax" , mkFFITypeLibC "CIntMax")
            , ("uintmax_t", "CUIntMax", mkFFITypeLibC "CUIntMax")
            , ("intptr_t",  "CIntPtr" , mkFFITypeLibC "CIntPtr")
            , ("uintptr_t", "CUIntPtr", mkFFITypeLibC "CUIntPtr")
            ]

    floatingTypes :: [(CTypeKV, HsTypeKV)]
    floatingTypes =
      let aux (t, hsIdentifier) = mkType t hsIdentifier hsED [] ["fenv.h"]
      in  map aux [
              ("fenv_t",    "CFenvT")
            , ("fexcept_t", "CFexceptT")
            ]

    stdTypes :: [(CTypeKV, HsTypeKV)]
    stdTypes = [
        mkTypeN "size_t" "CSize" intI (Just $ mkFFITypeLibC "CSize") [
            "signal.h"
          , "stddef.h"
          , "stdio.h"
          , "stdlib.h"
          , "string.h"
          , "time.h"
          , "uchar.h"
          , "wchar.h"
          ]
      , mkTypeN "ptrdiff_t" "CPtrdiff" intI (Just $ mkFFITypeLibC "CPtrdiff") ["stddef.h"]
      ]

    nonLocalJumpTypes :: [(CTypeKV, HsTypeKV)]
    nonLocalJumpTypes = [
        mkType "jmp_buf" "CJmpBuf" hsED [] ["setjmp.h"]
      ]

    wcharTypes :: [(CTypeKV, HsTypeKV)]
    wcharTypes = [
        mkTypeN "wchar_t" "CWchar" intI (Just $ mkFFITypeLibC "CWchar") [
            "inttypes.h"
          , "stddef.h"
          , "stdlib.h"
          , "wchar.h"
          ]
      , mkTypeN "wint_t"    "CWintT"         intI (Just $ mkFFITypeLibC "CWintT")    ["wchar.h", "wctype.h"]
      , mkType  "mbstate_t" "CMbstateT" hsED []                                         ["uchar.h", "wchar.h"]
      , mkTypeN "wctrans_t" "CWctransT"      nEqI (Just $ mkFFITypeLibC "CWctransT") ["wctype.h"]
      , mkTypeN "wctype_t"  "CWctypeT"       nEqI (Just $ mkFFITypeLibC "CWctypeT" ) ["wchar.h", "wctype.h"]
      , mkTypeN "char16_t"  "CChar16T"       intI (Just $ mkFFITypeLibC "CChar16T" ) ["uchar.h"]
      , mkTypeN "char32_t"  "CChar32T"       intI (Just $ mkFFITypeLibC "CChar32T" ) ["uchar.h"]
      ]

    timeTypes :: [(CTypeKV, HsTypeKV)]
    timeTypes = [
        mkTypeN "time_t"  "CTime"  timeI (Just $ mkFFITypeLibC "CTime")  ["signal.h", "time.h"]
      , mkTypeN "clock_t" "CClock" timeI (Just $ mkFFITypeLibC "CClock") ["signal.h", "time.h"]
      , let hsR = mkHsR "CTm" [
                "tm_sec"
              , "tm_min"
              , "tm_hour"
              , "tm_mday"
              , "tm_mon"
              , "tm_year"
              , "tm_wday"
              , "tm_yday"
              , "tm_isdst"
              ]
        in  mkType "struct tm" "CTm" hsR tmI ["time.h"]
      ]

    fileTypes :: [(CTypeKV, HsTypeKV)]
    fileTypes = [
        mkType "FILE"   "CFile" hsED [] ["stdio.h", "wchar.h"]
      , mkType "fpos_t" "CFpos" hsED [] ["stdio.h"]
      ]

    signalTypes :: [(CTypeKV, HsTypeKV)]
    signalTypes = [
        mkTypeN "sig_atomic_t" "CSigAtomic" intI (Just $ mkFFITypeLibC "CSigAtomic") ["signal.h"]
      ]

    intI, nEqI, timeI, tmI :: [Inst.TypeClass]
    intI = [
        Inst.Bitfield
      , Inst.Bits
      , Inst.Bounded
      , Inst.Enum
      , Inst.Eq
      , Inst.FiniteBits
      , Inst.HasFFIType
      , Inst.Integral
      , Inst.Ix
      , Inst.Num
      , Inst.Ord
      , Inst.Prim
      , Inst.Read
      , Inst.ReadRaw
      , Inst.Real
      , Inst.Show
      , Inst.StaticSize
      , Inst.Storable
      , Inst.WriteRaw
      ]
    nEqI = [ -- newtype equality
        Inst.Eq
      , Inst.HasFFIType
      , Inst.Prim
      , Inst.ReadRaw
      , Inst.Show
      , Inst.StaticSize
      , Inst.Storable
      , Inst.WriteRaw
      ]
    timeI = [
        Inst.Enum
      , Inst.Eq
      , Inst.HasFFIType
      , Inst.Num
      , Inst.Ord
      , Inst.Read
      , Inst.ReadRaw
      , Inst.Real
      , Inst.Show
      , Inst.StaticSize
      , Inst.Storable
      , Inst.WriteRaw
      ]
    tmI = [ -- struct tm
        Inst.Eq
      , Inst.HasCField
      , Inst.HasField
      , Inst.ReadRaw
      , Inst.Show
      , Inst.StaticSize
      ]

{-------------------------------------------------------------------------------
  Auxiliary functions
-------------------------------------------------------------------------------}

-- | Concise alias for the C type 'Map'
type CTypeMap =
  Map C.DeclId [(Set C.HashIncludeArg, Omittable BindingSpec.CTypeSpec)]

-- | Concise alias for the key and value tuple corresponding to an entry in a
-- 'CTypeMap'
type CTypeKV =
  (C.DeclId, [(Set C.HashIncludeArg, Omittable BindingSpec.CTypeSpec)])

-- | Concise alias for the Haskell type 'Map'
type HsTypeMap = Map (Hs.Name Hs.NsTypeConstr) BindingSpec.HsTypeSpec

-- | Concise alias for the key and value tuple corresponding to an entry in a
-- 'HsTypeMap'
type HsTypeKV = (Hs.Name Hs.NsTypeConstr, BindingSpec.HsTypeSpec)

mkMaps :: [(CTypeKV, HsTypeKV)] -> (CTypeMap, HsTypeMap)
mkMaps = bimap Map.fromList Map.fromList . unzip

-- | Construct the 'CTypeKV' and 'HsTypeKV' for a type
mkType ::
     Text
  -> Text
  -> BindingSpec.HsTypeRep
  -> [Inst.TypeClass]
  -> [FilePath]
  -> (CTypeKV, HsTypeKV)
mkType t hsId hsTypeRep insts headers' =
    case C.parseDeclId t of
      Just cDeclId ->
        ( (cDeclId, [(headers, Require cTypeSpec)])
        , (typeConstrName, hsTypeSpec)
        )
      Nothing -> panicPure $ "Invalid declaration ID: " ++ show t
  where
    -- Names in the stdlib binding spec are statically known-valid Haskell
    -- identifiers, so 'Hs.UnsafeName' is safe here.
    typeConstrName :: Hs.Name Hs.NsTypeConstr
    typeConstrName = Hs.UnsafeName hsId

    headers :: Set C.HashIncludeArg
    headers = Set.fromList $ map C.HashIncludeArg headers'

    cTypeSpec :: BindingSpec.CTypeSpec
    cTypeSpec = BindingSpec.CTypeSpec {
        hsName = Just typeConstrName
      , enum   = Nothing -- No C @enum@ types in @stdlib@
      }

    hsTypeSpec :: BindingSpec.HsTypeSpec
    hsTypeSpec = BindingSpec.HsTypeSpec {
        hsRep     = Just hsTypeRep
      , instances = Map.fromList [
            (inst, Require def)
          | inst <- insts
          ]
      }

-- | Concise alias for 'BindingSpec.HsTypeRepEmptyData'
hsED :: BindingSpec.HsTypeRep
hsED = BindingSpec.HsTypeRepEmptyData

-- | Construct a 'BindingSpec.HsTypeRepRecord' with the specified constructor
-- and field names
mkHsR :: Text -> [Text] -> BindingSpec.HsTypeRep
mkHsR hsId fieldNames = BindingSpec.HsTypeRepRecord $
    BindingSpec.HsRecordRep {
        -- Names in the stdlib binding spec are statically known-valid Haskell
        -- identifiers, so 'Hs.UnsafeName' is safe here.
        constructor = Just $ Hs.UnsafeName hsId
      , fields      = Just $ map Hs.UnsafeName fieldNames
      }

-- | Construct a 'BindingSpec.HsTypeRepNewtype' with the specified constructor
-- name and no field names
--
-- The standard @newtype@ types do not have field names.
mkHsN :: Hs.Name Hs.NsConstr -> Maybe BindingSpec.HsFFIType -> BindingSpec.HsTypeRep
mkHsN constructorName ffiType = BindingSpec.HsTypeRepNewtype $
    BindingSpec.HsNewtypeRep {
        constructor = Just constructorName
      , field       = Nothing
      , ffiType     = ffiType
      }

-- | Variant of 'mkType' that creates a 'BindingSpec.HsTypeRepNewtype' where the
-- constructor has the same name as the type
mkTypeN ::
     Text
  -> Text
  -> [Inst.TypeClass]
  -> Maybe BindingSpec.HsFFIType
  -> [FilePath]
  -> (CTypeKV, HsTypeKV)
mkTypeN t hsId insts ffiType headers =
    mkType t hsId (mkHsN dataConstrName ffiType) insts headers
  where
    -- Names in the stdlib binding spec are statically known-valid Haskell
    -- identifiers, so 'Hs.UnsafeName' is safe here.
    dataConstrName :: Hs.Name Hs.NsConstr
    dataConstrName = Hs.UnsafeName hsId

mkFFIType :: Hs.ModuleName -> Text -> BindingSpec.HsFFIType
mkFFIType moduleName typeName = BindingSpec.HsFFIType $ Hs.ExtRef {
      moduleName = moduleName
    , name       = Hs.UnsafeName typeName
    }

mkFFITypeLibC :: Text -> BindingSpec.HsFFIType
mkFFITypeLibC = mkFFIType "HsBindgen.Runtime.LibC"