Translation.hs

module HsBindgen.Backend.HsModule.Translation (
    -- * GhcPragma
    GhcPragma (..)
    -- * ImportListItem
  , ImportListItem(..)
    -- * Export list
  , ExportEntry(..)
  , ExportItem(..)
  , resolveDeclExports
    -- * HsModule
  , HsModule(..)
    -- * Translation
  , translateModuleMultiple
  , translateModuleSingle
  ) where

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

import HsBindgen.Backend.Category
import HsBindgen.Backend.Extensions
import HsBindgen.Backend.Global
import HsBindgen.Backend.Hs.AST qualified as Hs
import HsBindgen.Backend.Hs.CallConv
import HsBindgen.Backend.Hs.Haddock.Documentation qualified as HsDoc
import HsBindgen.Backend.Hs.Name qualified as Hs
import HsBindgen.Backend.HsModule.Names
import HsBindgen.Backend.SHs.AST
import HsBindgen.Backend.SHs.AST.Expr (FBind (FBind))
import HsBindgen.Config.Prelims
import HsBindgen.Imports
import HsBindgen.Instances qualified as Inst
import HsBindgen.IR.C qualified as C
import HsBindgen.Language.Haskell qualified as Hs

{-------------------------------------------------------------------------------
  GhcPragma
-------------------------------------------------------------------------------}

-- | GHC Pragma
--
-- Example: @LANGUAGE NoImplicitPrelude@
newtype GhcPragma = GhcPragma { unGhcPragma :: String }
  deriving newtype (Eq, Ord, IsString)

{-------------------------------------------------------------------------------
  ImportListItem
-------------------------------------------------------------------------------}

-- | Import list item
data ImportListItem =
    QualifiedImportListItem   Hs.ModuleName (Maybe String)
    -- An empty import list (@Just []@) means "import instances only", and
    -- differs greatly from having no import list (@Nothing@), which is an open,
    -- unqualified import.
  | UnqualifiedImportListItem Hs.ModuleName (Maybe [ResolvedName])
  deriving stock (Eq, Ord)

{-------------------------------------------------------------------------------
  Export list
-------------------------------------------------------------------------------}

-- | An entry in the module export list.
--
-- Sections nest naturally: an 'ExportSection' carries its own children, so
-- depth is implicit in the tree structure rather than tracked as an integer
-- on each header.  The pretty-printer derives Haddock @*@ count from the
-- recursion depth.
--
-- Example: a top-level @api_version_t@ followed by a @Core Data Types@
-- group containing a record and a derived pattern synonym is rendered as:
--
-- > [ ExportEntry (ExportTypeAll "Api_version_t")
-- > , ExportSection [TextContent "Core Data Types"]
-- >     [ ExportEntry (ExportTypeAll "Config_t")
-- >     , ExportEntry (ExportPattern "COLOR_RED")
-- >     ]
-- > ]
data ExportEntry =
    ExportEntry ExportItem
    -- | A Haddock section header carrying its title (as inline content,
    -- so it can mix bold\/italic\/monospace markup) and its nested children.
  | ExportSection [HsDoc.CommentInlineContent] [ExportEntry]

-- | An item in the module export list
data ExportItem =
    -- | Export a type with all its constructors and fields: @TypeName(..)@
    ExportTypeAll Text
    -- | Export a plain name (type without constructors, or term-level binding)
  | ExportName Text
    -- | Export a pattern synonym: @pattern PatName@
  | ExportPattern Text

{-------------------------------------------------------------------------------
  HsModule
-------------------------------------------------------------------------------}

-- | Haskell module
data HsModule = HsModule {
      pragmas        :: [GhcPragma]
    , name           ::  Hs.ModuleName
    , exports        :: [ExportEntry]
    , imports        :: [ImportListItem]
    , qualifiedStyle :: QualifiedStyle
      -- | Root directives, prepended to the CAPI wrapper source
    , rootDirectives :: [C.RootDirective C.HashIncludeArg]
    , cWrappers      :: [CWrapper]
    , decls          :: [SDecl]
    }

{-------------------------------------------------------------------------------
  Translation
-------------------------------------------------------------------------------}

translateModuleMultiple ::
     FieldNamingStrategy
  -> ModuleRenderConfig
  -> [C.RootDirective C.HashIncludeArg]
  -> BaseModuleName
  -> ([SDecl] -> [ExportEntry])
  -> ByCategory_ ([CWrapper], [SDecl])
  -> ByCategory_ (Maybe HsModule)
translateModuleMultiple fns mrc dirs moduleBaseName resolveExports declsByCat =
    mapWithCategory_ go declsByCat
  where
    go :: Category -> ([CWrapper], [SDecl]) -> Maybe HsModule
    go _ ([], []) = Nothing
    go cat xs     = Just $
      translateModule' fns mrc dirs (Just cat) moduleBaseName resolveExports xs

translateModuleSingle ::
     FieldNamingStrategy
  -> ModuleRenderConfig
  -> [C.RootDirective C.HashIncludeArg]
  -> BaseModuleName
  -> ([SDecl] -> [ExportEntry])
  -> ByCategory_ ([CWrapper], [SDecl])
  -> HsModule
translateModuleSingle fns mrc dirs name resolveExports declsByCat =
    translateModule' fns mrc dirs Nothing name resolveExports $
      Foldable.fold declsByCat

translateModule' ::
     FieldNamingStrategy
  -> ModuleRenderConfig
  -> [C.RootDirective C.HashIncludeArg]
  -> Maybe Category
  -> BaseModuleName
  -> ([SDecl] -> [ExportEntry])
  -> ([CWrapper], [SDecl])
  -> HsModule
translateModule' fns mrc dirs mcat moduleBaseName resolveExports (cWrappers, decs) =
    HsModule{
        pragmas        = resolvePragmas fns mrc.qualifiedStyle cWrappers decs
      , exports        = resolveExports decs
      , imports        = resolveImports moduleBaseName mcat cWrappers decs
      , name           = fromBaseModuleName moduleBaseName mcat
      , qualifiedStyle = mrc.qualifiedStyle
      , rootDirectives = dirs
      , cWrappers      = cWrappers
      , decls          = decs
      }

{-------------------------------------------------------------------------------
  Auxiliary: Pragma resolution
-------------------------------------------------------------------------------}

resolvePragmas :: FieldNamingStrategy -> QualifiedStyle -> [CWrapper] -> [SDecl] -> [GhcPragma]
resolvePragmas fieldNaming qualStyle wrappers ds =
    Set.toAscList . mconcat $
      noImplicitPreludePragma
        : omitFieldPrefixesPragmas
        : haddockPrunePragmas
        : userlandCapiPragmas
        : qualifiedPostPragma
        : map (resolveDeclPragmas fieldNaming) ds
  where
    -- Generated modules import every name they use; see 'resolveImports'.
    noImplicitPreludePragma :: Set GhcPragma
    noImplicitPreludePragma = Set.singleton "LANGUAGE NoImplicitPrelude"

    -- 'NoFieldSelectors' is the negation of the default-on 'FieldSelectors' and
    -- so cannot be carried in the positive 'TH.Extension' set (see
    -- 'HsBindgen.Backend.Extensions.omitFieldPrefixesExtensions'); we emit it as
    -- a module pragma directly. Without top-level field selectors, an unprefixed
    -- field name cannot clash with a non-field declaration of the same name.
    omitFieldPrefixesPragmas :: Set GhcPragma
    omitFieldPrefixesPragmas = case fieldNaming of
      AddFieldPrefixes  -> Set.empty
      OmitFieldPrefixes -> Set.singleton "LANGUAGE NoFieldSelectors"
    userlandCapiPragmas :: Set GhcPragma
    userlandCapiPragmas = case wrappers of
      []  -> Set.empty
      _xs -> Set.singleton "LANGUAGE TemplateHaskell"

    haddockPrunePragmas :: Set GhcPragma
    haddockPrunePragmas = case wrappers of
      []  -> Set.empty
      _xs -> Set.singleton "OPTIONS_HADDOCK prune"

    qualifiedPostPragma :: Set GhcPragma
    qualifiedPostPragma = case qualStyle of
      PreQualified  -> Set.empty
      PostQualified -> Set.singleton "LANGUAGE ImportQualifiedPost"

resolveDeclPragmas :: FieldNamingStrategy -> SDecl -> Set GhcPragma
resolveDeclPragmas fieldNaming decl =
    Set.map f (requiredExtensions fieldNaming decl)
  where
    f ext = GhcPragma ("LANGUAGE " ++ show ext)

{-------------------------------------------------------------------------------
  Auxiliary: Import resolution
-------------------------------------------------------------------------------}

-- | Resolve imports in a list of declarations
resolveImports ::
     BaseModuleName
  -> Maybe Category
  -> [CWrapper]
  -> [SDecl]
  -> [ImportListItem]
resolveImports baseModule cat wrappers ds =
    let acc = mconcat $ map resolveDeclImports ds
    in  Set.toAscList . mconcat $
            bindingCatImport acc.requireTypes
          : Set.map (uncurry QualifiedImportListItem) (userlandCapiImport <> acc.qualified)
          : map (Set.singleton . uncurry mkUImportListItem) (Map.toList acc.unqualified)
  where
    mkUImportListItem :: Hs.ModuleName -> Set ResolvedName -> ImportListItem
    mkUImportListItem m xs = UnqualifiedImportListItem m (Just $ Set.toAscList xs)

    bindingCatImport :: Bool -> Set ImportListItem
    bindingCatImport requireTypes = case requireTypes of
      False -> mempty
      True  -> case cat of
        Nothing    -> mempty
        Just CType -> mempty
        _otherCat  ->
          let moduleName = fromBaseModuleName baseModule (Just CType)
          in  Set.singleton $ UnqualifiedImportListItem moduleName Nothing

    userlandCapiImport :: Set (Hs.ModuleName, Maybe String)
    userlandCapiImport = case wrappers of
      []  -> mempty
      _xs -> Set.singleton (capiModule, Nothing)

-- | Accumulator for resolving imports
--
-- Both qualified imports and unqualified imports are accumulated.
data ImportAcc = ImportAcc {
      requireTypes :: Bool
    , qualified    :: Set (Hs.ModuleName, Maybe String)
    , unqualified  :: Map Hs.ModuleName (Set ResolvedName)
    }

instance Semigroup ImportAcc where
  a <> b = ImportAcc{
        requireTypes = combineWith (||)                 (.requireTypes)
      , qualified    = combineWith (<>)                 (.qualified)
      , unqualified  = combineWith (Map.unionWith (<>)) (.unqualified)
      }
    where
      combineWith :: (a -> a -> a) -> (ImportAcc -> a) -> a
      combineWith op f = f a `op` f b

instance Monoid ImportAcc where
  mempty = ImportAcc{
        requireTypes = False
      , qualified    = mempty
      , unqualified  = mempty
      }

-- | Resolve imports in a declaration
resolveDeclImports :: SDecl -> ImportAcc
resolveDeclImports = \case
    DTypSyn typSyn -> mconcat [
        resolveTypeImports typSyn.typ
      ]
    DInst inst -> mconcat $ concat [
        [resolveTypeClassImports inst.clss]
      , map resolveTypeImports inst.args
      , [ resolveTypeImports t | t <- inst.super ]
      , concat [
           resolveGlobalImports t : resolveTypeImports r : map resolveTypeImports as
         | (t, as, r) <- inst.types
         ]
      , concat [
            [resolveGlobalImports f, resolveExprImports e]
          | (f, e) <- inst.decs
          ]
      ]
    DRecord record -> mconcat [
        mconcat $ map (resolveTypeImports . (.typ)) record.fields
      , resolveNestedDeriv record.deriv
      ]
    DEmptyData _name ->
      mempty
    DNewtype newtyp -> mconcat [
        resolveTypeImports newtyp.field.typ
      , resolveNestedDeriv newtyp.deriv
      ]
    DDerivingInstance deriv -> mconcat [
        resolveStrategyImports deriv.strategy
      , resolveTypeImports deriv.typ
      ]
    DForeignImport foreignImport -> mconcat [
        foldMap (resolveTypeImports . (.typ)) foreignImport.parameters
      , resolveTypeImports foreignImport.result.typ
      ]
    DBinding binding -> mconcat [
        foldMap (resolveTypeImports . (.typ)) binding.parameters
      , resolveTypeImports binding.result.typ
      , resolveExprImports binding.body
      ]
    DPatternSynonym patSyn -> mconcat [
        resolveTypeImports patSyn.typ
      , resolvePatExprImports patSyn.rhs
      ]
    DCompletePragma _completePragma ->
      mempty

-- | Resolve nested deriving clauses (part of a datatype declaration)
resolveNestedDeriv :: [(Hs.Strategy ClosedType, [Inst.TypeClass])] -> ImportAcc
resolveNestedDeriv = mconcat . map aux
  where
    aux :: (Hs.Strategy ClosedType, [Inst.TypeClass]) -> ImportAcc
    aux (strategy, cls) = mconcat $
          resolveStrategyImports strategy
        : map resolveTypeClassImports cls

resolveTypeClassImports :: Inst.TypeClass -> ImportAcc
resolveTypeClassImports = resolveGlobalImports . typeClassGlobal

-- | Resolve global imports
resolveGlobalImports :: Global c -> ImportAcc
resolveGlobalImports global =
    case resolved.hsImport of
      Hs.QualifiedImport m as -> ImportAcc{
          requireTypes = False
        , qualified    = Set.singleton (m, as)
        , unqualified  = mempty
        }
      Hs.UnqualifiedImport m -> ImportAcc{
          requireTypes = False
        , qualified    = mempty
        , unqualified  = Map.singleton m (Set.singleton resolved)
        }
  where
    resolved :: ResolvedName
    resolved = resolveGlobal global

-- | Resolve imports in an expression
resolveExprImports :: SExpr ctx -> ImportAcc
resolveExprImports = \case
    EGlobal g -> resolveGlobalImports g
    EBound _x -> mempty
    EFree {} -> mempty
    ECon _n -> mempty
    EIntegral _ t -> maybe mempty resolveTypeImports t
    EUnboxedIntegral _ -> mempty
    ECChar {} -> mempty
    EString {} -> mempty
    ECString {} -> resolveGlobalImports (bindgenGlobalTerm ByteString_pack)
    EFloat _ t -> resolveTypeImports t
    EDouble _ t -> resolveTypeImports t
    EApp f x -> resolveExprImports f <> resolveExprImports x
    EInfix op x y ->
      resolveGlobalImports (infixOpGlobal op) <> resolveExprImports x <> resolveExprImports y
    ELam _mPat body -> resolveExprImports body
    EUnusedLam body -> resolveExprImports body
    ECase x alts -> mconcat $
        resolveExprImports x
      : [ case alt of
            SAlt _con _add _hints body -> resolveExprImports body
            SAltNoConstr _hints body -> resolveExprImports body
            SAltUnboxedTuple _add _hints body -> resolveExprImports body
        | alt <- alts
        ]
    EUnit -> mempty
    EBoxedTup{} -> mempty
    EUnboxedTup{} -> mempty
    EList xs -> foldMap resolveExprImports xs
    ETypeApp f t -> resolveExprImports f <> resolveTypeImports t
    ERecCon _con fbinds -> foldMap resolveFBindImports fbinds

resolveFBindImports :: FBind ctx -> ImportAcc
resolveFBindImports (FBind _label expr) = resolveExprImports expr

-- | Resolve imports in a pattern|expression
resolvePatExprImports :: PatExpr -> ImportAcc
resolvePatExprImports = \case
    PEApps _n xs -> foldMap resolvePatExprImports xs
    PELit _      -> mempty

-- | Resolve imports in a type
resolveTypeImports :: SType ctx -> ImportAcc
resolveTypeImports = \case
    TGlobal g -> resolveGlobalImports g
    TClass cls -> resolveTypeClassImports cls
    TCon _n -> ImportAcc {
        requireTypes = True
      , qualified    = mempty
      , unqualified  = mempty
      }
    TFree _ -> mempty
    TLit _n -> mempty
    TStrLit _s -> mempty
    TExt ref -> resolveExtHsRefImports ref
    TApp c x -> resolveTypeImports c <> resolveTypeImports x
    TFun a b -> resolveTypeImports a <> resolveTypeImports b
    TBound{} -> mempty
    TUnit -> mempty
    TBoxedTup{} -> mempty
    TEq -> resolveGlobalImports (bindgenGlobalType TypeEquality_type)
    TForall _hints _qtvs ctxt body ->
      foldMap resolveTypeImports (body:ctxt)
    TList t -> resolveTypeImports t

resolveStrategyImports :: Hs.Strategy ClosedType -> ImportAcc
resolveStrategyImports = \case
    Hs.DeriveNewtype -> mempty
    Hs.DeriveStock -> mempty
    Hs.DeriveVia ty -> resolveTypeImports ty

resolveExtHsRefImports :: Hs.ExtRef -> ImportAcc
resolveExtHsRefImports extRef = ImportAcc{
      requireTypes = False
    , qualified    = Set.singleton (extRef.moduleName, Nothing)
    , unqualified  = mempty
    }

{-------------------------------------------------------------------------------
  Auxiliary: Export resolution
-------------------------------------------------------------------------------}

-- | Resolve the export items contributed by a single declaration.
--
-- Returns one or more 'ExportItem' values for declarations with exported
-- (user-facing) names; internal names and instance declarations produce
-- the empty list (instances are auto-exported by GHC).
resolveDeclExports :: SDecl -> [ExportItem]
resolveDeclExports = \case
    DTypSyn typSyn               -> exportTypeConstr typSyn.name ExportName
    DRecord record               -> exportTypeConstr record.typ ExportTypeAll
    DNewtype newtyp              -> exportTypeConstr newtyp.name ExportTypeAll
    DEmptyData empty             -> exportTypeConstr empty.name ExportName
    DForeignImport foreignImport -> exportVar foreignImport.name
    DBinding binding             -> exportVar binding.name
    DPatternSynonym patSyn       -> exportPattern patSyn.name
    DCompletePragma _            -> []
    -- Instances are automatically exported by GHC
    DInst _                      -> []
    DDerivingInstance _          -> []
  where
    exportTypeConstr :: Hs.Name Hs.NsTypeConstr -> (Text -> ExportItem) -> [ExportItem]
    exportTypeConstr name mkItem = [mkItem name.text]

    exportVar :: Hs.TermName -> [ExportItem]
    exportVar name = case name of
      Hs.ExportedName n -> [ExportName n.text]
      Hs.InternalName _ -> []

    exportPattern :: Hs.Name Hs.NsConstr -> [ExportItem]
    exportPattern name = [ExportPattern name.text]