{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wwarn #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Haddock.Interface.Create
-- Copyright   :  (c) Simon Marlow      2003-2006,
--                    David Waern       2006-2009,
--                    Mateusz Kowalczyk 2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- This module provides a single function 'createInterface',
-- which creates a Haddock 'Interface' from the typechecking
-- results 'TypecheckedModule' from GHC.
module Haddock.Interface.Create (IfM, runIfM, createInterface1, createInterface1') where

import Control.Arrow (first, (&&&))
import Control.DeepSeq
import Control.Monad.State.Strict
import Data.Foldable
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, isJust, mapMaybe, maybeToList)
import Data.Traversable (for)
import GHC hiding (lookupName)
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
import GHC.Core.ConLike (ConLike (..))
import GHC.Data.FastString (FastString, bytesFS, unpackFS)
import qualified GHC.Driver.Config.Parser as Parser
import qualified GHC.Driver.DynFlags as DynFlags
import GHC.Driver.Ppr
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Iface.Syntax
import GHC.Parser.Lexer (ParserOpts)
import GHC.Types.Avail
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SafeHaskell
import qualified GHC.Types.SrcLoc as SrcLoc
import qualified GHC.Types.Unique.Map as UniqMap
import GHC.Unit.Module.ModIface
import GHC.Unit.State (PackageName (..), UnitState)
import GHC.Utils.Outputable (SDocContext)
import qualified GHC.Utils.Outputable as O
import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic (pprPanic)

import Documentation.Haddock.Doc
import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl)
import Haddock.GhcUtils
import Haddock.Interface.LexParseRn
import Haddock.Options (Flag (..), modulePackageInfo)
import Haddock.Types
import Haddock.Utils (replace)

createInterface1
  :: MonadIO m
  => [Flag]
  -> UnitState
  -> ModSummary
  -> ModIface
  -> IfaceMap
  -> InstIfaceMap
  -> ([ClsInst], [FamInst])
  -> WarningMap
  -> IfM m Interface
createInterface1 :: forall (m :: Type -> Type).
MonadIO m =>
[Flag]
-> UnitState
-> ModSummary
-> ModIface
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
-> WarningMap
-> IfM m Interface
createInterface1 [Flag]
flags UnitState
unit_state ModSummary
mod_sum ModIface
mod_iface IfaceMap
ifaces InstIfaceMap
inst_ifaces ([ClsInst]
instances, [FamInst]
fam_instances) WarningMap
depWarnings =
  let
    ModSummary
      { -- Cached flags from OPTIONS, INCLUDE and LANGUAGE
      -- pragmas in the modules source code. Used to infer
      -- safety of module.
      DynFlags
ms_hspp_opts :: DynFlags
ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts
      , ms_location :: ModSummary -> ModLocation
ms_location = ModLocation
modl
      } = ModSummary
mod_sum
   in
    [Flag]
-> UnitState
-> DynFlags
-> String
-> ModIface
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
-> WarningMap
-> IfM m Interface
forall (m :: Type -> Type).
MonadIO m =>
[Flag]
-> UnitState
-> DynFlags
-> String
-> ModIface
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
-> WarningMap
-> IfM m Interface
createInterface1' [Flag]
flags UnitState
unit_state DynFlags
ms_hspp_opts (ModLocation -> String
ml_hie_file ModLocation
modl) ModIface
mod_iface IfaceMap
ifaces InstIfaceMap
inst_ifaces ([ClsInst]
instances, [FamInst]
fam_instances) WarningMap
depWarnings

createInterface1'
  :: MonadIO m
  => [Flag]
  -> UnitState
  -> DynFlags
  -> FilePath
  -> ModIface
  -> IfaceMap
  -> InstIfaceMap
  -> ([ClsInst], [FamInst])
  -> WarningMap
  -> IfM m Interface
createInterface1' :: forall (m :: Type -> Type).
MonadIO m =>
[Flag]
-> UnitState
-> DynFlags
-> String
-> ModIface
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
-> WarningMap
-> IfM m Interface
createInterface1' [Flag]
flags UnitState
unit_state DynFlags
dflags String
hie_file ModIface
mod_iface IfaceMap
ifaces InstIfaceMap
inst_ifaces ([ClsInst]
instances, [FamInst]
fam_instances) WarningMap
depWarnings = do
  let
    sDocContext :: SDocContext
sDocContext = DynFlags -> PprStyle -> SDocContext
DynFlags.initSDocContext DynFlags
dflags PprStyle
Outputable.defaultUserStyle
    mLanguage :: Maybe Language
mLanguage = DynFlags -> Maybe Language
language DynFlags
dflags
    parserOpts :: ParserOpts
parserOpts = DynFlags -> ParserOpts
Parser.initParserOpts DynFlags
dflags
    mdl :: Module
mdl = ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
mod_iface
    sem_mdl :: Module
sem_mdl = ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_semantic_module ModIface
mod_iface
    is_sig :: Bool
is_sig = Maybe Module -> Bool
forall a. Maybe a -> Bool
isJust (ModIface -> Maybe Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Maybe Module
mi_sig_of ModIface
mod_iface)
    safety :: SafeHaskellMode
safety = IfaceTrustInfo -> SafeHaskellMode
getSafeMode (ModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust ModIface
mod_iface)

    (Maybe PackageName
pkg_name_fs, Maybe Version
_) =
      UnitState
-> [Flag] -> Maybe Module -> (Maybe PackageName, Maybe Version)
modulePackageInfo UnitState
unit_state [Flag]
flags (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
mdl)

    pkg_name :: Maybe Package
    pkg_name :: Maybe String
pkg_name =
      let
        unpack :: PackageName -> String
unpack (PackageName FastString
name) = FastString -> String
unpackFS FastString
name
       in
        (PackageName -> String) -> Maybe PackageName -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> String
unpack Maybe PackageName
pkg_name_fs

    warnings :: IfaceWarnings
warnings = ModIface -> IfaceWarnings
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceWarnings
mi_warns ModIface
mod_iface

    -- See Note [Exporting built-in items]
    special_exports :: [AvailInfo]
special_exports
      | Module
mdl Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_PRIM = [AvailInfo]
funAvail
      | Bool
otherwise = []
    !exportedNames :: [Name]
exportedNames =
      (AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap
        AvailInfo -> [Name]
availNames
        ([AvailInfo]
special_exports [AvailInfo] -> [AvailInfo] -> [AvailInfo]
forall a. Semigroup a => a -> a -> a
<> ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
mod_iface)

    fixities :: FixMap
    fixities :: FixMap
fixities = [Name] -> [(OccName, Fixity)] -> FixMap
mkFixMap [Name]
exportedNames (ModIface -> [(OccName, Fixity)]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities ModIface
mod_iface)

    -- This is used for looking up the Name of a default method
    -- from its OccName. See Note [default method Name] in GHC.Iface.Recomp
    def_meths_env :: OccEnv Name
def_meths_env = [(OccName, Name)] -> OccEnv Name
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [(OccName, Name)]
def_meths
    def_meths :: [(OccName, Name)]
def_meths =
      [ (Name -> OccName
nameOccName Name
nm, Name
nm)
      | (Fingerprint
_, IfaceId{ifName :: IfaceDecl -> Name
ifName = Name
nm}) <- ModIface -> [IfaceDeclExts 'ModIfaceFinal]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls ModIface
mod_iface
      , let occ :: OccName
occ = Name -> OccName
nameOccName Name
nm
      , OccName -> Bool
isDefaultMethodOcc OccName
occ
      ]

  mod_iface_docs <- case ModIface -> Maybe Docs
forall (phase :: ModIfacePhase). ModIface_ phase -> Maybe Docs
mi_docs ModIface
mod_iface of
    Just Docs
docs -> Docs -> IfM m Docs
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Docs
docs
    Maybe Docs
Nothing -> do
      String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn (String -> IfM m ()) -> String -> IfM m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Module -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags Module
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no docs in its .hi file"
      Docs -> IfM m Docs
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Docs
emptyDocs
  -- Derive final options to use for haddocking this module
  doc_opts <- mkDocOpts (docs_haddock_opts mod_iface_docs) flags mdl

  let prr
        | DocOption
OptPrintRuntimeRep DocOption -> [DocOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [DocOption]
doc_opts = PrintRuntimeReps
ShowRuntimeRep
        | Bool
otherwise = PrintRuntimeReps
HideRuntimeRep

  (!info, header_doc) <-
    processModuleHeader
      mLanguage
      parserOpts
      sDocContext
      pkg_name
      safety
      (docs_language mod_iface_docs)
      (docs_extensions mod_iface_docs)
      (docs_mod_hdr mod_iface_docs)
  mod_warning <- moduleWarning parserOpts sDocContext warnings

  (docMap :: DocMap Name) <- do
    let docsDecls = [(Name, [HsDoc GhcRn])] -> Map Name [HsDoc GhcRn]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, [HsDoc GhcRn])] -> Map Name [HsDoc GhcRn])
-> [(Name, [HsDoc GhcRn])] -> Map Name [HsDoc GhcRn]
forall a b. (a -> b) -> a -> b
$ UniqMap Name [HsDoc GhcRn] -> [(Name, [HsDoc GhcRn])]
forall k a. UniqMap k a -> [(k, a)]
UniqMap.nonDetUniqMapToList Docs
mod_iface_docs.docs_decls
    traverse (processDocStringsParas parserOpts sDocContext pkg_name) docsDecls

  exportsSinceMap <- mkExportSinceMap parserOpts sDocContext pkg_name mod_iface_docs

  (argMap :: Map Name (Map Int (MDoc Name))) <- do
    let docsArgs = [(Name, IntMap (HsDoc GhcRn))] -> Map Name (IntMap (HsDoc GhcRn))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, IntMap (HsDoc GhcRn))] -> Map Name (IntMap (HsDoc GhcRn)))
-> [(Name, IntMap (HsDoc GhcRn))]
-> Map Name (IntMap (HsDoc GhcRn))
forall a b. (a -> b) -> a -> b
$ UniqMap Name (IntMap (HsDoc GhcRn))
-> [(Name, IntMap (HsDoc GhcRn))]
forall k a. UniqMap k a -> [(k, a)]
UniqMap.nonDetUniqMapToList Docs
mod_iface_docs.docs_args
    (result :: Map Name (IntMap (MDoc Name))) <-
      traverse (traverse (processDocStringParas parserOpts sDocContext pkg_name)) docsArgs
    let result2 = (IntMap (MDoc Name) -> Map Key (MDoc Name))
-> Map Name (IntMap (MDoc Name)) -> Map Name (Map Key (MDoc Name))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\IntMap (MDoc Name)
intMap -> [(Key, MDoc Name)] -> Map Key (MDoc Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Key, MDoc Name)] -> Map Key (MDoc Name))
-> [(Key, MDoc Name)] -> Map Key (MDoc Name)
forall a b. (a -> b) -> a -> b
$ IntMap (MDoc Name) -> [(Key, MDoc Name)]
forall a. IntMap a -> [(Key, a)]
IM.assocs IntMap (MDoc Name)
intMap) Map Name (IntMap (MDoc Name))
result
    pure result2

  warningMap <- mkWarningMap parserOpts sDocContext warnings exportedNames

  let local_instances =
        (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> Name -> Bool
nameIsLocalOrFrom Module
sem_mdl) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$
          (ClsInst -> Name) -> [ClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> Name
forall a. NamedThing a => a -> Name
getName [ClsInst]
instances
            [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (FamInst -> Name) -> [FamInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> Name
forall a. NamedThing a => a -> Name
getName [FamInst]
fam_instances
      instanceMap = [(RealSrcSpan, Name)] -> Map RealSrcSpan Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RealSrcSpan
l, Name
n) | Name
n <- [Name]
local_instances, RealSrcSpan RealSrcSpan
l Maybe BufSpan
_ <- [Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n]]

  -- See Note [Exporting built-in items]
  let builtinTys = Key -> HsDoc GhcRn -> DocStructureItem
DsiSectionHeading Key
1 (HsDocString -> [Located (IdP GhcRn)] -> HsDoc GhcRn
forall a pass.
a -> [Located (IdP pass)] -> WithHsDocIdentifiers a pass
WithHsDocIdentifiers (String -> HsDocString
mkGeneratedHsDocString String
"Builtin syntax") [])
      bonus_ds [DocStructureItem]
mods
        | Module
mdl Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_PRIM = [DocStructureItem
builtinTys, [AvailInfo] -> DocStructureItem
DsiExports [AvailInfo]
funAvail] [DocStructureItem] -> [DocStructureItem] -> [DocStructureItem]
forall a. Semigroup a => a -> a -> a
<> [DocStructureItem]
mods
        | Bool
otherwise = [DocStructureItem]
mods

  let
    -- Warnings in this module and transitive warnings from dependent modules
    transitiveWarnings :: Map Name (Doc Name)
    transitiveWarnings = WarningMap -> WarningMap -> WarningMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union WarningMap
warningMap WarningMap
depWarnings

  export_items <-
    mkExportItems
      prr
      ifaces
      pkg_name
      mdl
      transitiveWarnings
      exportsSinceMap
      docMap
      argMap
      fixities
      (docs_named_chunks mod_iface_docs)
      (bonus_ds $ docs_structure mod_iface_docs)
      inst_ifaces
      dflags
      parserOpts
      sDocContext
      def_meths_env

  let
    visible_names :: [Name]
    visible_names = Map RealSrcSpan Name -> [ExportItem GhcRn] -> [DocOption] -> [Name]
mkVisibleNames Map RealSrcSpan Name
instanceMap [ExportItem GhcRn]
export_items [DocOption]
doc_opts

    -- Measure haddock documentation coverage.
    pruned_export_items :: [ExportItem GhcRn]
    pruned_export_items = [ExportItem GhcRn] -> [ExportItem GhcRn]
pruneExportItems [ExportItem GhcRn]
export_items

    !haddockable = Key
1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ [ExportItem GhcRn] -> Key
forall a. [a] -> Key
forall (t :: Type -> Type) a. Foldable t => t a -> Key
length [ExportItem GhcRn]
export_items -- module + exports
    !haddocked = (if Maybe (MDoc Name) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (MDoc Name)
header_doc then Key
1 else Key
0) Key -> Key -> Key
forall a. Num a => a -> a -> a
+ [ExportItem GhcRn] -> Key
forall a. [a] -> Key
forall (t :: Type -> Type) a. Foldable t => t a -> Key
length [ExportItem GhcRn]
pruned_export_items

    coverage :: (Int, Int)
    !coverage = (Key
haddockable, Key
haddocked)

  return $!
    Interface
      { ifaceMod = mdl
      , ifaceIsSig = is_sig
      , ifaceHieFile = hie_file
      , ifaceInfo = info
      , ifaceDoc = Documentation header_doc mod_warning
      , ifaceRnDoc = Documentation Nothing Nothing
      , ifaceOptions = doc_opts
      , ifaceDocMap = docMap
      , ifaceArgMap = argMap
      , ifaceExportItems =
          if OptPrune `elem` doc_opts
            then pruned_export_items
            else export_items
      , ifaceRnExportItems = []
      , ifaceExports = exportedNames
      , ifaceVisibleExports = visible_names
      , ifaceFixMap = fixities
      , ifaceInstances = instances
      , ifaceOrphanInstances = [] -- Filled in attachInstances
      , ifaceRnOrphanInstances = [] -- Filled in renameInterfaceRn
      , ifaceHaddockCoverage = coverage
      , ifaceWarningMap = warningMap
      , ifaceDynFlags = dflags
      , ifaceDefMeths = def_meths
      }
  where
    -- Note [Exporting built-in items]
    --
    -- @(->)@ does not show up in module exports simply because Haskell
    -- lacks the concrete syntax to represent such an export. We'd still like
    -- it to show up in docs, so we manually patch "GHC.Prim" and "Prelude"
    -- to have an extra exports for @(->)@
    --
    funAvail :: [AvailInfo]
funAvail = [Name -> [Name] -> AvailInfo
AvailTC Name
fUNTyConName [Name
fUNTyConName]]

-------------------------------------------------------------------------------
-- Export @since annotations
-------------------------------------------------------------------------------
mkExportSinceMap
  :: forall m
   . MonadIO m
  => ParserOpts
  -> SDocContext
  -> Maybe Package
  -> Docs
  -> IfM m (Map Name MetaSince)
mkExportSinceMap :: forall (m :: Type -> Type).
MonadIO m =>
ParserOpts
-> SDocContext
-> Maybe String
-> Docs
-> IfM m (Map Name MetaSince)
mkExportSinceMap ParserOpts
parserOpts SDocContext
sDocContext Maybe String
pkg_name Docs
docs = do
  [Map Name MetaSince] -> Map Name MetaSince
forall (f :: Type -> Type) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map Name MetaSince] -> Map Name MetaSince)
-> IfM m [Map Name MetaSince] -> IfM m (Map Name MetaSince)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, HsDoc GhcRn) -> IfM m (Map Name MetaSince))
-> [(Name, HsDoc GhcRn)] -> IfM m [Map Name MetaSince]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Name, HsDoc GhcRn) -> IfM m (Map Name MetaSince)
processExportDoc (UniqMap Name (HsDoc GhcRn) -> [(Name, HsDoc GhcRn)]
forall k a. UniqMap k a -> [(k, a)]
UniqMap.nonDetUniqMapToList (Docs -> UniqMap Name (HsDoc GhcRn)
docs_exports Docs
docs))
  where
    processExportDoc :: (Name, HsDoc GhcRn) -> IfM m (Map Name MetaSince)
    processExportDoc :: (Name, HsDoc GhcRn) -> IfM m (Map Name MetaSince)
processExportDoc (Name
nm, HsDoc GhcRn
doc) = do
      mdoc <- ParserOpts
-> SDocContext
-> Maybe String
-> [HsDoc GhcRn]
-> IfM m (MDoc Name)
forall (m :: Type -> Type).
MonadIO m =>
ParserOpts
-> SDocContext
-> Maybe String
-> [HsDoc GhcRn]
-> IfM m (MDoc Name)
processDocStringsParas ParserOpts
parserOpts SDocContext
sDocContext Maybe String
pkg_name [HsDoc GhcRn
doc]
      case _doc mdoc of
        Doc Name
DocEmpty -> () -> IfM m ()
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
        Doc Name
_ -> String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn String
"Export docstrings may only contain @since annotations"
      case _metaSince (_meta mdoc) of
        Maybe MetaSince
Nothing -> Map Name MetaSince -> IfM m (Map Name MetaSince)
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Map Name MetaSince
forall a. Monoid a => a
mempty
        Just MetaSince
since -> Map Name MetaSince -> IfM m (Map Name MetaSince)
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Map Name MetaSince -> IfM m (Map Name MetaSince))
-> Map Name MetaSince -> IfM m (Map Name MetaSince)
forall a b. (a -> b) -> a -> b
$ Name -> MetaSince -> Map Name MetaSince
forall k a. k -> a -> Map k a
Map.singleton Name
nm MetaSince
since

-------------------------------------------------------------------------------
-- Warnings
-------------------------------------------------------------------------------

mkWarningMap
  :: MonadIO m
  => ParserOpts
  -> SDocContext
  -> IfaceWarnings
  -> [Name]
  -> IfM m WarningMap
mkWarningMap :: forall (m :: Type -> Type).
MonadIO m =>
ParserOpts
-> SDocContext -> IfaceWarnings -> [Name] -> IfM m WarningMap
mkWarningMap ParserOpts
parserOpts SDocContext
sDocContext IfaceWarnings
warnings [Name]
exps =
  case IfaceWarnings
warnings of
    IfWarnSome [(OccName, IfaceWarningTxt)]
ws [(Name, IfaceWarningTxt)]
_ ->
      let expsOccEnv :: OccEnv Name
expsOccEnv = [(OccName, Name)] -> OccEnv Name
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [(Name -> OccName
nameOccName Name
n, Name
n) | Name
n <- [Name]
exps]
          ws' :: [(Name, IfaceWarningTxt)]
ws' = (((OccName, IfaceWarningTxt) -> Maybe (Name, IfaceWarningTxt))
 -> [(OccName, IfaceWarningTxt)] -> [(Name, IfaceWarningTxt)])
-> [(OccName, IfaceWarningTxt)]
-> ((OccName, IfaceWarningTxt) -> Maybe (Name, IfaceWarningTxt))
-> [(Name, IfaceWarningTxt)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((OccName, IfaceWarningTxt) -> Maybe (Name, IfaceWarningTxt))
-> [(OccName, IfaceWarningTxt)] -> [(Name, IfaceWarningTxt)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [(OccName, IfaceWarningTxt)]
ws (((OccName, IfaceWarningTxt) -> Maybe (Name, IfaceWarningTxt))
 -> [(Name, IfaceWarningTxt)])
-> ((OccName, IfaceWarningTxt) -> Maybe (Name, IfaceWarningTxt))
-> [(Name, IfaceWarningTxt)]
forall a b. (a -> b) -> a -> b
$ \(OccName
occ, IfaceWarningTxt
w) ->
            -- Ensure we also look in the record field namespace. If the OccName
            -- resolves to multiple GREs, take the first.
            case OccEnv Name -> OccName -> [Name]
forall a. OccEnv a -> OccName -> [a]
lookupOccEnv_WithFields OccEnv Name
expsOccEnv OccName
occ of
              (Name
n : [Name]
_) -> (Name, IfaceWarningTxt) -> Maybe (Name, IfaceWarningTxt)
forall a. a -> Maybe a
Just (Name
n, IfaceWarningTxt
w)
              [] -> Maybe (Name, IfaceWarningTxt)
forall a. Maybe a
Nothing
       in [(Name, Doc Name)] -> WarningMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Doc Name)] -> WarningMap)
-> IfM m [(Name, Doc Name)] -> IfM m WarningMap
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, IfaceWarningTxt) -> IfM m (Name, Doc Name))
-> [(Name, IfaceWarningTxt)] -> IfM m [(Name, Doc Name)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((IfaceWarningTxt -> IfM m (Doc Name))
-> (Name, IfaceWarningTxt) -> IfM m (Name, Doc Name)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> (Name, a) -> f (Name, b)
traverse (ParserOpts -> SDocContext -> IfaceWarningTxt -> IfM m (Doc Name)
forall (m :: Type -> Type).
MonadIO m =>
ParserOpts -> SDocContext -> IfaceWarningTxt -> IfM m (Doc Name)
parseWarning ParserOpts
parserOpts SDocContext
sDocContext)) [(Name, IfaceWarningTxt)]
ws'
    IfaceWarnings
_ -> WarningMap -> IfM m WarningMap
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure WarningMap
forall k a. Map k a
Map.empty

moduleWarning
  :: MonadIO m
  => ParserOpts
  -> SDocContext
  -> IfaceWarnings
  -> IfM m (Maybe (Doc Name))
moduleWarning :: forall (m :: Type -> Type).
MonadIO m =>
ParserOpts
-> SDocContext -> IfaceWarnings -> IfM m (Maybe (Doc Name))
moduleWarning ParserOpts
parserOpts SDocContext
sDocContext (IfWarnAll IfaceWarningTxt
w) = Doc Name -> Maybe (Doc Name)
forall a. a -> Maybe a
Just (Doc Name -> Maybe (Doc Name))
-> IfM m (Doc Name) -> IfM m (Maybe (Doc Name))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserOpts -> SDocContext -> IfaceWarningTxt -> IfM m (Doc Name)
forall (m :: Type -> Type).
MonadIO m =>
ParserOpts -> SDocContext -> IfaceWarningTxt -> IfM m (Doc Name)
parseWarning ParserOpts
parserOpts SDocContext
sDocContext IfaceWarningTxt
w
moduleWarning ParserOpts
_ SDocContext
_ IfaceWarnings
_ = Maybe (Doc Name) -> IfM m (Maybe (Doc Name))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Doc Name)
forall a. Maybe a
Nothing

parseWarning
  :: MonadIO m
  => ParserOpts
  -> SDocContext
  -> IfaceWarningTxt
  -> IfM m (Doc Name)
parseWarning :: forall (m :: Type -> Type).
MonadIO m =>
ParserOpts -> SDocContext -> IfaceWarningTxt -> IfM m (Doc Name)
parseWarning ParserOpts
parserOpts SDocContext
sDocContext IfaceWarningTxt
w = case IfaceWarningTxt
w of
  IfDeprecatedTxt SourceText
_ [(IfaceStringLiteral, [Name])]
msg -> String -> [HsDoc GhcRn] -> IfM m (Doc Name)
format String
"Deprecated: " (((IfaceStringLiteral, [Name]) -> HsDoc GhcRn)
-> [(IfaceStringLiteral, [Name])] -> [HsDoc GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (IfaceStringLiteral, [Name]) -> HsDoc GhcRn
dstToDoc [(IfaceStringLiteral, [Name])]
msg)
  IfWarningTxt Maybe WarningCategory
_ SourceText
_ [(IfaceStringLiteral, [Name])]
msg -> String -> [HsDoc GhcRn] -> IfM m (Doc Name)
format String
"Warning: " (((IfaceStringLiteral, [Name]) -> HsDoc GhcRn)
-> [(IfaceStringLiteral, [Name])] -> [HsDoc GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (IfaceStringLiteral, [Name]) -> HsDoc GhcRn
dstToDoc [(IfaceStringLiteral, [Name])]
msg)
  where
    dstToDoc :: (IfaceStringLiteral, [Name]) -> HsDoc GhcRn
    dstToDoc :: (IfaceStringLiteral, [Name]) -> HsDoc GhcRn
dstToDoc ((IfStringLiteral SourceText
_ FastString
fs), [Name]
ids) = HsDocString -> [Located (IdP GhcRn)] -> HsDoc GhcRn
forall a pass.
a -> [Located (IdP pass)] -> WithHsDocIdentifiers a pass
WithHsDocIdentifiers (FastString -> HsDocString
fsToDoc FastString
fs) ((Name -> Located Name) -> [Name] -> [Located Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Located Name
forall e. e -> Located e
noLoc [Name]
ids)

    fsToDoc :: FastString -> HsDocString
    fsToDoc :: FastString -> HsDocString
fsToDoc FastString
fs = HsDocStringChunk -> HsDocString
GeneratedDocString (HsDocStringChunk -> HsDocString)
-> HsDocStringChunk -> HsDocString
forall a b. (a -> b) -> a -> b
$ ByteString -> HsDocStringChunk
HsDocStringChunk (FastString -> ByteString
bytesFS FastString
fs)

    format :: String -> [HsDoc GhcRn] -> IfM m (Doc Name)
format String
x [HsDoc GhcRn]
bs =
      Doc Name -> Doc Name
forall mod id. DocH mod id -> DocH mod id
DocWarning (Doc Name -> Doc Name)
-> (Doc Name -> Doc Name) -> Doc Name -> Doc Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Name -> Doc Name
forall mod id. DocH mod id -> DocH mod id
DocParagraph (Doc Name -> Doc Name)
-> (Doc Name -> Doc Name) -> Doc Name -> Doc Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Name -> Doc Name -> Doc Name
forall mod id. DocH mod id -> DocH mod id -> DocH mod id
DocAppend (String -> Doc Name
forall mod id. String -> DocH mod id
DocString String
x)
        (Doc Name -> Doc Name) -> IfM m (Doc Name) -> IfM m (Doc Name)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (HsDoc GhcRn -> Doc Name -> IfM m (Doc Name))
-> Doc Name -> [HsDoc GhcRn] -> IfM m (Doc Name)
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (\HsDoc GhcRn
doc Doc Name
rest -> Doc Name -> Doc Name -> Doc Name
forall mod id. DocH mod id -> DocH mod id -> DocH mod id
docAppend (Doc Name -> Doc Name -> Doc Name)
-> IfM m (Doc Name) -> IfM m (Doc Name -> Doc Name)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserOpts -> SDocContext -> HsDoc GhcRn -> IfM m (Doc Name)
forall (m :: Type -> Type).
MonadIO m =>
ParserOpts -> SDocContext -> HsDoc GhcRn -> IfM m (Doc Name)
processDocString ParserOpts
parserOpts SDocContext
sDocContext HsDoc GhcRn
doc IfM m (Doc Name -> Doc Name)
-> IfM m (Doc Name) -> IfM m (Doc Name)
forall a b. IfM m (a -> b) -> IfM m a -> IfM m b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Doc Name -> IfM m (Doc Name)
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Doc Name
rest) Doc Name
forall mod id. DocH mod id
DocEmpty [HsDoc GhcRn]
bs

-------------------------------------------------------------------------------
-- Doc options
--
-- Haddock options that are embedded in the source file
-------------------------------------------------------------------------------

mkDocOpts :: MonadIO m => Maybe String -> [Flag] -> Module -> IfM m [DocOption]
mkDocOpts :: forall (m :: Type -> Type).
MonadIO m =>
Maybe String -> [Flag] -> Module -> IfM m [DocOption]
mkDocOpts Maybe String
mbOpts [Flag]
flags Module
mdl = do
  opts <- case Maybe String
mbOpts of
    Just String
opts -> case String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Char -> Char -> String -> String
forall a. Eq a => a -> a -> [a] -> [a]
replace Char
',' Char
' ' String
opts of
      [] -> String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn String
"No option supplied to DOC_OPTION/doc_option" IfM m () -> IfM m [DocOption] -> IfM m [DocOption]
forall a b. IfM m a -> IfM m b -> IfM m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> [DocOption] -> IfM m [DocOption]
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
      [String]
xs -> ([Maybe DocOption] -> [DocOption])
-> IfM m [Maybe DocOption] -> IfM m [DocOption]
forall a b. (a -> b) -> IfM m a -> IfM m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe DocOption] -> [DocOption]
forall a. [Maybe a] -> [a]
catMaybes ((String -> IfM m (Maybe DocOption))
-> [String] -> IfM m [Maybe DocOption]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM String -> IfM m (Maybe DocOption)
forall (m :: Type -> Type).
MonadIO m =>
String -> IfM m (Maybe DocOption)
parseOption [String]
xs)
    Maybe String
Nothing -> [DocOption] -> IfM m [DocOption]
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
  pure (foldl go opts flags)
  where
    mdlStr :: String
mdlStr = Module -> String
moduleString Module
mdl

    -- Later flags override earlier ones
    go :: [DocOption] -> Flag -> [DocOption]
go [DocOption]
os Flag
m
      | Flag
m Flag -> Flag -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Flag
Flag_HideModule String
mdlStr = DocOption
OptHide DocOption -> [DocOption] -> [DocOption]
forall a. a -> [a] -> [a]
: [DocOption]
os
      | Flag
m Flag -> Flag -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Flag
Flag_ShowModule String
mdlStr = (DocOption -> Bool) -> [DocOption] -> [DocOption]
forall a. (a -> Bool) -> [a] -> [a]
filter (DocOption -> DocOption -> Bool
forall a. Eq a => a -> a -> Bool
/= DocOption
OptHide) [DocOption]
os
      | Flag
m Flag -> Flag -> Bool
forall a. Eq a => a -> a -> Bool
== Flag
Flag_ShowAllModules = (DocOption -> Bool) -> [DocOption] -> [DocOption]
forall a. (a -> Bool) -> [a] -> [a]
filter (DocOption -> DocOption -> Bool
forall a. Eq a => a -> a -> Bool
/= DocOption
OptHide) [DocOption]
os
      | Flag
m Flag -> Flag -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Flag
Flag_ShowExtensions String
mdlStr = DocOption
OptShowExtensions DocOption -> [DocOption] -> [DocOption]
forall a. a -> [a] -> [a]
: [DocOption]
os
      | Bool
otherwise = [DocOption]
os

parseOption :: MonadIO m => String -> IfM m (Maybe DocOption)
parseOption :: forall (m :: Type -> Type).
MonadIO m =>
String -> IfM m (Maybe DocOption)
parseOption String
"hide" = Maybe DocOption -> IfM m (Maybe DocOption)
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DocOption -> Maybe DocOption
forall a. a -> Maybe a
Just DocOption
OptHide)
parseOption String
"prune" = Maybe DocOption -> IfM m (Maybe DocOption)
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DocOption -> Maybe DocOption
forall a. a -> Maybe a
Just DocOption
OptPrune)
parseOption String
"not-home" = Maybe DocOption -> IfM m (Maybe DocOption)
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DocOption -> Maybe DocOption
forall a. a -> Maybe a
Just DocOption
OptNotHome)
parseOption String
"show-extensions" = Maybe DocOption -> IfM m (Maybe DocOption)
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DocOption -> Maybe DocOption
forall a. a -> Maybe a
Just DocOption
OptShowExtensions)
parseOption String
"print-explicit-runtime-reps" = Maybe DocOption -> IfM m (Maybe DocOption)
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DocOption -> Maybe DocOption
forall a. a -> Maybe a
Just DocOption
OptPrintRuntimeRep)
parseOption String
other = String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn (String
"Unrecognised option: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
other) IfM m () -> IfM m (Maybe DocOption) -> IfM m (Maybe DocOption)
forall a b. IfM m a -> IfM m b -> IfM m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Maybe DocOption -> IfM m (Maybe DocOption)
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe DocOption
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- Declarations
--------------------------------------------------------------------------------

-- | Extract a map of fixity declarations only
mkFixMap :: [Name] -> [(OccName, Fixity)] -> FixMap
mkFixMap :: [Name] -> [(OccName, Fixity)] -> FixMap
mkFixMap [Name]
exps [(OccName, Fixity)]
occFixs =
  [(Name, Fixity)] -> FixMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Fixity)] -> FixMap) -> [(Name, Fixity)] -> FixMap
forall a b. (a -> b) -> a -> b
$ (((OccName, Fixity) -> Maybe (Name, Fixity))
 -> [(OccName, Fixity)] -> [(Name, Fixity)])
-> [(OccName, Fixity)]
-> ((OccName, Fixity) -> Maybe (Name, Fixity))
-> [(Name, Fixity)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((OccName, Fixity) -> Maybe (Name, Fixity))
-> [(OccName, Fixity)] -> [(Name, Fixity)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [(OccName, Fixity)]
occFixs (((OccName, Fixity) -> Maybe (Name, Fixity)) -> [(Name, Fixity)])
-> ((OccName, Fixity) -> Maybe (Name, Fixity)) -> [(Name, Fixity)]
forall a b. (a -> b) -> a -> b
$ \(OccName
occ, Fixity
fix_) ->
    (,Fixity
fix_) (Name -> (Name, Fixity)) -> Maybe Name -> Maybe (Name, Fixity)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> OccEnv Name -> OccName -> Maybe Name
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv Name
expsOccEnv OccName
occ
  where
    expsOccEnv :: OccEnv Name
expsOccEnv = [(OccName, Name)] -> OccEnv Name
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv ((Name -> (OccName, Name)) -> [Name] -> [(OccName, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> OccName
nameOccName (Name -> OccName) -> (Name -> Name) -> Name -> (OccName, Name)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Name -> Name
forall a. a -> a
id) [Name]
exps)

-- | Build the list of items that will become the documentation, from the
-- export list.  At this point, the list of ExportItems is in terms of
-- original names.
--
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
  :: MonadIO m
  => PrintRuntimeReps
  -> IfaceMap
  -> Maybe Package -- this package
  -> Module -- this module
  -> WarningMap
  -> Map Name MetaSince
  -> DocMap Name
  -> ArgMap Name
  -> FixMap
  -> Map String (HsDoc GhcRn) -- named chunks
  -> DocStructure
  -> InstIfaceMap
  -> DynFlags
  -> ParserOpts
  -> SDocContext
  -> OccEnv Name
  -> IfM m [ExportItem GhcRn]
mkExportItems :: forall (m :: Type -> Type).
MonadIO m =>
PrintRuntimeReps
-> IfaceMap
-> Maybe String
-> Module
-> WarningMap
-> Map Name MetaSince
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> FixMap
-> Map String (HsDoc GhcRn)
-> [DocStructureItem]
-> InstIfaceMap
-> DynFlags
-> ParserOpts
-> SDocContext
-> OccEnv Name
-> IfM m [ExportItem GhcRn]
mkExportItems
  PrintRuntimeReps
prr
  IfaceMap
modMap
  Maybe String
pkgName
  Module
thisMod
  WarningMap
warnings
  Map Name MetaSince
exportSinceMap
  DocMap Name
docMap
  Map Name (Map Key (MDoc Name))
argMap
  FixMap
fixMap
  Map String (HsDoc GhcRn)
namedChunks
  [DocStructureItem]
dsItems
  InstIfaceMap
instIfaceMap
  DynFlags
dflags
  ParserOpts
parserOpts
  SDocContext
sDocContext
  OccEnv Name
defMeths =
    [[ExportItem GhcRn]] -> [ExportItem GhcRn]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[ExportItem GhcRn]] -> [ExportItem GhcRn])
-> IfM m [[ExportItem GhcRn]] -> IfM m [ExportItem GhcRn]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DocStructureItem -> IfM m [ExportItem GhcRn])
-> [DocStructureItem] -> IfM m [[ExportItem GhcRn]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse DocStructureItem -> IfM m [ExportItem GhcRn]
forall (m :: Type -> Type).
MonadIO m =>
DocStructureItem -> IfM m [ExportItem GhcRn]
lookupExport [DocStructureItem]
dsItems
    where
      lookupExport :: MonadIO m => DocStructureItem -> IfM m [ExportItem GhcRn]
      lookupExport :: forall (m :: Type -> Type).
MonadIO m =>
DocStructureItem -> IfM m [ExportItem GhcRn]
lookupExport = \case
        DsiSectionHeading Key
lev HsDoc GhcRn
hsDoc' -> do
          doc <- ParserOpts -> SDocContext -> HsDoc GhcRn -> IfM m (Doc Name)
forall (m :: Type -> Type).
MonadIO m =>
ParserOpts -> SDocContext -> HsDoc GhcRn -> IfM m (Doc Name)
processDocString ParserOpts
parserOpts SDocContext
sDocContext HsDoc GhcRn
hsDoc'
          pure [ExportGroup lev "" doc]
        DsiDocChunk HsDoc GhcRn
hsDoc' -> do
          doc <- ParserOpts
-> SDocContext -> Maybe String -> HsDoc GhcRn -> IfM m (MDoc Name)
forall (m :: Type -> Type).
MonadIO m =>
ParserOpts
-> SDocContext -> Maybe String -> HsDoc GhcRn -> IfM m (MDoc Name)
processDocStringParas ParserOpts
parserOpts SDocContext
sDocContext Maybe String
pkgName HsDoc GhcRn
hsDoc'
          pure [ExportDoc doc]
        DsiNamedChunkRef String
ref -> do
          case String -> Map String (HsDoc GhcRn) -> Maybe (HsDoc GhcRn)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
ref Map String (HsDoc GhcRn)
namedChunks of
            Maybe (HsDoc GhcRn)
Nothing -> do
              String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn (String -> IfM m ()) -> String -> IfM m ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot find documentation for: $" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ref
              [ExportItem GhcRn] -> IfM m [ExportItem GhcRn]
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
            Just HsDoc GhcRn
hsDoc' -> do
              doc <- ParserOpts
-> SDocContext -> Maybe String -> HsDoc GhcRn -> IfM m (MDoc Name)
forall (m :: Type -> Type).
MonadIO m =>
ParserOpts
-> SDocContext -> Maybe String -> HsDoc GhcRn -> IfM m (MDoc Name)
processDocStringParas ParserOpts
parserOpts SDocContext
sDocContext Maybe String
pkgName HsDoc GhcRn
hsDoc'
              pure [ExportDoc doc]
        DsiExports [AvailInfo]
avails ->
          -- TODO: We probably don't need nubAvails here.
          -- mkDocStructureFromExportList already uses it.
          [[ExportItem GhcRn]] -> [ExportItem GhcRn]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[ExportItem GhcRn]] -> [ExportItem GhcRn])
-> IfM m [[ExportItem GhcRn]] -> IfM m [ExportItem GhcRn]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (AvailInfo -> IfM m [ExportItem GhcRn])
-> [AvailInfo] -> IfM m [[ExportItem GhcRn]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse AvailInfo -> IfM m [ExportItem GhcRn]
forall (m :: Type -> Type).
MonadIO m =>
AvailInfo -> IfM m [ExportItem GhcRn]
availExport ([AvailInfo] -> [AvailInfo]
nubAvails [AvailInfo]
avails)
        DsiModExport NonEmpty ModuleName
mod_names [AvailInfo]
avails -> do
          -- only consider exporting a module if we are sure we are really
          -- exporting the whole module and not some subset.
          (unrestricted_mods, remaining_avails) <- SDocContext
-> Module
-> IfaceMap
-> InstIfaceMap
-> [AvailInfo]
-> [ModuleName]
-> IfM m ([Module], [AvailInfo])
forall (m :: Type -> Type).
MonadIO m =>
SDocContext
-> Module
-> IfaceMap
-> InstIfaceMap
-> [AvailInfo]
-> [ModuleName]
-> IfM m ([Module], [AvailInfo])
unrestrictedModExports SDocContext
sDocContext Module
thisMod IfaceMap
modMap InstIfaceMap
instIfaceMap [AvailInfo]
avails (NonEmpty ModuleName -> [ModuleName]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ModuleName
mod_names)
          avail_exps <- concat <$> traverse availExport remaining_avails
          pure (map ExportModule unrestricted_mods ++ avail_exps)

      availExport :: MonadIO m => AvailInfo -> IfM m [ExportItem GhcRn]
      availExport :: forall (m :: Type -> Type).
MonadIO m =>
AvailInfo -> IfM m [ExportItem GhcRn]
availExport AvailInfo
avail =
        PrintRuntimeReps
-> IfaceMap
-> Module
-> WarningMap
-> Map Name MetaSince
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> FixMap
-> InstIfaceMap
-> DynFlags
-> SDocContext
-> AvailInfo
-> OccEnv Name
-> IfM m [ExportItem GhcRn]
forall (m :: Type -> Type).
MonadIO m =>
PrintRuntimeReps
-> IfaceMap
-> Module
-> WarningMap
-> Map Name MetaSince
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> FixMap
-> InstIfaceMap
-> DynFlags
-> SDocContext
-> AvailInfo
-> OccEnv Name
-> IfM m [ExportItem GhcRn]
availExportItem
          PrintRuntimeReps
prr
          IfaceMap
modMap
          Module
thisMod
          WarningMap
warnings
          Map Name MetaSince
exportSinceMap
          DocMap Name
docMap
          Map Name (Map Key (MDoc Name))
argMap
          FixMap
fixMap
          InstIfaceMap
instIfaceMap
          DynFlags
dflags
          SDocContext
sDocContext
          AvailInfo
avail
          OccEnv Name
defMeths

unrestrictedModExports
  :: MonadIO m
  => SDocContext
  -> Module
  -- ^ Current Module
  -> IfaceMap
  -- ^ Already created interfaces
  -> InstIfaceMap
  -- ^ Interfaces in other packages
  -> Avails
  -> [ModuleName]
  -- ^ Modules to be exported
  -> IfM m ([Module], Avails)
  -- ^ ( modules exported without restriction
  --   , remaining exports not included in any
  --     of these modules
  --   )
unrestrictedModExports :: forall (m :: Type -> Type).
MonadIO m =>
SDocContext
-> Module
-> IfaceMap
-> InstIfaceMap
-> [AvailInfo]
-> [ModuleName]
-> IfM m ([Module], [AvailInfo])
unrestrictedModExports SDocContext
sDocContext Module
thisMod IfaceMap
ifaceMap InstIfaceMap
instIfaceMap [AvailInfo]
avails [ModuleName]
mod_names = do
  mods_and_exports <- ([Maybe (Module, NameSet)] -> [(Module, NameSet)])
-> IfM m [Maybe (Module, NameSet)] -> IfM m [(Module, NameSet)]
forall a b. (a -> b) -> IfM m a -> IfM m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Module, NameSet)] -> [(Module, NameSet)]
forall a. [Maybe a] -> [a]
catMaybes (IfM m [Maybe (Module, NameSet)] -> IfM m [(Module, NameSet)])
-> IfM m [Maybe (Module, NameSet)] -> IfM m [(Module, NameSet)]
forall a b. (a -> b) -> a -> b
$ [ModuleName]
-> (ModuleName -> IfM m (Maybe (Module, NameSet)))
-> IfM m [Maybe (Module, NameSet)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ModuleName]
mod_names ((ModuleName -> IfM m (Maybe (Module, NameSet)))
 -> IfM m [Maybe (Module, NameSet)])
-> (ModuleName -> IfM m (Maybe (Module, NameSet)))
-> IfM m [Maybe (Module, NameSet)]
forall a b. (a -> b) -> a -> b
$ \ModuleName
mod_name -> do
    let m_local :: Module
m_local = GenUnit UnitId -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit Module
thisMod) ModuleName
mod_name
    case Module -> IfaceMap -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
m_local IfaceMap
ifaceMap of
      -- First lookup locally
      Just Interface
iface -> Maybe (Module, NameSet) -> IfM m (Maybe (Module, NameSet))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (Module, NameSet) -> IfM m (Maybe (Module, NameSet)))
-> Maybe (Module, NameSet) -> IfM m (Maybe (Module, NameSet))
forall a b. (a -> b) -> a -> b
$ (Module, NameSet) -> Maybe (Module, NameSet)
forall a. a -> Maybe a
Just (Interface -> Module
ifaceMod Interface
iface, [Name] -> NameSet
mkNameSet (Interface -> [Name]
ifaceExports Interface
iface))
      Maybe Interface
Nothing ->
        case ModuleName
-> Map ModuleName InstalledInterface -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mod_name Map ModuleName InstalledInterface
instIfaceMap' of
          Just InstalledInterface
iface -> Maybe (Module, NameSet) -> IfM m (Maybe (Module, NameSet))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (Module, NameSet) -> IfM m (Maybe (Module, NameSet)))
-> Maybe (Module, NameSet) -> IfM m (Maybe (Module, NameSet))
forall a b. (a -> b) -> a -> b
$ (Module, NameSet) -> Maybe (Module, NameSet)
forall a. a -> Maybe a
Just (InstalledInterface -> Module
instMod InstalledInterface
iface, [Name] -> NameSet
mkNameSet (InstalledInterface -> [Name]
instExports InstalledInterface
iface))
          Maybe InstalledInterface
Nothing -> do
            String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn (String -> IfM m ()) -> String -> IfM m ()
forall a b. (a -> b) -> a -> b
$
              String
"Warning: "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDocContext -> Module -> String
forall a. Outputable a => SDocContext -> a -> String
pretty SDocContext
sDocContext Module
thisMod
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": Could not find "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"documentation for exported module: "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDocContext -> ModuleName -> String
forall a. Outputable a => SDocContext -> a -> String
pretty SDocContext
sDocContext ModuleName
mod_name
            Maybe (Module, NameSet) -> IfM m (Maybe (Module, NameSet))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Module, NameSet)
forall a. Maybe a
Nothing
  let unrestricted = ((Module, NameSet) -> Bool)
-> [(Module, NameSet)] -> [(Module, NameSet)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Module, NameSet) -> Bool
everythingVisible [(Module, NameSet)]
mods_and_exports
      mod_exps = [NameSet] -> NameSet
unionNameSets (((Module, NameSet) -> NameSet) -> [(Module, NameSet)] -> [NameSet]
forall a b. (a -> b) -> [a] -> [b]
map (Module, NameSet) -> NameSet
forall a b. (a, b) -> b
snd [(Module, NameSet)]
unrestricted)
      remaining = [AvailInfo] -> [AvailInfo]
nubAvails ((Name -> Bool) -> [AvailInfo] -> [AvailInfo]
filterAvails (\Name
n -> Bool -> Bool
not (Name
n Name -> NameSet -> Bool
`elemNameSet` NameSet
mod_exps)) [AvailInfo]
avails)
  pure (map fst unrestricted, remaining)
  where
    instIfaceMap' :: Map ModuleName InstalledInterface
instIfaceMap' = (Module -> ModuleName)
-> InstIfaceMap -> Map ModuleName InstalledInterface
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName InstIfaceMap
instIfaceMap
    all_names :: NameSet
all_names = [AvailInfo] -> NameSet
availsToNameSet [AvailInfo]
avails

    -- Is everything in this (supposedly re-exported) module visible?
    everythingVisible :: (Module, NameSet) -> Bool
    everythingVisible :: (Module, NameSet) -> Bool
everythingVisible (Module
mdl, NameSet
exps)
      | Bool -> Bool
not (NameSet
exps NameSet -> NameSet -> Bool
`isSubsetOf` NameSet
all_names) = Bool
False
      | Just Interface
iface <- Module -> IfaceMap -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
mdl IfaceMap
ifaceMap = DocOption
OptHide DocOption -> [DocOption] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` Interface -> [DocOption]
ifaceOptions Interface
iface
      | Just InstalledInterface
iface <- ModuleName
-> Map ModuleName InstalledInterface -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mdl) Map ModuleName InstalledInterface
instIfaceMap' = DocOption
OptHide DocOption -> [DocOption] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` InstalledInterface -> [DocOption]
instOptions InstalledInterface
iface
      | Bool
otherwise = Bool
True

    -- TODO: Add a utility based on IntMap.isSubmapOfBy
    isSubsetOf :: NameSet -> NameSet -> Bool
    isSubsetOf :: NameSet -> NameSet -> Bool
isSubsetOf NameSet
a NameSet
b = (Name -> Bool) -> NameSet -> Bool
nameSetAll (Name -> NameSet -> Bool
`elemNameSet` NameSet
b) NameSet
a

availExportItem
  :: forall m
   . MonadIO m
  => PrintRuntimeReps
  -> IfaceMap
  -> Module -- this module
  -> WarningMap
  -> Map Name MetaSince
  -- ^ export \@since declarations
  -> Map Name (MDoc Name) -- docs (keyed by 'Name's)
  -> ArgMap Name -- docs for arguments (keyed by 'Name's)
  -> FixMap
  -> InstIfaceMap
  -> DynFlags
  -> SDocContext
  -> AvailInfo
  -> OccEnv Name -- Default methods
  -> IfM m [ExportItem GhcRn]
availExportItem :: forall (m :: Type -> Type).
MonadIO m =>
PrintRuntimeReps
-> IfaceMap
-> Module
-> WarningMap
-> Map Name MetaSince
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> FixMap
-> InstIfaceMap
-> DynFlags
-> SDocContext
-> AvailInfo
-> OccEnv Name
-> IfM m [ExportItem GhcRn]
availExportItem
  PrintRuntimeReps
prr
  IfaceMap
modMap
  Module
thisMod
  WarningMap
warnings
  Map Name MetaSince
exportSinceMap
  DocMap Name
docMap
  Map Name (Map Key (MDoc Name))
argMap
  FixMap
fixMap
  InstIfaceMap
instIfaceMap
  DynFlags
dflags
  SDocContext
sDocContext
  AvailInfo
availInfo
  OccEnv Name
defMeths =
    AvailInfo -> IfM m [ExportItem GhcRn]
declWith AvailInfo
availInfo
    where
      declWith :: AvailInfo -> IfM m [ExportItem GhcRn]
      declWith :: AvailInfo -> IfM m [ExportItem GhcRn]
declWith AvailInfo
avail = do
        let t :: Name
t = AvailInfo -> Name
availName AvailInfo
avail
        mayDecl <- SDocContext
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
forall (m :: Type -> Type).
MonadIO m =>
SDocContext
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl SDocContext
sDocContext PrintRuntimeReps
prr Name
t
        case mayDecl of
          Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
Nothing -> [ExportItem GhcRn] -> IfM m [ExportItem GhcRn]
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [IdP GhcRn -> [IdP GhcRn] -> ExportItem GhcRn
forall name. IdP name -> [IdP name] -> ExportItem name
ExportNoDecl IdP GhcRn
Name
t []]
          Just GenLocated SrcSpanAnnA (HsDecl GhcRn)
decl -> do
            AvailInfo
-> LHsDecl GhcRn
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m [ExportItem GhcRn]
availExportDecl AvailInfo
avail LHsDecl GhcRn
GenLocated SrcSpanAnnA (HsDecl GhcRn)
decl ((DocForDecl Name, [(Name, DocForDecl Name)])
 -> IfM m [ExportItem GhcRn])
-> IfM m (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m [ExportItem GhcRn]
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
              -- Find docs for decl
              let tmod :: Module
tmod = HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
t
              if Module
tmod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
thisMod
                then (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m (DocForDecl Name, [(Name, DocForDecl Name)])
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AvailInfo
-> WarningMap
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> OccEnv Name
-> (DocForDecl Name, [(Name, DocForDecl Name)])
lookupDocs AvailInfo
avail WarningMap
warnings DocMap Name
docMap Map Name (Map Key (MDoc Name))
argMap OccEnv Name
defMeths)
                else case Module -> IfaceMap -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
tmod IfaceMap
modMap of
                  Just Interface
iface ->
                    (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m (DocForDecl Name, [(Name, DocForDecl Name)])
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((DocForDecl Name, [(Name, DocForDecl Name)])
 -> IfM m (DocForDecl Name, [(Name, DocForDecl Name)]))
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m (DocForDecl Name, [(Name, DocForDecl Name)])
forall a b. (a -> b) -> a -> b
$
                      (DocForDecl Name -> DocForDecl Name)
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> (DocForDecl Name, [(Name, DocForDecl Name)])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Map Name MetaSince -> Name -> DocForDecl Name -> DocForDecl Name
applyExportSince Map Name MetaSince
exportSinceMap Name
t) ((DocForDecl Name, [(Name, DocForDecl Name)])
 -> (DocForDecl Name, [(Name, DocForDecl Name)]))
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> (DocForDecl Name, [(Name, DocForDecl Name)])
forall a b. (a -> b) -> a -> b
$
                        AvailInfo
-> WarningMap
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> OccEnv Name
-> (DocForDecl Name, [(Name, DocForDecl Name)])
lookupDocs AvailInfo
avail WarningMap
warnings (Interface -> DocMap Name
ifaceDocMap Interface
iface) (Interface -> Map Name (Map Key (MDoc Name))
ifaceArgMap Interface
iface) ([(OccName, Name)] -> OccEnv Name
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv (Interface -> [(OccName, Name)]
ifaceDefMeths Interface
iface))
                  Maybe Interface
Nothing ->
                    -- We try to get the subs and docs
                    -- from the installed .haddock file for that package.
                    -- TODO: This needs to be more sophisticated to deal
                    -- with signature inheritance
                    case Module -> InstIfaceMap -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
t) InstIfaceMap
instIfaceMap of
                      Maybe InstalledInterface
Nothing -> do
                        String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn (String -> IfM m ()) -> String -> IfM m ()
forall a b. (a -> b) -> a -> b
$
                          String
"Warning: "
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDocContext -> Module -> String
forall a. Outputable a => SDocContext -> a -> String
pretty SDocContext
sDocContext Module
thisMod
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": Couldn't find .haddock for export "
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDocContext -> Name -> String
forall a. Outputable a => SDocContext -> a -> String
pretty SDocContext
sDocContext Name
t
                        let subs_ :: [(Name, DocForDecl Name)]
subs_ = AvailInfo -> [(Name, DocForDecl Name)]
availNoDocs AvailInfo
avail
                        (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m (DocForDecl Name, [(Name, DocForDecl Name)])
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DocForDecl Name
forall name. DocForDecl name
noDocForDecl, [(Name, DocForDecl Name)]
subs_)
                      Just InstalledInterface
instIface ->
                        (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m (DocForDecl Name, [(Name, DocForDecl Name)])
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((DocForDecl Name, [(Name, DocForDecl Name)])
 -> IfM m (DocForDecl Name, [(Name, DocForDecl Name)]))
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m (DocForDecl Name, [(Name, DocForDecl Name)])
forall a b. (a -> b) -> a -> b
$
                          (DocForDecl Name -> DocForDecl Name)
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> (DocForDecl Name, [(Name, DocForDecl Name)])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Map Name MetaSince -> Name -> DocForDecl Name -> DocForDecl Name
applyExportSince Map Name MetaSince
exportSinceMap Name
t) ((DocForDecl Name, [(Name, DocForDecl Name)])
 -> (DocForDecl Name, [(Name, DocForDecl Name)]))
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> (DocForDecl Name, [(Name, DocForDecl Name)])
forall a b. (a -> b) -> a -> b
$
                            AvailInfo
-> WarningMap
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> OccEnv Name
-> (DocForDecl Name, [(Name, DocForDecl Name)])
lookupDocs AvailInfo
avail WarningMap
warnings (InstalledInterface -> DocMap Name
instDocMap InstalledInterface
instIface) (InstalledInterface -> Map Name (Map Key (MDoc Name))
instArgMap InstalledInterface
instIface) ([(OccName, Name)] -> OccEnv Name
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv (InstalledInterface -> [(OccName, Name)]
instDefMeths InstalledInterface
instIface))

      -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
      availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
      availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
availDecl Name
declName LHsDecl GhcRn
parentDecl =
        PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: Type -> Type).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags SDocContext
sDocContext Name
declName LHsDecl GhcRn
parentDecl IfM m (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
-> (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
    -> IfM m (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
-> IfM m (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. IfM m a -> (a -> IfM m b) -> IfM m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Right GenLocated SrcSpanAnnA (HsDecl GhcRn)
d -> GenLocated SrcSpanAnnA (HsDecl GhcRn)
-> IfM m (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsDecl GhcRn)
d
          Left String
err -> do
            synifiedDeclOpt <- SDocContext
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
forall (m :: Type -> Type).
MonadIO m =>
SDocContext
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl SDocContext
sDocContext PrintRuntimeReps
prr Name
declName
            case synifiedDeclOpt of
              Just GenLocated SrcSpanAnnA (HsDecl GhcRn)
synifiedDecl -> GenLocated SrcSpanAnnA (HsDecl GhcRn)
-> IfM m (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsDecl GhcRn)
synifiedDecl
              Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
Nothing -> String -> SDoc -> IfM m (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"availExportItem" (String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
err)

      availExportDecl
        :: AvailInfo
        -> LHsDecl GhcRn
        -> (DocForDecl Name, [(Name, DocForDecl Name)])
        -> IfM m [ExportItem GhcRn]
      availExportDecl :: AvailInfo
-> LHsDecl GhcRn
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m [ExportItem GhcRn]
availExportDecl AvailInfo
avail LHsDecl GhcRn
decl (DocForDecl Name
doc, [(Name, DocForDecl Name)]
subs)
        | AvailInfo -> Bool
availExportsDecl AvailInfo
avail = do
            extractedDecl <- Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
availDecl (AvailInfo -> Name
availName AvailInfo
avail) LHsDecl GhcRn
decl

            -- bundled pattern synonyms only make sense if the declaration is
            -- exported (otherwise there would be nothing to bundle to)
            bundledPatSyns <- findBundledPatterns avail

            let
              !patSynNames =
                [Name] -> [Name]
forall a. NFData a => a -> a
force ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$
                  ((HsDecl GhcRn, DocForDecl Name) -> [Name])
-> [(HsDecl GhcRn, DocForDecl Name)] -> [Name]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (OccEnv Name -> HsDecl GhcRn -> [Name]
getMainDeclBinder OccEnv Name
forall a. OccEnv a
emptyOccEnv (HsDecl GhcRn -> [Name])
-> ((HsDecl GhcRn, DocForDecl Name) -> HsDecl GhcRn)
-> (HsDecl GhcRn, DocForDecl Name)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsDecl GhcRn, DocForDecl Name) -> HsDecl GhcRn
forall a b. (a, b) -> a
fst) [(HsDecl GhcRn, DocForDecl Name)]
bundledPatSyns

              !doc' = DocForDecl Name -> DocForDecl Name
forall a. NFData a => a -> a
force DocForDecl Name
doc
              !subs' = [(Name, DocForDecl Name)] -> [(Name, DocForDecl Name)]
forall a. NFData a => a -> a
force [(Name, DocForDecl Name)]
subs

              !restrictToNames = [Name] -> [Name]
forall a. NFData a => a -> a
force ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ((Name, DocForDecl Name) -> Name)
-> [(Name, DocForDecl Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, DocForDecl Name) -> Name
forall a b. (a, b) -> a
fst [(Name, DocForDecl Name)]
subs'

              !fixities =
                [(Name, Fixity)] -> [(Name, Fixity)]
forall a. NFData a => a -> a
force
                  [ (Name
n, Fixity
f)
                  | Name
n <- AvailInfo -> Name
availName AvailInfo
avail Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: ((Name, DocForDecl Name) -> Name)
-> [(Name, DocForDecl Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, DocForDecl Name) -> Name
forall a b. (a, b) -> a
fst [(Name, DocForDecl Name)]
subs' [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
patSynNames
                  , Just Fixity
f <- [Name -> FixMap -> Maybe Fixity
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n FixMap
fixMap]
                  ]

            return
              [ ExportDecl
                  ExportD
                    { expDDecl = restrictTo restrictToNames extractedDecl
                    , expDPats = bundledPatSyns
                    , expDMbDoc = doc'
                    , expDSubDocs = subs'
                    , expDInstances = []
                    , expDFixities = fixities
                    , expDSpliced = False
                    }
              ]
        | Bool
otherwise = [(Name, DocForDecl Name)]
-> ((Name, DocForDecl Name) -> IfM m (ExportItem GhcRn))
-> IfM m [ExportItem GhcRn]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Name, DocForDecl Name)]
subs (((Name, DocForDecl Name) -> IfM m (ExportItem GhcRn))
 -> IfM m [ExportItem GhcRn])
-> ((Name, DocForDecl Name) -> IfM m (ExportItem GhcRn))
-> IfM m [ExportItem GhcRn]
forall a b. (a -> b) -> a -> b
$ \(Name
sub, DocForDecl Name
sub_doc) -> do
            extractedDecl <- Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
availDecl Name
sub LHsDecl GhcRn
decl

            let
              !fixities = [(Name, Fixity)] -> [(Name, Fixity)]
forall a. NFData a => a -> a
force [(Name
sub, Fixity
f) | Just Fixity
f <- [Name -> FixMap -> Maybe Fixity
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
sub FixMap
fixMap]]
              !subDoc = DocForDecl Name -> DocForDecl Name
forall a. NFData a => a -> a
force DocForDecl Name
sub_doc

            return $
              ExportDecl
                ExportD
                  { expDDecl = extractedDecl
                  , expDPats = []
                  , expDMbDoc = subDoc
                  , expDSubDocs = []
                  , expDInstances = []
                  , expDFixities = fixities
                  , expDSpliced = False
                  }

      findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)]
      findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)]
findBundledPatterns AvailInfo
avail = do
        patsyns <- [Name]
-> (Name -> IfM m [(HsDecl GhcRn, DocForDecl Name)])
-> IfM m [[(HsDecl GhcRn, DocForDecl Name)]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Name]
constructor_names ((Name -> IfM m [(HsDecl GhcRn, DocForDecl Name)])
 -> IfM m [[(HsDecl GhcRn, DocForDecl Name)]])
-> (Name -> IfM m [(HsDecl GhcRn, DocForDecl Name)])
-> IfM m [[(HsDecl GhcRn, DocForDecl Name)]]
forall a b. (a -> b) -> a -> b
$ \Name
name -> do
          mtyThing <- Name -> IfM m (Maybe TyThing)
forall (m :: Type -> Type).
Monad m =>
Name -> IfM m (Maybe TyThing)
lookupName Name
name
          case mtyThing of
            Just (AConLike PatSynCon{}) -> do
              export_items <- AvailInfo -> IfM m [ExportItem GhcRn]
declWith (Name -> AvailInfo
Avail Name
name)
              pure
                [ (unLoc patsyn_decl, patsyn_doc)
                | ExportDecl
                    ExportD
                      { expDDecl = patsyn_decl
                      , expDMbDoc = patsyn_doc
                      } <-
                    export_items
                ]
            Maybe TyThing
_ -> [(HsDecl GhcRn, DocForDecl Name)]
-> IfM m [(HsDecl GhcRn, DocForDecl Name)]
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
        pure (concat patsyns)
        where
          constructor_names :: [Name]
constructor_names =
            (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
isDataConName (AvailInfo -> [Name]
availSubordinates AvailInfo
avail)

availSubordinates :: AvailInfo -> [Name]
availSubordinates :: AvailInfo -> [Name]
availSubordinates = AvailInfo -> [Name]
availSubordinateNames

availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)]
availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)]
availNoDocs AvailInfo
avail =
  [Name] -> [DocForDecl Name] -> [(Name, DocForDecl Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (AvailInfo -> [Name]
availSubordinates AvailInfo
avail) (DocForDecl Name -> [DocForDecl Name]
forall a. a -> [a]
repeat DocForDecl Name
forall name. DocForDecl name
noDocForDecl)

-- | Override 'MetaSince' of a declaration with that of its export if appropriate.
applyExportSince
  :: Map Name MetaSince
  -> Name
  -> DocForDecl Name
  -> DocForDecl Name
applyExportSince :: Map Name MetaSince -> Name -> DocForDecl Name -> DocForDecl Name
applyExportSince Map Name MetaSince
exportSinceMap Name
nm (Documentation Name
dd, Map Key (MDoc Name)
argDoc)
  | Just MetaSince
since <- Name -> Map Name MetaSince -> Maybe MetaSince
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
nm Map Name MetaSince
exportSinceMap =
      let dd' :: Documentation Name
dd' = Documentation Name
dd{documentationDoc = setMDocSince (documentationDoc dd)}
          setMDocSince :: Maybe (MDoc name) -> Maybe (MDoc name)
          setMDocSince :: forall name. Maybe (MDoc name) -> Maybe (MDoc name)
setMDocSince (Just (MetaDoc Meta
meta DocH (Wrap (ModuleName, OccName)) (Wrap name)
doc)) = MDoc name -> Maybe (MDoc name)
forall a. a -> Maybe a
Just (MDoc name -> Maybe (MDoc name)) -> MDoc name -> Maybe (MDoc name)
forall a b. (a -> b) -> a -> b
$ Meta -> DocH (Wrap (ModuleName, OccName)) (Wrap name) -> MDoc name
forall mod id. Meta -> DocH mod id -> MetaDoc mod id
MetaDoc (Meta
meta{_metaSince = Just since}) DocH (Wrap (ModuleName, OccName)) (Wrap name)
doc
          setMDocSince Maybe (MDoc name)
Nothing = MDoc name -> Maybe (MDoc name)
forall a. a -> Maybe a
Just (MDoc name -> Maybe (MDoc name)) -> MDoc name -> Maybe (MDoc name)
forall a b. (a -> b) -> a -> b
$ Meta -> DocH (Wrap (ModuleName, OccName)) (Wrap name) -> MDoc name
forall mod id. Meta -> DocH mod id -> MetaDoc mod id
MetaDoc (Meta{_metaSince :: Maybe MetaSince
_metaSince = MetaSince -> Maybe MetaSince
forall a. a -> Maybe a
Just MetaSince
since}) DocH (Wrap (ModuleName, OccName)) (Wrap name)
forall mod id. DocH mod id
DocEmpty
       in (Documentation Name
dd', Map Key (MDoc Name)
argDoc)
applyExportSince Map Name MetaSince
_ Name
_ DocForDecl Name
dd = DocForDecl Name
dd

hiDecl
  :: MonadIO m
  => SDocContext
  -> PrintRuntimeReps
  -> Name
  -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl :: forall (m :: Type -> Type).
MonadIO m =>
SDocContext
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl SDocContext
sDocContext PrintRuntimeReps
prr Name
t = do
  mayTyThing <- Name -> IfM m (Maybe TyThing)
forall (m :: Type -> Type).
Monad m =>
Name -> IfM m (Maybe TyThing)
lookupName Name
t
  case mayTyThing of
    Maybe TyThing
Nothing -> do
      String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn (String -> IfM m ()) -> String -> IfM m ()
forall a b. (a -> b) -> a -> b
$ String
"Warning: Not found in environment: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDocContext -> Name -> String
forall a. Outputable a => SDocContext -> a -> String
pretty SDocContext
sDocContext Name
t
      Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a. Maybe a
Nothing
    Just TyThing
x -> case PrintRuntimeReps
-> TyThing -> Either String ([String], HsDecl GhcRn)
tyThingToLHsDecl PrintRuntimeReps
prr TyThing
x of
      Left String
m -> (String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn (String -> IfM m ()) -> String -> IfM m ()
forall a b. (a -> b) -> a -> b
$ String -> String
bugWarn String
m) IfM m ()
-> IfM m (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
-> IfM m (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a b. IfM m a -> IfM m b -> IfM m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a. Maybe a
Nothing
      Right ([String]
m, HsDecl GhcRn
t') -> (String -> IfM m ()) -> [String] -> IfM m [()]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (String -> IfM m ()
forall (m :: Type -> Type). MonadIO m => String -> IfM m ()
warn (String -> IfM m ()) -> (String -> String) -> String -> IfM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
bugWarn) [String]
m IfM m [()]
-> IfM m (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
-> IfM m (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a b. IfM m a -> IfM m b -> IfM m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a. a -> IfM m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsDecl GhcRn)
-> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnA (HsDecl GhcRn)
 -> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
-> GenLocated SrcSpanAnnA (HsDecl GhcRn)
-> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsDecl GhcRn -> GenLocated SrcSpanAnnA (HsDecl GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan (Name -> SrcSpan
nameSrcSpan Name
t)) HsDecl GhcRn
t')
  where
    warnLine :: String -> SDoc
warnLine String
x =
      String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"haddock-bug:"
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<+> String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
x
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<> SDoc
forall doc. IsLine doc => doc
O.comma
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<+> SDoc -> SDoc
O.quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
O.ppr Name
t)
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<+> String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"-- Please report this on Haddock issue tracker!"
    bugWarn :: String -> String
bugWarn = SDocContext -> SDoc -> String
Outputable.renderWithContext SDocContext
sDocContext (SDoc -> String) -> (String -> SDoc) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
warnLine

-- | Lookup docs for a declaration from maps.
lookupDocs
  :: AvailInfo
  -> WarningMap
  -> Map Name (MDoc Name)
  -> ArgMap Name
  -> OccEnv Name
  -> (DocForDecl Name, [(Name, DocForDecl Name)])
  -- ^ documentation for declaration and its subordinates
lookupDocs :: AvailInfo
-> WarningMap
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> OccEnv Name
-> (DocForDecl Name, [(Name, DocForDecl Name)])
lookupDocs AvailInfo
avail WarningMap
warningMap DocMap Name
docMap Map Name (Map Key (MDoc Name))
argMap OccEnv Name
def_meths_env =
  let
    n :: Name
n = AvailInfo -> Name
availName AvailInfo
avail
    lookupArgDoc :: Name -> Map Key (MDoc Name)
lookupArgDoc Name
x = Map Key (MDoc Name)
-> Name -> Map Name (Map Key (MDoc Name)) -> Map Key (MDoc Name)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Key (MDoc Name)
forall k a. Map k a
Map.empty Name
x Map Name (Map Key (MDoc Name))
argMap
    doc :: DocForDecl Name
doc = (Name -> Documentation Name
lookupDoc Name
n, Name -> Map Key (MDoc Name)
lookupArgDoc Name
n)
    subs :: [Name]
subs = AvailInfo -> [Name]
availSubordinates AvailInfo
avail
    def_meths :: [(Name, DocForDecl Name)]
def_meths =
      [ (Name
meth, (Name -> Documentation Name
lookupDoc Name
meth, Name -> Map Key (MDoc Name)
lookupArgDoc Name
meth))
      | Name
s <- [Name]
subs
      , let dmOcc :: OccName
dmOcc = OccName -> OccName
mkDefaultMethodOcc (Name -> OccName
nameOccName Name
s)
      , Just Name
meth <- [OccEnv Name -> OccName -> Maybe Name
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv Name
def_meths_env OccName
dmOcc]
      , AvailInfo -> Bool
availExportsDecl AvailInfo
avail
      ]
    subDocs :: [(Name, DocForDecl Name)]
subDocs =
      [ (Name
s, (Name -> Documentation Name
lookupDoc Name
s, Name -> Map Key (MDoc Name)
lookupArgDoc Name
s))
      | Name
s <- [Name]
subs
      ]
        [(Name, DocForDecl Name)]
-> [(Name, DocForDecl Name)] -> [(Name, DocForDecl Name)]
forall a. [a] -> [a] -> [a]
++ [(Name, DocForDecl Name)]
def_meths
   in
    (DocForDecl Name
doc, [(Name, DocForDecl Name)]
subDocs)
  where
    lookupDoc :: Name -> Documentation Name
lookupDoc Name
name = Maybe (MDoc Name) -> Maybe (Doc Name) -> Documentation Name
forall name.
Maybe (MDoc name) -> Maybe (Doc name) -> Documentation name
Documentation (Name -> DocMap Name -> Maybe (MDoc Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name DocMap Name
docMap) (Name -> WarningMap -> Maybe (Doc Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name WarningMap
warningMap)

-- Note [1]:
------------
-- It is unnecessary to document a subordinate by itself at the top level if
-- any of its parents is also documented. Furthermore, if the subordinate is a
-- record field or a class method, documenting it under its parent
-- indicates its special status.
--
-- A user might expect that it should show up separately, so we issue a
-- warning. It's a fine opportunity to also tell the user she might want to
-- export the subordinate through the parent export item for clarity.
--
-- The code removes top-level subordinates also when the parent is exported
-- through a 'module' export. I think that is fine.
--
-- (For more information, see Trac #69)

-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method.  In these
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
--
-- This function looks through the declarations in this module to try to find
-- the one with the right name.
extractDecl
  :: MonadIO m
  => PrintRuntimeReps
  -> DynFlags
  -> SDocContext
  -> Name
  -- ^ name of the declaration to extract
  -> LHsDecl GhcRn
  -- ^ parent declaration
  -> IfM m (Either String (LHsDecl GhcRn))
extractDecl :: forall (m :: Type -> Type).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags SDocContext
sDocContext Name
name LHsDecl GhcRn
decl
  | Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` OccEnv Name -> HsDecl GhcRn -> [Name]
getMainDeclBinder OccEnv Name
forall a. OccEnv a
emptyOccEnv (GenLocated SrcSpanAnnA (HsDecl GhcRn) -> HsDecl GhcRn
forall l e. GenLocated l e -> e
unLoc LHsDecl GhcRn
GenLocated SrcSpanAnnA (HsDecl GhcRn)
decl) = Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String (LHsDecl GhcRn)
 -> IfM m (Either String (LHsDecl GhcRn)))
-> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$ LHsDecl GhcRn -> Either String (LHsDecl GhcRn)
forall a b. b -> Either a b
Right LHsDecl GhcRn
decl
  | Bool
otherwise =
      case GenLocated SrcSpanAnnA (HsDecl GhcRn) -> HsDecl GhcRn
forall l e. GenLocated l e -> e
unLoc LHsDecl GhcRn
GenLocated SrcSpanAnnA (HsDecl GhcRn)
decl of
        TyClD
          XTyClD GhcRn
_
          d :: TyClDecl GhcRn
d@ClassDecl
            { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
clsNm
            , tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
clsSigs
            , tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
clsATs
            } ->
            let
              matchesMethod :: [GenLocated SrcSpanAnnA (Sig GhcRn)]
matchesMethod =
                [ GenLocated SrcSpanAnnA (Sig GhcRn)
lsig
                | GenLocated SrcSpanAnnA (Sig GhcRn)
lsig <- [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
clsSigs
                , ClassOpSig XClassOpSig GhcRn
_ Bool
False [LIdP GhcRn]
_ LHsSigType GhcRn
_ <- Sig GhcRn -> [Sig GhcRn]
forall a. a -> [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Sig GhcRn -> [Sig GhcRn]) -> Sig GhcRn -> [Sig GhcRn]
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (Sig GhcRn) -> Sig GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Sig GhcRn)
lsig
                , -- Note: exclude `default` declarations (see #505)
                Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` LSig GhcRn -> [IdP GhcRn]
sigName LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
lsig
                ]

              matchesAssociatedType :: [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
matchesAssociatedType =
                [ GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
lfam_decl
                | GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
lfam_decl <- [LFamilyDecl GhcRn]
[GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
clsATs
                , Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (FamilyDecl GhcRn -> LIdP GhcRn
forall pass. FamilyDecl pass -> LIdP pass
fdLName (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
lfam_decl))
                ]
             in
              -- TODO: document fixity
              case ([GenLocated SrcSpanAnnA (Sig GhcRn)]
matchesMethod, [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
matchesAssociatedType) of
                ([GenLocated SrcSpanAnnA (Sig GhcRn)
s0], [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
_) ->
                  let tyvar_names :: LHsQTyVars GhcRn
tyvar_names = TyClDecl GhcRn -> LHsQTyVars GhcRn
forall pass. TyClDecl pass -> LHsQTyVars pass
tyClDeclTyVars TyClDecl GhcRn
d
                      L SrcSpanAnnA
pos Sig GhcRn
sig = Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
addClassContext Name
clsNm LHsQTyVars GhcRn
tyvar_names LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
s0
                   in Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsDecl GhcRn)
-> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (HsDecl GhcRn)
 -> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
-> GenLocated SrcSpanAnnA (HsDecl GhcRn)
-> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsDecl GhcRn -> GenLocated SrcSpanAnnA (HsDecl GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos (XSigD GhcRn -> Sig GhcRn -> HsDecl GhcRn
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcRn
NoExtField
noExtField Sig GhcRn
sig))
                ([GenLocated SrcSpanAnnA (Sig GhcRn)]
_, [L SrcSpanAnnA
pos FamilyDecl GhcRn
fam_decl]) -> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsDecl GhcRn)
-> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (HsDecl GhcRn)
 -> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
-> GenLocated SrcSpanAnnA (HsDecl GhcRn)
-> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsDecl GhcRn -> GenLocated SrcSpanAnnA (HsDecl GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
pos (XTyClD GhcRn -> TyClDecl GhcRn -> HsDecl GhcRn
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcRn
NoExtField
noExtField (XFamDecl GhcRn -> FamilyDecl GhcRn -> TyClDecl GhcRn
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcRn
NoExtField
noExtField FamilyDecl GhcRn
fam_decl)))
                ([], []) -> do
                  famInstDeclOpt <- SDocContext
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
forall (m :: Type -> Type).
MonadIO m =>
SDocContext
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl SDocContext
sDocContext PrintRuntimeReps
prr Name
name
                  case famInstDeclOpt of
                    Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
Nothing ->
                      Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
 -> IfM m (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))))
-> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a b. (a -> b) -> a -> b
$
                        String -> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. a -> Either a b
Left
                          ( [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
                              [ String
"Ambiguous decl for "
                              , Name -> String
forall a. NamedThing a => a -> String
getOccString Name
name
                              , String
" in class "
                              , Name -> String
forall a. NamedThing a => a -> String
getOccString Name
clsNm
                              ]
                          )
                    Just GenLocated SrcSpanAnnA (HsDecl GhcRn)
famInstDecl -> PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: Type -> Type).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags SDocContext
sDocContext Name
name LHsDecl GhcRn
GenLocated SrcSpanAnnA (HsDecl GhcRn)
famInstDecl
                ([GenLocated SrcSpanAnnA (Sig GhcRn)],
 [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)])
_ ->
                  Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String (LHsDecl GhcRn)
 -> IfM m (Either String (LHsDecl GhcRn)))
-> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$
                    String -> Either String (LHsDecl GhcRn)
forall a b. a -> Either a b
Left
                      ( [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
                          [ String
"Ambiguous decl for "
                          , Name -> String
forall a. NamedThing a => a -> String
getOccString Name
name
                          , String
" in class "
                          , Name -> String
forall a. NamedThing a => a -> String
getOccString Name
clsNm
                          ]
                      )
        TyClD
          XTyClD GhcRn
_
          d :: TyClDecl GhcRn
d@DataDecl
            { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
dataNm
            , tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn{dd_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl GhcRn)
dataCons}
            } -> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String (LHsDecl GhcRn)
 -> IfM m (Either String (LHsDecl GhcRn)))
-> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$ do
            let ty_args :: [LHsTypeArg GhcRn]
ty_args = LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
lHsQTyVarsToTypes (TyClDecl GhcRn -> LHsQTyVars GhcRn
forall pass. TyClDecl pass -> LHsQTyVars pass
tyClDeclTyVars TyClDecl GhcRn
d)
            lsig <-
              if Name -> Bool
isDataConName Name
name
                then Name
-> Name
-> [LHsTypeArg GhcRn]
-> [LConDecl GhcRn]
-> Either String (LSig GhcRn)
extractPatternSyn Name
name Name
dataNm [LHsTypeArg GhcRn]
ty_args (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
forall a. DataDefnCons a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
dataCons)
                else Name
-> Name
-> [LHsTypeArg GhcRn]
-> [LConDecl GhcRn]
-> Either String (LSig GhcRn)
extractRecSel Name
name Name
dataNm [LHsTypeArg GhcRn]
ty_args (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
forall a. DataDefnCons a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
dataCons)
            pure (SigD noExtField <$> lsig)
        TyClD XTyClD GhcRn
_ FamDecl{}
          | Name -> Bool
isValName Name
name -> do
              famInstOpt <- SDocContext
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
forall (m :: Type -> Type).
MonadIO m =>
SDocContext
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl SDocContext
sDocContext PrintRuntimeReps
prr Name
name
              case famInstOpt of
                Just GenLocated SrcSpanAnnA (HsDecl GhcRn)
famInst -> PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: Type -> Type).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags SDocContext
sDocContext Name
name LHsDecl GhcRn
GenLocated SrcSpanAnnA (HsDecl GhcRn)
famInst
                Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
Nothing -> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
 -> IfM m (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))))
-> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a b. (a -> b) -> a -> b
$ String -> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. a -> Either a b
Left (String
"extractDecl: Unhandled decl for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. NamedThing a => a -> String
getOccString Name
name)
        InstD
          XInstD GhcRn
_
          ( DataFamInstD
              XDataFamInstD GhcRn
_
              ( DataFamInstDecl
                  ( FamEqn
                      { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
_ Name
n
                      , feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsFamEqnPats pass
feqn_pats = [LHsTypeArg GhcRn]
tys
                      , feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = HsDataDefn GhcRn
defn
                      }
                    )
                )
            ) ->
            Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String (LHsDecl GhcRn)
 -> IfM m (Either String (LHsDecl GhcRn)))
-> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$
              if Name -> Bool
isDataConName Name
name
                then (Sig GhcRn -> HsDecl GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> GenLocated SrcSpanAnnA (HsDecl GhcRn)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (XSigD GhcRn -> Sig GhcRn -> HsDecl GhcRn
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcRn
NoExtField
noExtField) (GenLocated SrcSpanAnnA (Sig GhcRn)
 -> GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> Either String (GenLocated SrcSpanAnnA (Sig GhcRn))
-> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Name
-> Name
-> [LHsTypeArg GhcRn]
-> [LConDecl GhcRn]
-> Either String (LSig GhcRn)
extractPatternSyn Name
name Name
n [LHsTypeArg GhcRn]
tys (DataDefnCons (LConDecl GhcRn) -> [LConDecl GhcRn]
forall a. DataDefnCons a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (DataDefnCons (LConDecl GhcRn) -> [LConDecl GhcRn])
-> DataDefnCons (LConDecl GhcRn) -> [LConDecl GhcRn]
forall a b. (a -> b) -> a -> b
$ HsDataDefn GhcRn -> DataDefnCons (LConDecl GhcRn)
forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons HsDataDefn GhcRn
defn)
                else (Sig GhcRn -> HsDecl GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> GenLocated SrcSpanAnnA (HsDecl GhcRn)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (XSigD GhcRn -> Sig GhcRn -> HsDecl GhcRn
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcRn
NoExtField
noExtField) (GenLocated SrcSpanAnnA (Sig GhcRn)
 -> GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> Either String (GenLocated SrcSpanAnnA (Sig GhcRn))
-> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Name
-> Name
-> [LHsTypeArg GhcRn]
-> [LConDecl GhcRn]
-> Either String (LSig GhcRn)
extractRecSel Name
name Name
n [LHsTypeArg GhcRn]
tys (DataDefnCons (LConDecl GhcRn) -> [LConDecl GhcRn]
forall a. DataDefnCons a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (DataDefnCons (LConDecl GhcRn) -> [LConDecl GhcRn])
-> DataDefnCons (LConDecl GhcRn) -> [LConDecl GhcRn]
forall a b. (a -> b) -> a -> b
$ HsDataDefn GhcRn -> DataDefnCons (LConDecl GhcRn)
forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons HsDataDefn GhcRn
defn)
        InstD XInstD GhcRn
_ (ClsInstD XClsInstD GhcRn
_ ClsInstDecl{cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl GhcRn]
insts})
          | Name -> Bool
isDataConName Name
name ->
              let matches :: [DataFamInstDecl GhcRn]
matches =
                    [ DataFamInstDecl GhcRn
d' | L SrcSpanAnnA
_ d' :: DataFamInstDecl GhcRn
d'@(DataFamInstDecl (FamEqn{feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = HsDataDefn GhcRn
dd})) <- [LDataFamInstDecl GhcRn]
[GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)]
insts, Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` (GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc ((GenLocated SrcSpanAnnA (ConDecl GhcRn)
 -> [GenLocated SrcSpanAnnN Name])
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> [GenLocated SrcSpanAnnN Name]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ([GenLocated SrcSpanAnnN Name] -> [GenLocated SrcSpanAnnN Name]
forall a. [a] -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList ([GenLocated SrcSpanAnnN Name] -> [GenLocated SrcSpanAnnN Name])
-> (GenLocated SrcSpanAnnA (ConDecl GhcRn)
    -> [GenLocated SrcSpanAnnN Name])
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> [GenLocated SrcSpanAnnN Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name]
getConNames (ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name])
-> (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn)
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> [GenLocated SrcSpanAnnN Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) (HsDataDefn GhcRn -> DataDefnCons (LConDecl GhcRn)
forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons HsDataDefn GhcRn
dd))
                    ]
               in case [DataFamInstDecl GhcRn]
matches of
                    [DataFamInstDecl GhcRn
d0] -> PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: Type -> Type).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags SDocContext
sDocContext Name
name (HsDecl GhcRn -> GenLocated SrcSpanAnnA (HsDecl GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XInstD GhcRn -> InstDecl GhcRn -> HsDecl GhcRn
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcRn
NoExtField
noExtField (XDataFamInstD GhcRn -> DataFamInstDecl GhcRn -> InstDecl GhcRn
forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD XDataFamInstD GhcRn
NoExtField
noExtField DataFamInstDecl GhcRn
d0)))
                    [DataFamInstDecl GhcRn]
_ -> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String (LHsDecl GhcRn)
 -> IfM m (Either String (LHsDecl GhcRn)))
-> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$ String -> Either String (LHsDecl GhcRn)
forall a b. a -> Either a b
Left String
"internal: extractDecl (ClsInstD)"
          | Bool
otherwise ->
              let matches :: [DataFamInstDecl GhcRn]
matches =
                    [ DataFamInstDecl GhcRn
d'
                    | L SrcSpanAnnA
_ d' :: DataFamInstDecl GhcRn
d'@(DataFamInstDecl FamEqn GhcRn (HsDataDefn GhcRn)
d) <-
                        [LDataFamInstDecl GhcRn]
[GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)]
insts
                    , -- , L _ ConDecl { con_details = RecCon rec } <- toList $ dd_cons (feqn_rhs d)
                    Just GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
rec <- DataDefnCons
  (Maybe
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]))
-> [Maybe
      (GenLocated
         SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])]
forall a. DataDefnCons a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (DataDefnCons
   (Maybe
      (GenLocated
         SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]))
 -> [Maybe
       (GenLocated
          SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])])
-> DataDefnCons
     (Maybe
        (GenLocated
           SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]))
-> [Maybe
      (GenLocated
         SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])]
forall a b. (a -> b) -> a -> b
$ ConDecl GhcRn -> Maybe (LocatedL [LConDeclField GhcRn])
ConDecl GhcRn
-> Maybe
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
getRecConArgs_maybe (ConDecl GhcRn
 -> Maybe
      (GenLocated
         SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]))
-> (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn)
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> Maybe
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (ConDecl GhcRn)
 -> Maybe
      (GenLocated
         SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]))
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> DataDefnCons
     (Maybe
        (GenLocated
           SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> HsDataDefn GhcRn -> DataDefnCons (LConDecl GhcRn)
forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons (FamEqn GhcRn (HsDataDefn GhcRn) -> HsDataDefn GhcRn
forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs FamEqn GhcRn (HsDataDefn GhcRn)
d)
                    , ConDeclField{cd_fld_names :: forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names = [LFieldOcc GhcRn]
ns} <- (GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn)
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [ConDeclField GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall l e. GenLocated l e -> e
unLoc GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
rec)
                    , L SrcSpanAnnA
_ FieldOcc GhcRn
n <- [LFieldOcc GhcRn]
[GenLocated SrcSpanAnnA (FieldOcc GhcRn)]
ns
                    , FieldOcc GhcRn -> XCFieldOcc GhcRn
forall pass. FieldOcc pass -> XCFieldOcc pass
foExt FieldOcc GhcRn
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name
                    ]
               in case [DataFamInstDecl GhcRn]
matches of
                    [DataFamInstDecl GhcRn
d0] -> PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: Type -> Type).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> SDocContext
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags SDocContext
sDocContext Name
name (HsDecl GhcRn -> LHsDecl GhcRn
HsDecl GhcRn -> GenLocated SrcSpanAnnA (HsDecl GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsDecl GhcRn -> LHsDecl GhcRn)
-> (InstDecl GhcRn -> HsDecl GhcRn)
-> InstDecl GhcRn
-> LHsDecl GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XInstD GhcRn -> InstDecl GhcRn -> HsDecl GhcRn
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcRn
NoExtField
noExtField (InstDecl GhcRn -> LHsDecl GhcRn)
-> InstDecl GhcRn -> LHsDecl GhcRn
forall a b. (a -> b) -> a -> b
$ XDataFamInstD GhcRn -> DataFamInstDecl GhcRn -> InstDecl GhcRn
forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD XDataFamInstD GhcRn
NoExtField
noExtField DataFamInstDecl GhcRn
d0)
                    [DataFamInstDecl GhcRn]
_ -> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String (LHsDecl GhcRn)
 -> IfM m (Either String (LHsDecl GhcRn)))
-> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$ String -> Either String (LHsDecl GhcRn)
forall a b. a -> Either a b
Left String
"internal: extractDecl (ClsInstD)"
        HsDecl GhcRn
_ -> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a. a -> IfM m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String (LHsDecl GhcRn)
 -> IfM m (Either String (LHsDecl GhcRn)))
-> Either String (LHsDecl GhcRn)
-> IfM m (Either String (LHsDecl GhcRn))
forall a b. (a -> b) -> a -> b
$ String -> Either String (LHsDecl GhcRn)
forall a b. a -> Either a b
Left (String
"extractDecl: Unhandled decl for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. NamedThing a => a -> String
getOccString Name
name)

extractPatternSyn
  :: Name
  -> Name
  -> [LHsTypeArg GhcRn]
  -> [LConDecl GhcRn]
  -> Either String (LSig GhcRn)
extractPatternSyn :: Name
-> Name
-> [LHsTypeArg GhcRn]
-> [LConDecl GhcRn]
-> Either String (LSig GhcRn)
extractPatternSyn Name
nm Name
t [LHsTypeArg GhcRn]
tvs [LConDecl GhcRn]
cons =
  case (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LConDecl GhcRn -> Bool
GenLocated SrcSpanAnnA (ConDecl GhcRn) -> Bool
matches [LConDecl GhcRn]
[GenLocated SrcSpanAnnA (ConDecl GhcRn)]
cons of
    [] ->
      String -> Either String (LSig GhcRn)
String -> Either String (GenLocated SrcSpanAnnA (Sig GhcRn))
forall a b. a -> Either a b
Left (String -> Either String (LSig GhcRn))
-> (SDoc -> String) -> SDoc -> Either String (LSig GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> String
O.showSDocOneLine SDocContext
O.defaultSDocContext (SDoc -> Either String (LSig GhcRn))
-> SDoc -> Either String (LSig GhcRn)
forall a b. (a -> b) -> a -> b
$
        String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"constructor pattern " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
O.ppr Name
nm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<+> String -> SDoc
forall doc. IsLine doc => String -> doc
O.text String
"not found in type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
O.<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
O.ppr Name
t
    GenLocated SrcSpanAnnA (ConDecl GhcRn)
con : [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
_ -> GenLocated SrcSpanAnnA (Sig GhcRn)
-> Either String (GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Either String a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ConDecl GhcRn -> Sig GhcRn
extract (ConDecl GhcRn -> Sig GhcRn)
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (ConDecl GhcRn)
con)
  where
    matches :: LConDecl GhcRn -> Bool
    matches :: LConDecl GhcRn -> Bool
matches (L SrcSpanAnnA
_ ConDecl GhcRn
con) = Name
nm Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name]
getConNames ConDecl GhcRn
con)
    extract :: ConDecl GhcRn -> Sig GhcRn
    extract :: ConDecl GhcRn -> Sig GhcRn
extract ConDecl GhcRn
con =
      let args :: [GenLocated SrcSpanAnnA (HsType GhcRn)]
args =
            case ConDecl GhcRn
con of
              ConDeclH98{con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = HsConDeclH98Details GhcRn
con_args'} -> case HsConDeclH98Details GhcRn
con_args' of
                PrefixCon [Void]
_ [HsScaled GhcRn (LBangType GhcRn)]
args' -> (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass a. HsScaled pass a -> a
hsScaledThing [HsScaled GhcRn (LBangType GhcRn)]
[HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
args'
                RecCon (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
fields) -> ConDeclField GhcRn -> LBangType GhcRn
ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
    -> ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
fields
                InfixCon HsScaled GhcRn (LBangType GhcRn)
arg1 HsScaled GhcRn (LBangType GhcRn)
arg2 -> (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass a. HsScaled pass a -> a
hsScaledThing [HsScaled GhcRn (LBangType GhcRn)
HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
arg1, HsScaled GhcRn (LBangType GhcRn)
HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
arg2]
              ConDeclGADT{con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = HsConDeclGADTDetails GhcRn
con_args'} -> case HsConDeclGADTDetails GhcRn
con_args' of
                PrefixConGADT XPrefixConGADT GhcRn
_ [HsScaled GhcRn (LBangType GhcRn)]
args' -> (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass a. HsScaled pass a -> a
hsScaledThing [HsScaled GhcRn (LBangType GhcRn)]
[HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
args'
                RecConGADT XRecConGADT GhcRn
_ (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
fields) -> ConDeclField GhcRn -> LBangType GhcRn
ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
    -> ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
fields
          typ :: LBangType GhcRn
typ = [LBangType GhcRn] -> LBangType GhcRn -> LBangType GhcRn
longArrow [LBangType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
args (ConDecl GhcRn -> LBangType GhcRn
data_ty ConDecl GhcRn
con)
          typ' :: GenLocated SrcSpanAnnA (HsType GhcRn)
typ' =
            case ConDecl GhcRn
con of
              ConDeclH98{con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Just LHsContext GhcRn
cxt} -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XQualTy GhcRn
-> LHsContext GhcRn -> LBangType GhcRn -> HsType GhcRn
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy XQualTy GhcRn
NoExtField
noExtField LHsContext GhcRn
cxt LBangType GhcRn
typ)
              ConDecl GhcRn
_ -> LBangType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
typ
          typ'' :: GenLocated SrcSpanAnnA (HsType GhcRn)
typ'' = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XQualTy GhcRn
-> LHsContext GhcRn -> LBangType GhcRn -> HsType GhcRn
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy XQualTy GhcRn
NoExtField
noExtField ([LBangType GhcRn] -> GenLocated SrcSpanAnnC [LBangType GhcRn]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA []) LBangType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
typ')
       in XPatSynSig GhcRn -> [LIdP GhcRn] -> LHsSigType GhcRn -> Sig GhcRn
forall pass.
XPatSynSig pass -> [LIdP pass] -> LHsSigType pass -> Sig pass
PatSynSig XPatSynSig GhcRn
AnnSig
forall a. NoAnn a => a
noAnn [Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
nm] (LBangType GhcRn -> LHsSigType GhcRn
mkEmptySigType LBangType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
typ'')

    longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
    longArrow :: [LBangType GhcRn] -> LBangType GhcRn -> LBangType GhcRn
longArrow [LBangType GhcRn]
inputs LBangType GhcRn
output = (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\GenLocated SrcSpanAnnA (HsType GhcRn)
x GenLocated SrcSpanAnnA (HsType GhcRn)
y -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XFunTy GhcRn
-> HsArrow GhcRn
-> LBangType GhcRn
-> LBangType GhcRn
-> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
NoExtField
noExtField (XUnrestrictedArrow (GenLocated SrcSpanAnnA (HsType GhcRn)) GhcRn
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcRn)) GhcRn
forall mult pass.
XUnrestrictedArrow mult pass -> HsArrowOf mult pass
HsUnrestrictedArrow NoExtField
XUnrestrictedArrow (GenLocated SrcSpanAnnA (HsType GhcRn)) GhcRn
noExtField) LBangType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
x LBangType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
y)) LBangType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
output [LBangType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
inputs

    data_ty :: ConDecl GhcRn -> LBangType GhcRn
data_ty ConDecl GhcRn
con
      | ConDeclGADT{} <- ConDecl GhcRn
con = ConDecl GhcRn -> LBangType GhcRn
forall pass. ConDecl pass -> LHsType pass
con_res_ty ConDecl GhcRn
con
      | Bool
otherwise = (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> HsArg
      GhcRn
      (GenLocated SrcSpanAnnA (HsType GhcRn))
      (GenLocated SrcSpanAnnA (HsType GhcRn))
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> [HsArg
      GhcRn
      (GenLocated SrcSpanAnnA (HsType GhcRn))
      (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\GenLocated SrcSpanAnnA (HsType GhcRn)
x HsArg
  GhcRn
  (GenLocated SrcSpanAnnA (HsType GhcRn))
  (GenLocated SrcSpanAnnA (HsType GhcRn))
y -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (LBangType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
mkAppTyArg LBangType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
x LHsTypeArg GhcRn
HsArg
  GhcRn
  (GenLocated SrcSpanAnnA (HsType GhcRn))
  (GenLocated SrcSpanAnnA (HsType GhcRn))
y)) (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar [AddEpAnn]
XTyVar GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted (Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
t))) [LHsTypeArg GhcRn]
[HsArg
   GhcRn
   (GenLocated SrcSpanAnnA (HsType GhcRn))
   (GenLocated SrcSpanAnnA (HsType GhcRn))]
tvs
      where
        mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
        mkAppTyArg :: LBangType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
mkAppTyArg LBangType GhcRn
f (HsValArg XValArg GhcRn
_ LBangType GhcRn
ty) = XAppTy GhcRn -> LBangType GhcRn -> LBangType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcRn
NoExtField
noExtField LBangType GhcRn
f LBangType GhcRn
ty
        mkAppTyArg LBangType GhcRn
f (HsTypeArg XTypeArg GhcRn
_ LBangType GhcRn
ki) = XAppKindTy GhcRn
-> LBangType GhcRn -> LBangType GhcRn -> HsType GhcRn
forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy XAppKindTy GhcRn
NoExtField
noExtField LBangType GhcRn
f LBangType GhcRn
ki
        mkAppTyArg LBangType GhcRn
f (HsArgPar XArgPar GhcRn
_) = XParTy GhcRn -> LBangType GhcRn -> HsType GhcRn
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcRn
AnnParen
forall a. NoAnn a => a
noAnn LBangType GhcRn
f

extractRecSel
  :: Name
  -> Name
  -> [LHsTypeArg GhcRn]
  -> [LConDecl GhcRn]
  -> Either String (LSig GhcRn)
extractRecSel :: Name
-> Name
-> [LHsTypeArg GhcRn]
-> [LConDecl GhcRn]
-> Either String (LSig GhcRn)
extractRecSel Name
_ Name
_ [LHsTypeArg GhcRn]
_ [] = String -> Either String (GenLocated SrcSpanAnnA (Sig GhcRn))
forall a b. a -> Either a b
Left String
"extractRecSel: selector not found"
extractRecSel Name
nm Name
t [LHsTypeArg GhcRn]
tvs (L SrcSpanAnnA
_ ConDecl GhcRn
con : [LConDecl GhcRn]
rest) =
  case ConDecl GhcRn -> Maybe (LocatedL [LConDeclField GhcRn])
getRecConArgs_maybe ConDecl GhcRn
con of
    Just (L SrcSpanAnnL
_ [LConDeclField GhcRn]
fields)
      | ((SrcSpan
l, L SrcSpanAnnA
_ (ConDeclField XConDeclField GhcRn
_ [LFieldOcc GhcRn]
_nn LBangType GhcRn
ty Maybe (LHsDoc GhcRn)
_)) : [(SrcSpan, LConDeclField GhcRn)]
_) <- [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
matching_fields [LConDeclField GhcRn]
fields ->
          GenLocated SrcSpanAnnA (Sig GhcRn)
-> Either String (GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Either String a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) (XTypeSig GhcRn -> [LIdP GhcRn] -> LHsSigWcType GhcRn -> Sig GhcRn
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcRn
AnnSig
forall a. NoAnn a => a
noAnn [Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
nm] (LHsSigType GhcRn -> LHsSigWcType GhcRn
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (LHsSigType GhcRn -> LHsSigWcType GhcRn)
-> LHsSigType GhcRn -> LHsSigWcType GhcRn
forall a b. (a -> b) -> a -> b
$ LBangType GhcRn -> LHsSigType GhcRn
mkEmptySigType (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XFunTy GhcRn
-> HsArrow GhcRn
-> LBangType GhcRn
-> LBangType GhcRn
-> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
NoExtField
noExtField (XUnrestrictedArrow (GenLocated SrcSpanAnnA (HsType GhcRn)) GhcRn
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcRn)) GhcRn
forall mult pass.
XUnrestrictedArrow mult pass -> HsArrowOf mult pass
HsUnrestrictedArrow NoExtField
XUnrestrictedArrow (GenLocated SrcSpanAnnA (HsType GhcRn)) GhcRn
noExtField) LBangType GhcRn
data_ty (LBangType GhcRn -> LBangType GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
getBangType LBangType GhcRn
ty))))))
    Maybe (LocatedL [LConDeclField GhcRn])
_ -> Name
-> Name
-> [LHsTypeArg GhcRn]
-> [LConDecl GhcRn]
-> Either String (LSig GhcRn)
extractRecSel Name
nm Name
t [LHsTypeArg GhcRn]
tvs [LConDecl GhcRn]
rest
  where
    matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
    matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
matching_fields [LConDeclField GhcRn]
flds =
      [ (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l, LConDeclField GhcRn
GenLocated SrcSpanAnnA (ConDeclField GhcRn)
f) | f :: GenLocated SrcSpanAnnA (ConDeclField GhcRn)
f@(L SrcSpanAnnA
_ (ConDeclField XConDeclField GhcRn
_ [LFieldOcc GhcRn]
ns LBangType GhcRn
_ Maybe (LHsDoc GhcRn)
_)) <- [LConDeclField GhcRn]
[GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds, L SrcSpanAnnA
l FieldOcc GhcRn
n <- [LFieldOcc GhcRn]
[GenLocated SrcSpanAnnA (FieldOcc GhcRn)]
ns, FieldOcc GhcRn -> XCFieldOcc GhcRn
forall pass. FieldOcc pass -> XCFieldOcc pass
foExt FieldOcc GhcRn
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm
      ]
    data_ty :: LBangType GhcRn
data_ty
      -- ResTyGADT _ ty <- con_res con = ty
      | ConDeclGADT{} <- ConDecl GhcRn
con = ConDecl GhcRn -> LBangType GhcRn
forall pass. ConDecl pass -> LHsType pass
con_res_ty ConDecl GhcRn
con
      | Bool
otherwise = (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> HsArg
      GhcRn
      (GenLocated SrcSpanAnnA (HsType GhcRn))
      (GenLocated SrcSpanAnnA (HsType GhcRn))
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> [HsArg
      GhcRn
      (GenLocated SrcSpanAnnA (HsType GhcRn))
      (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\GenLocated SrcSpanAnnA (HsType GhcRn)
x HsArg
  GhcRn
  (GenLocated SrcSpanAnnA (HsType GhcRn))
  (GenLocated SrcSpanAnnA (HsType GhcRn))
y -> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (LBangType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
mkAppTyArg LBangType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
x LHsTypeArg GhcRn
HsArg
  GhcRn
  (GenLocated SrcSpanAnnA (HsType GhcRn))
  (GenLocated SrcSpanAnnA (HsType GhcRn))
y)) (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar [AddEpAnn]
XTyVar GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted (Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
t))) [LHsTypeArg GhcRn]
[HsArg
   GhcRn
   (GenLocated SrcSpanAnnA (HsType GhcRn))
   (GenLocated SrcSpanAnnA (HsType GhcRn))]
tvs
      where
        mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
        mkAppTyArg :: LBangType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
mkAppTyArg LBangType GhcRn
f (HsValArg XValArg GhcRn
_ LBangType GhcRn
ty) = XAppTy GhcRn -> LBangType GhcRn -> LBangType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcRn
NoExtField
noExtField LBangType GhcRn
f LBangType GhcRn
ty
        mkAppTyArg LBangType GhcRn
f (HsTypeArg XTypeArg GhcRn
_ LBangType GhcRn
ki) = XAppKindTy GhcRn
-> LBangType GhcRn -> LBangType GhcRn -> HsType GhcRn
forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy XAppKindTy GhcRn
NoExtField
noExtField LBangType GhcRn
f LBangType GhcRn
ki
        mkAppTyArg LBangType GhcRn
f (HsArgPar XArgPar GhcRn
_) = XParTy GhcRn -> LBangType GhcRn -> HsType GhcRn
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcRn
AnnParen
forall a. NoAnn a => a
noAnn LBangType GhcRn
f

-- | Keep export items with docs.
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
pruneExportItems = (ExportItem GhcRn -> Bool)
-> [ExportItem GhcRn] -> [ExportItem GhcRn]
forall a. (a -> Bool) -> [a] -> [a]
filter ExportItem GhcRn -> Bool
forall {name} {name}.
(XExportDecl name ~ ExportD name) =>
ExportItem name -> Bool
hasDoc
  where
    hasDoc :: ExportItem name -> Bool
hasDoc (ExportDecl ExportD{expDMbDoc :: forall name. ExportD name -> DocForDecl (IdP name)
expDMbDoc = (Documentation Maybe (MDoc (IdP name))
d Maybe (Doc (IdP name))
_, FnArgsDoc (IdP name)
_)}) = Maybe (MDoc (IdP name)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (MDoc (IdP name))
d
    hasDoc ExportItem name
_ = Bool
True

mkVisibleNames :: InstMap -> [ExportItem GhcRn] -> [DocOption] -> [Name]
mkVisibleNames :: Map RealSrcSpan Name -> [ExportItem GhcRn] -> [DocOption] -> [Name]
mkVisibleNames Map RealSrcSpan Name
instMap [ExportItem GhcRn]
exports [DocOption]
opts
  | DocOption
OptHide DocOption -> [DocOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [DocOption]
opts = []
  | Bool
otherwise =
      let ns :: [Name]
ns = (ExportItem GhcRn -> [Name]) -> [ExportItem GhcRn] -> [Name]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ExportItem GhcRn -> [Name]
exportName [ExportItem GhcRn]
exports
       in [Name] -> ()
forall a. [a] -> ()
seqList [Name]
ns () -> [Name] -> [Name]
forall a b. a -> b -> b
`seq` [Name]
ns
  where
    exportName :: ExportItem GhcRn -> [Name]
exportName (ExportDecl e :: XExportDecl GhcRn
e@ExportD{}) = [Name]
name [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
subs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
patsyns
      where
        subs :: [Name]
subs = ((Name, DocForDecl Name) -> Name)
-> [(Name, DocForDecl Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, DocForDecl Name) -> Name
forall a b. (a, b) -> a
fst (ExportD GhcRn -> [(IdP GhcRn, DocForDecl (IdP GhcRn))]
forall name. ExportD name -> [(IdP name, DocForDecl (IdP name))]
expDSubDocs ExportD GhcRn
XExportDecl GhcRn
e)
        patsyns :: [Name]
patsyns = ((HsDecl GhcRn, DocForDecl Name) -> [Name])
-> [(HsDecl GhcRn, DocForDecl Name)] -> [Name]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (OccEnv Name -> HsDecl GhcRn -> [Name]
getMainDeclBinder OccEnv Name
forall a. OccEnv a
emptyOccEnv (HsDecl GhcRn -> [Name])
-> ((HsDecl GhcRn, DocForDecl Name) -> HsDecl GhcRn)
-> (HsDecl GhcRn, DocForDecl Name)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsDecl GhcRn, DocForDecl Name) -> HsDecl GhcRn
forall a b. (a, b) -> a
fst) (ExportD GhcRn -> [(HsDecl GhcRn, DocForDecl (IdP GhcRn))]
forall name. ExportD name -> [(HsDecl name, DocForDecl (IdP name))]
expDPats ExportD GhcRn
XExportDecl GhcRn
e)
        name :: [Name]
name = case GenLocated SrcSpanAnnA (HsDecl GhcRn) -> HsDecl GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsDecl GhcRn) -> HsDecl GhcRn)
-> GenLocated SrcSpanAnnA (HsDecl GhcRn) -> HsDecl GhcRn
forall a b. (a -> b) -> a -> b
$ ExportD GhcRn -> LHsDecl GhcRn
forall name. ExportD name -> LHsDecl name
expDDecl ExportD GhcRn
XExportDecl GhcRn
e of
          InstD XInstD GhcRn
_ InstDecl GhcRn
d -> Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList (Maybe Name -> [Name]) -> Maybe Name -> [Name]
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Map RealSrcSpan Name -> Maybe Name
forall a. SrcSpan -> Map RealSrcSpan a -> Maybe a
SrcLoc.lookupSrcSpan (InstDecl GhcRn -> SrcSpan
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
InstDecl (GhcPass p) -> SrcSpan
getInstLoc InstDecl GhcRn
d) Map RealSrcSpan Name
instMap
          HsDecl GhcRn
decl -> OccEnv Name -> HsDecl GhcRn -> [Name]
getMainDeclBinder OccEnv Name
forall a. OccEnv a
emptyOccEnv HsDecl GhcRn
decl
    exportName ExportNoDecl{} = [] -- we don't count these as visible, since
    -- we don't want links to go to them.
    exportName ExportItem GhcRn
_ = []

seqList :: [a] -> ()
seqList :: forall a. [a] -> ()
seqList [] = ()
seqList (a
x : [a]
xs) = a
x a -> () -> ()
forall a b. a -> b -> b
`seq` [a] -> ()
forall a. [a] -> ()
seqList [a]
xs