{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# 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) where

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

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 qualified GHC.Types.Unique.Map as UniqMap
import GHC.Core.ConLike (ConLike (..))
import GHC.Data.FastString (FastString, unpackFS, bytesFS)
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Types.Avail
import GHC.Types.Basic
import GHC.Types.Name
import GHC.Types.Name.Set
import qualified GHC.Types.SrcLoc as SrcLoc
import GHC.Unit.Module.Deps (dep_orphs)
import GHC.Unit.State (PackageName (..), UnitState)
import qualified GHC.Utils.Outputable as O
import GHC.Utils.Panic (pprPanic)
import GHC.Driver.Ppr
import GHC.Unit.Module.ModIface
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Types.SafeHaskell
import Control.Arrow ((&&&), first)
import GHC.Iface.Syntax

createInterface1
  :: MonadIO m
  => [Flag]
  -> UnitState
  -> ModSummary
  -> ModIface
  -> IfaceMap
  -> InstIfaceMap
  -> ([ClsInst],[FamInst])
  -> IfM m Interface
createInterface1 :: forall (m :: * -> *).
MonadIO m =>
[Flag]
-> UnitState
-> ModSummary
-> ModIface
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
-> 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) = do

  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
        {
          String
ml_hie_file :: String
ml_hie_file :: ModLocation -> String
ml_hie_file
        }
      } = ModSummary
mod_sum

    dflags :: DynFlags
dflags  = DynFlags
ms_hspp_opts
    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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a. Applicative f => a -> f a
pure Docs
docs
    Maybe Docs
Nothing -> do
      String -> IfM m ()
forall (m :: * -> *). 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 :: * -> *) 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 :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DocOption]
doc_opts = PrintRuntimeReps
ShowRuntimeRep
          | Bool
otherwise = PrintRuntimeReps
HideRuntimeRep

  (!info, header_doc) <-
    processModuleHeader dflags pkg_name safety
      (docs_language mod_iface_docs)
      (docs_extensions mod_iface_docs)
      (docs_mod_hdr mod_iface_docs)
  mod_warning <- moduleWarning dflags 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 dflags pkg_name) docsDecls

  exportsSinceMap <- mkExportSinceMap dflags 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 dflags 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 dflags 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
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (WarningMap
warningMap WarningMap -> [WarningMap] -> [WarningMap]
forall a. a -> [a] -> [a]
: (Interface -> WarningMap) -> [Interface] -> [WarningMap]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> WarningMap
ifaceWarningMap (IfaceMap -> [Interface]
forall k a. Map k a -> [a]
Map.elems IfaceMap
ifaces))

  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
    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 :: * -> *) 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 :: * -> *) 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           = ml_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
    , ifaceOrphanDeps        = dep_orphs $ mi_deps mod_iface
    , 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)
  => DynFlags
  -> Maybe Package
  -> Docs
  -> IfM m (Map Name MetaSince)
mkExportSinceMap :: forall (m :: * -> *).
MonadIO m =>
DynFlags -> Maybe String -> Docs -> IfM m (Map Name MetaSince)
mkExportSinceMap DynFlags
dflags Maybe String
pkg_name Docs
docs = do
    [Map Name MetaSince] -> Map Name MetaSince
forall (f :: * -> *) 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 :: * -> *) 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 :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) 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 <- DynFlags -> Maybe String -> [HsDoc GhcRn] -> IfM m (MDoc Name)
forall (m :: * -> *).
MonadIO m =>
DynFlags -> Maybe String -> [HsDoc GhcRn] -> IfM m (MDoc Name)
processDocStringsParas DynFlags
dflags Maybe String
pkg_name [HsDoc GhcRn
doc]
      case _doc mdoc of
        Doc Name
DocEmpty -> () -> IfM m ()
forall a. a -> IfM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Doc Name
_ -> String -> IfM m ()
forall (m :: * -> *). 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 :: * -> *) 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 :: * -> *) 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
  => DynFlags
  -> IfaceWarnings
  -> [Name]
  -> IfM m WarningMap
mkWarningMap :: forall (m :: * -> *).
MonadIO m =>
DynFlags -> IfaceWarnings -> [Name] -> IfM m WarningMap
mkWarningMap DynFlags
dflags 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 :: * -> *) 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 :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) 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 :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (Name, a) -> f (Name, b)
traverse (DynFlags -> IfaceWarningTxt -> IfM m (Doc Name)
forall (m :: * -> *).
MonadIO m =>
DynFlags -> IfaceWarningTxt -> IfM m (Doc Name)
parseWarning DynFlags
dflags)) [(Name, IfaceWarningTxt)]
ws'
    IfaceWarnings
_ -> WarningMap -> IfM m WarningMap
forall a. a -> IfM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WarningMap
forall k a. Map k a
Map.empty

moduleWarning
  :: MonadIO m
  => DynFlags
  -> IfaceWarnings
  -> IfM m (Maybe (Doc Name))
moduleWarning :: forall (m :: * -> *).
MonadIO m =>
DynFlags -> IfaceWarnings -> IfM m (Maybe (Doc Name))
moduleWarning DynFlags
dflags (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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> IfaceWarningTxt -> IfM m (Doc Name)
forall (m :: * -> *).
MonadIO m =>
DynFlags -> IfaceWarningTxt -> IfM m (Doc Name)
parseWarning DynFlags
dflags IfaceWarningTxt
w
moduleWarning DynFlags
_      IfaceWarnings
_             = Maybe (Doc Name) -> IfM m (Maybe (Doc Name))
forall a. a -> IfM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Doc Name)
forall a. Maybe a
Nothing

parseWarning
  :: MonadIO m
  => DynFlags
  -> IfaceWarningTxt
  -> IfM m (Doc Name)
parseWarning :: forall (m :: * -> *).
MonadIO m =>
DynFlags -> IfaceWarningTxt -> IfM m (Doc Name)
parseWarning DynFlags
dflags 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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> HsDoc GhcRn -> IfM m (Doc Name)
forall (m :: * -> *).
MonadIO m =>
DynFlags -> HsDoc GhcRn -> IfM m (Doc Name)
processDocString DynFlags
dflags 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 :: * -> *) 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 :: * -> *) 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 :: * -> *).
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 :: * -> *). 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 :: * -> *) a b. Monad m => m a -> m b -> m b
>> [DocOption] -> IfM m [DocOption]
forall a. a -> IfM m a
forall (m :: * -> *) 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 :: * -> *) 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IfM m (Maybe DocOption)
forall (m :: * -> *).
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 :: * -> *) 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 :: * -> *).
MonadIO m =>
String -> IfM m (Maybe DocOption)
parseOption String
"hide"                        = Maybe DocOption -> IfM m (Maybe DocOption)
forall a. a -> IfM m a
forall (m :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *). 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 :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DocOption -> IfM m (Maybe DocOption)
forall a. a -> IfM m a
forall (m :: * -> *) 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 :: * -> *) 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 :: * -> * -> *) 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
  -> OccEnv Name
  -> IfM m [ExportItem GhcRn]
mkExportItems :: forall (m :: * -> *).
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
-> 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 OccEnv Name
defMeths =
    [[ExportItem GhcRn]] -> [ExportItem GhcRn]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ExportItem GhcRn]] -> [ExportItem GhcRn])
-> IfM m [[ExportItem GhcRn]] -> IfM m [ExportItem GhcRn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DocStructureItem -> IfM m [ExportItem GhcRn])
-> [DocStructureItem] -> IfM m [[ExportItem GhcRn]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse DocStructureItem -> IfM m [ExportItem GhcRn]
forall (m :: * -> *).
MonadIO m =>
DocStructureItem -> IfM m [ExportItem GhcRn]
lookupExport [DocStructureItem]
dsItems
  where
    lookupExport :: MonadIO m => DocStructureItem -> IfM m [ExportItem GhcRn]
    lookupExport :: forall (m :: * -> *).
MonadIO m =>
DocStructureItem -> IfM m [ExportItem GhcRn]
lookupExport = \case
      DsiSectionHeading Key
lev HsDoc GhcRn
hsDoc' -> do
        doc <- DynFlags -> HsDoc GhcRn -> IfM m (Doc Name)
forall (m :: * -> *).
MonadIO m =>
DynFlags -> HsDoc GhcRn -> IfM m (Doc Name)
processDocString DynFlags
dflags HsDoc GhcRn
hsDoc'
        pure [ExportGroup lev "" doc]
      DsiDocChunk HsDoc GhcRn
hsDoc' -> do
        doc <- DynFlags -> Maybe String -> HsDoc GhcRn -> IfM m (MDoc Name)
forall (m :: * -> *).
MonadIO m =>
DynFlags -> Maybe String -> HsDoc GhcRn -> IfM m (MDoc Name)
processDocStringParas DynFlags
dflags 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 :: * -> *). 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 :: * -> *) a. Applicative f => a -> f a
pure []
          Just HsDoc GhcRn
hsDoc' -> do
            doc <- DynFlags -> Maybe String -> HsDoc GhcRn -> IfM m (MDoc Name)
forall (m :: * -> *).
MonadIO m =>
DynFlags -> Maybe String -> HsDoc GhcRn -> IfM m (MDoc Name)
processDocStringParas DynFlags
dflags 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ExportItem GhcRn]] -> [ExportItem GhcRn])
-> IfM m [[ExportItem GhcRn]] -> IfM m [ExportItem GhcRn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AvailInfo -> IfM m [ExportItem GhcRn])
-> [AvailInfo] -> IfM m [[ExportItem GhcRn]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse AvailInfo -> IfM m [ExportItem GhcRn]
forall (m :: * -> *).
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) <- DynFlags
-> Module
-> IfaceMap
-> InstIfaceMap
-> [AvailInfo]
-> [ModuleName]
-> IfM m ([Module], [AvailInfo])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> Module
-> IfaceMap
-> InstIfaceMap
-> [AvailInfo]
-> [ModuleName]
-> IfM m ([Module], [AvailInfo])
unrestrictedModExports DynFlags
dflags 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 :: * -> *).
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
-> AvailInfo
-> OccEnv Name
-> IfM m [ExportItem GhcRn]
forall (m :: * -> *).
MonadIO m =>
PrintRuntimeReps
-> IfaceMap
-> Module
-> WarningMap
-> Map Name MetaSince
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> FixMap
-> InstIfaceMap
-> DynFlags
-> 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 AvailInfo
avail OccEnv Name
defMeths

unrestrictedModExports
  :: MonadIO m
  => DynFlags
  -> 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 :: * -> *).
MonadIO m =>
DynFlags
-> Module
-> IfaceMap
-> InstIfaceMap
-> [AvailInfo]
-> [ModuleName]
-> IfM m ([Module], [AvailInfo])
unrestrictedModExports DynFlags
dflags 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 :: * -> *) 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 :: * -> *) (f :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *). 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]
++ DynFlags -> Module -> String
forall a. Outputable a => DynFlags -> a -> String
pretty DynFlags
dflags 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]
++ DynFlags -> ModuleName -> String
forall a. Outputable a => DynFlags -> a -> String
pretty DynFlags
dflags ModuleName
mod_name
              Maybe (Module, NameSet) -> IfM m (Maybe (Module, NameSet))
forall a. a -> IfM m a
forall (f :: * -> *) 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 :: * -> *) 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 :: * -> *) 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
  -> AvailInfo
  -> OccEnv Name       -- Default methods
  -> IfM m [ExportItem GhcRn]
availExportItem :: forall (m :: * -> *).
MonadIO m =>
PrintRuntimeReps
-> IfaceMap
-> Module
-> WarningMap
-> Map Name MetaSince
-> DocMap Name
-> Map Name (Map Key (MDoc Name))
-> FixMap
-> InstIfaceMap
-> DynFlags
-> 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
    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 <- DynFlags
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl DynFlags
dflags 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> * -> *) 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 :: * -> *). 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]
++ DynFlags -> Module -> String
forall a. Outputable a => DynFlags -> a -> String
pretty DynFlags
dflags 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]
++ DynFlags -> Name -> String
forall a. Outputable a => DynFlags -> a -> String
pretty DynFlags
dflags 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 :: * -> *) 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 :: * -> *) 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 :: * -> * -> *) 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
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: * -> *).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags 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 :: * -> *) 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 :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsDecl GhcRn)
d
        Left String
err -> do
          synifiedDeclOpt <- DynFlags
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl DynFlags
dflags 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) (f :: * -> *) 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 :: * -> *) (f :: * -> *) 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 :: * -> *). 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 :: * -> *) 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
  => DynFlags
  -> PrintRuntimeReps
  -> Name
  -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl :: forall (m :: * -> *).
MonadIO m =>
DynFlags
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl DynFlags
dflags PrintRuntimeReps
prr Name
t = do
  mayTyThing <- Name -> IfM m (Maybe TyThing)
forall (m :: * -> *). Monad m => Name -> IfM m (Maybe TyThing)
lookupName Name
t
  case mayTyThing of
    Maybe TyThing
Nothing -> do
      String -> IfM m ()
forall (m :: * -> *). 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]
++ DynFlags -> Name -> String
forall a. Outputable a => DynFlags -> a -> String
pretty DynFlags
dflags Name
t
      Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn))
-> IfM m (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcRn)))
forall a. a -> IfM m a
forall (m :: * -> *) 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 :: * -> *). 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> IfM m ()
forall (m :: * -> *). 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 :: * -> *) 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 :: * -> *) 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 = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (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
  -> Name                      -- ^ name of the declaration to extract
  -> LHsDecl GhcRn             -- ^ parent declaration
  -> IfM m (Either String (LHsDecl GhcRn))
extractDecl :: forall (m :: * -> *).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags Name
name LHsDecl GhcRn
decl
  | Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) 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 :: * -> *) 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
$ GenLocated SrcSpanAnnA (HsDecl GhcRn)
-> Either String (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. b -> Either a b
Right LHsDecl GhcRn
GenLocated SrcSpanAnnA (HsDecl 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 :: * -> *) 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 :: * -> *) 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))
            ]

            -- TODO: document fixity
        in 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 :: * -> *) 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 :: * -> *) 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 <- DynFlags
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl DynFlags
dflags 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 :: * -> *) 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 :: * -> *) 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
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: * -> *).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags 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 :: * -> *) 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 (GenLocated SrcSpanAnnA (HsDecl GhcRn))
forall a b. a -> Either a b
Left ([String] -> String
forall (t :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 <- DynFlags
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> PrintRuntimeReps -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl DynFlags
dflags PrintRuntimeReps
prr Name
name
            case famInstOpt of
              Just GenLocated SrcSpanAnnA (HsDecl GhcRn)
famInst -> PrintRuntimeReps
-> DynFlags
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: * -> *).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([GenLocated SrcSpanAnnN Name] -> [GenLocated SrcSpanAnnN Name]
forall a. [a] -> [a]
forall (t :: * -> *) 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
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: * -> *).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags 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 :: * -> *) 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 (GenLocated SrcSpanAnnA (HsDecl 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 :: * -> *) 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 :: * -> *) 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
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
forall (m :: * -> *).
MonadIO m =>
PrintRuntimeReps
-> DynFlags
-> Name
-> LHsDecl GhcRn
-> IfM m (Either String (LHsDecl GhcRn))
extractDecl PrintRuntimeReps
prr DynFlags
dflags 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 :: * -> *) 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 (GenLocated SrcSpanAnnA (HsDecl 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 :: * -> *) 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 (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)

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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 GhcRn -> HsArrow GhcRn
forall pass. XUnrestrictedArrow pass -> HsArrow pass
HsUnrestrictedArrow NoExtField
XUnrestrictedArrow 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 :: * -> *) 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 :: * -> *) 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 GhcRn -> HsArrow GhcRn
forall pass. XUnrestrictedArrow pass -> HsArrow pass
HsUnrestrictedArrow NoExtField
XUnrestrictedArrow 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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