Gen.hs

-- | Binding specification generation
--
-- Intended for qualified import.
--
-- > import HsBindgen.BindingSpec.Gen qualified as BindingSpec
module HsBindgen.BindingSpec.Gen (
    -- * Public API
    genBindingSpec
  ) where

import Data.ByteString (ByteString)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Ord qualified as Ord
import Data.Set qualified as Set

import Clang.HighLevel.Types

import HsBindgen.Backend.Hs.AST qualified as Hs
import HsBindgen.Backend.Hs.Origin qualified as HsOrigin
import HsBindgen.BindingSpec.Private.Common
import HsBindgen.BindingSpec.Private.V1 (CTypeSpec (..), UnresolvedBindingSpec)
import HsBindgen.BindingSpec.Private.V1 qualified as BindingSpec
import HsBindgen.Errors
import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex)
import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex
import HsBindgen.Frontend.Analysis.IncludeGraph (IncludeGraph)
import HsBindgen.Frontend.Analysis.IncludeGraph qualified as IncludeGraph
import HsBindgen.Frontend.Pass.Final
import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass qualified as ResolveBindingSpecs
import HsBindgen.Frontend.ProcessIncludes
import HsBindgen.Imports
import HsBindgen.Instances qualified as Inst
import HsBindgen.IR.C qualified as C
import HsBindgen.IR.Translation
import HsBindgen.Language.Haskell qualified as Hs

{-------------------------------------------------------------------------------
  Public API
-------------------------------------------------------------------------------}

-- | Generate binding specification
genBindingSpec ::
     Format
  -> Hs.ModuleName
  -> IncludeGraph
  -> DeclIndex l
  -> GetMainHeaders
  -> [(C.DeclId, RealPath)]
  -> [(C.DeclId, (RealPath, Hs.Name Hs.NsTypeConstr))]
  -> [Hs.Decl l]
  -> ByteString
genBindingSpec
  format
  hsModuleName
  includeGraph
  declIndex
  getMainHeaders
  omitTypes
  squashedTypes =
      BindingSpec.encode compareCDeclId format
    . genBindingSpec' hsModuleName getMainHeaders omitTypes squashedTypes
  where
    compareCDeclId :: C.DeclId -> C.DeclId -> Ordering
    compareCDeclId cDeclIdL cDeclIdR = Ord.comparing aux cDeclIdL cDeclIdR

    aux :: C.DeclId -> (IncludeGraph.IncludeOrderIx, Int, Int, Text)
    aux cDeclId =
      case DeclIndex.lookupLoc cDeclId declIndex of
        Just locs ->
          -- NOTE: At the moment, we attempt to get the “minimum” location and
          -- discard other conflicting locations (e.g., the ones of other
          -- colliding definitions). This is OK, since we only use the location
          -- to sort the binding specifications before generating them.
          let loc = C.declLocsMin locs
              orderIx = IncludeGraph.lookupIncludeOrder order (singleLocPath loc)
          in  ( orderIx
              , loc.singleLocLine
              , loc.singleLocColumn
              , C.renderDeclId cDeclId
              )
        Nothing -> (
            IncludeGraph.NotInIncludeGraph
          , maxBound
          , maxBound
          , C.renderDeclId cDeclId
          )

    order :: IncludeGraph.IncludeOrder
    order = IncludeGraph.toIncludeOrder includeGraph

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

-- TODO <https://github.com/well-typed/hs-bindgen/issues/1436>
-- TODO <https://github.com/well-typed/hs-bindgen/issues/1549>
-- Once squashing is configurable (#1436), we should deal with aliases (#1549).
genBindingSpec' ::
     Hs.ModuleName
  -> GetMainHeaders
  -> [(C.DeclId, RealPath)]
  -> [(C.DeclId, (RealPath, Hs.Name Hs.NsTypeConstr))]
  -> [Hs.Decl l]
  -> UnresolvedBindingSpec
genBindingSpec' hsModuleName getMainHeaders omitTypes squashedTypes =
    foldr aux spec0
  where
    spec0 :: UnresolvedBindingSpec
    spec0 = BindingSpec.BindingSpec {
        moduleName = hsModuleName
      , cTypes     = Map.fromListWith (++) $
          [ (cDeclId, [(getMainHeaders' path, Omit)])
          | (cDeclId, path) <- omitTypes
          ] ++
          [ let headers   = getMainHeaders' sourcePath
                cTypeSpec :: CTypeSpec
                cTypeSpec = CTypeSpec{
                    hsName = Just hsName
                  , enum   = Nothing
                  }
            in  (cDeclId, [(headers, Require cTypeSpec)])
          | (cDeclId, (sourcePath, hsName)) <- squashedTypes
          ]
      , hsTypes = Map.empty
      }

    getMainHeaders' :: RealPath -> Set C.HashIncludeArg
    getMainHeaders' =
        either
          (\s -> panicPure ("Could not get main headers: " ++ s))
          (Set.fromList . NonEmpty.toList)
      . getMainHeaders

    aux ::
         Hs.Decl l
      -> UnresolvedBindingSpec
      -> UnresolvedBindingSpec
    aux = \case
      Hs.DeclTypSyn typSyn          -> insertType $ auxTypSyn    typSyn
      Hs.DeclData struct            -> insertType $ auxStruct    struct
      Hs.DeclEmpty edata            -> insertType $ auxEmptyData edata
      Hs.DeclNewtype ntype          ->
        case ntype.origin.kind of
          HsOrigin.Aux{} -> id
          _otherwise     -> insertType $ auxNewtype ntype
      Hs.DeclPatSyn{}               -> id
      Hs.DeclCompletePragma{}       -> id
      Hs.DeclDefineInstance{}       -> id
      Hs.DeclDeriveInstance{}       -> id
      Hs.DeclForeignImport{}        -> id
      Hs.DeclForeignImportWrapper{} -> id
      Hs.DeclForeignImportDynamic{} -> id
      Hs.DeclFunction{}             -> id
      Hs.DeclMacroValue{}           -> id
      Hs.DeclVar{}                  -> id

    -- TODO <https://github.com/well-typed/hs-bindgen/issues/2284>
    --
    -- Bindings specifications for macros defined on the command line or the
    -- root header.
    insertType ::
         ( (C.DeclInfo Final, BindingSpec.CTypeSpec)
         , (Hs.Name Hs.NsTypeConstr, BindingSpec.HsTypeSpec)
         )
      -> UnresolvedBindingSpec
      -> UnresolvedBindingSpec
    insertType ((declInfo, cTypeSpec), (hsName, hsTypeSpec)) spec =
      case singleLocPath declInfo.loc of
        C.InHeader path ->
          spec
            & #cTypes %~
                Map.insertWith (++)
                  declInfo.id.cName
                  [(getMainHeaders' path, Require cTypeSpec)]
            & #hsTypes %~
                Map.insert hsName hsTypeSpec
        -- Not in any header, so no binding specification can refer to it
        C.InRootHeader  -> spec
        C.OnCommandLine -> spec

    auxTypSyn ::
         Hs.TypSyn
      -> ( (C.DeclInfo Final, BindingSpec.CTypeSpec)
         , (Hs.Name Hs.NsTypeConstr, BindingSpec.HsTypeSpec)
         )
    auxTypSyn typSyn =
      let cTypeSpec = BindingSpec.CTypeSpec {
              hsName = Just typSyn.name
            , enum   = Nothing
            }
          hsTypeSpec = BindingSpec.HsTypeSpec {
              hsRep     = Just BindingSpec.HsTypeRepTypeAlias
            , instances = Map.empty
            }
      in  ( (typSyn.origin.info, cTypeSpec)
          , (typSyn.name, hsTypeSpec)
          )

    auxStruct ::
         Hs.Struct
      -> ( (C.DeclInfo Final, BindingSpec.CTypeSpec)
         , (Hs.Name Hs.NsTypeConstr, BindingSpec.HsTypeSpec)
         )
    auxStruct hsStruct = case hsStruct.origin of
      Nothing -> panicPure "Origin of structure unavailable"
      Just originDecl ->
        let cTypeSpec = BindingSpec.CTypeSpec {
                hsName = Just hsStruct.name
              , enum   = Nothing
              }
            hsRecordRep = BindingSpec.HsRecordRep {
                constructor = Just hsStruct.constr
              , fields      = Just [
                    field.name
                  | field <- hsStruct.fields
                  ]
              }
            hsTypeSpec = BindingSpec.HsTypeSpec {
                hsRep     = Just $ BindingSpec.HsTypeRepRecord hsRecordRep
              , instances =
                  mkInstSpecs
                    (maybe Map.empty (.instances) $ originDecl.spec.hsSpec)
                    hsStruct.instances
              }
        in  ( (originDecl.info, cTypeSpec)
            , (hsStruct.name, hsTypeSpec)
            )

    auxEmptyData ::
         Hs.EmptyData
      -> ( (C.DeclInfo Final, BindingSpec.CTypeSpec)
         , (Hs.Name Hs.NsTypeConstr, BindingSpec.HsTypeSpec)
         )
    auxEmptyData edata =
      let originDecl   = edata.origin
          cTypeSpec = BindingSpec.CTypeSpec {
              hsName = Just edata.name
            , enum   = Nothing
            }
          hsTypeSpec = BindingSpec.HsTypeSpec {
              hsRep     = Just BindingSpec.HsTypeRepEmptyData
            , instances =
                mkInstSpecs
                  (maybe Map.empty (.instances) $ originDecl.spec.hsSpec)
                  edata.instances
            }
      in  ( (originDecl.info, cTypeSpec)
          , (edata.name, hsTypeSpec)
          )

    auxNewtype ::
         Hs.Newtype
      -> ( (C.DeclInfo Final, BindingSpec.CTypeSpec)
         , (Hs.Name Hs.NsTypeConstr, BindingSpec.HsTypeSpec)
         )
    auxNewtype hsNewtype =
      let originDecl   = hsNewtype.origin
          cTypeSpec    = BindingSpec.CTypeSpec {
              hsName = Just hsNewtype.name
            , enum   =
                case originDecl.spec.cSpec of
                  Just spec -> spec.enum
                  Nothing   ->
                    case originDecl.kind of
                      HsOrigin.Enum{} -> Just BindingSpec.CEnumOpen
                      _otherwise      -> Nothing
            }
          hsNewtypeRep = BindingSpec.HsNewtypeRep {
              constructor = Just hsNewtype.constr
            , field       = Just hsNewtype.field.name
            , ffiType     = hsNewtype.ffiType
            }
          hsTypeSpec = BindingSpec.HsTypeSpec {
              hsRep     = Just $ BindingSpec.HsTypeRepNewtype hsNewtypeRep
            , instances =
                mkInstSpecs
                  (maybe Map.empty (.instances) $ originDecl.spec.hsSpec)
                  hsNewtype.instances
            }
      in  ( (originDecl.info, cTypeSpec)
          , (hsNewtype.name, hsTypeSpec)
          )

-- TODO <https://github.com/well-typed/hs-bindgen/issues/1766>
-- We should allow users to specify strategies for instance deriving.
--
-- TODO <https://github.com/well-typed/hs-bindgen/issues/648>
-- It should be possible to generate instances with constraints.
mkInstSpecs ::
     Map Inst.TypeClass (Omittable BindingSpec.InstanceSpec)
  -> Set Inst.TypeClass
  -> Map Inst.TypeClass (Omittable BindingSpec.InstanceSpec)
mkInstSpecs specMap insts = Map.fromList $
    [ (cls, Require def)
    | cls <- Set.toList insts
    ]
    ++
    [ (cls, Omit)
    | (cls, Omit) <- Map.toList specMap
    ]