{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

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

-- |
-- Module      :  Haddock.Interface.AttachInstances
-- Copyright   :  (c) Simon Marlow 2006,
--                    David Waern  2006-2009,
--                    Isaac Dupree 2009
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
module Haddock.Interface.AttachInstances (attachInstances, instHead) where

import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
import Control.DeepSeq (force)
import Control.Monad (unless)
import Data.Foldable (toList)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import Data.Ord (comparing)
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import GHC
import GHC.Builtin.Types (unrestrictedFunTyConName)
import GHC.Core (isOrphan)
import GHC.Core.Class
import GHC.Core.Coercion
import GHC.Core.Coercion.Axiom
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
import GHC.Core.TyCo.Compare (eqType)
import GHC.Core.TyCo.Rep
import GHC.Core.TyCon
import GHC.Data.FastString (unpackFS)
import GHC.Driver.Env.Types
import GHC.HsToCore.Docs
import GHC.Iface.Load
import GHC.Tc.Instance.Family
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.Unique.Map
import GHC.Types.Var hiding (varName)
import GHC.Unit.Env
import GHC.Unit.Module.Env (mkModuleSet, moduleSetElts)
import GHC.Unit.State
import GHC.Utils.Outputable (sep, text, (<+>))

import Haddock.Convert
import Haddock.GhcUtils (typeNames)
import Haddock.Types

type ExportedNames = Set.Set Name
type Modules = Set.Set Module
type ExportInfo = (ExportedNames, Modules)

-- Also attaches fixities
attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Bool -> Ghc [Interface]
attachInstances :: ExportInfo
-> [Interface] -> InstIfaceMap -> Bool -> Ghc [Interface]
attachInstances ExportInfo
expInfo [Interface]
ifaces InstIfaceMap
instIfaceMap Bool
isOneShot = do
  -- We need to keep load modules in which we will look for instances. We've
  -- somewhat arbitrarily decided to load all modules which are available -
  -- either directly or from a re-export.
  --
  -- See https://github.com/haskell/haddock/issues/469.
  env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
  let mod_to_pkg_conf = UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap (UnitState -> ModuleNameProvidersMap)
-> UnitState -> ModuleNameProvidersMap
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units (UnitEnv -> UnitState) -> UnitEnv -> UnitState
forall a b. (a -> b) -> a -> b
$ HscEnv -> UnitEnv
hsc_unit_env HscEnv
env
      mods =
        [Module] -> ModuleSet
mkModuleSet
          [ Module
m
          | UniqMap Module ModuleOrigin
mod_map <- ModuleNameProvidersMap -> [UniqMap Module ModuleOrigin]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap ModuleNameProvidersMap
mod_to_pkg_conf
          , ( Module
m
              , ModOrigin
                  { fromOrigUnit :: ModuleOrigin -> Maybe Bool
fromOrigUnit = Maybe Bool
fromOrig
                  , fromExposedReexport :: ModuleOrigin -> [UnitInfo]
fromExposedReexport = [UnitInfo]
reExp
                  }
              ) <-
              UniqMap Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap Module ModuleOrigin
mod_map
          , Maybe Bool
fromOrig Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Bool -> Bool -> Bool
|| Bool -> Bool
not ([UnitInfo] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [UnitInfo]
reExp)
          ]
      mods_to_load = ModuleSet -> [Module]
moduleSetElts ModuleSet
mods
      mods_visible = [Module] -> ModuleSet
mkModuleSet ([Module] -> ModuleSet) -> [Module] -> ModuleSet
forall a b. (a -> b) -> a -> b
$ (Interface -> Module) -> [Interface] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> Module
ifaceMod [Interface]
ifaces

  (_msgs, mb_index) <- do
    hsc_env <- getSession
    liftIO $ runTcInteractive hsc_env $ do
      -- In one shot mode we don't want to load anything more than is already loaded
      unless isOneShot $ do
        let doc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Need interface for haddock"
        initIfaceTcRn $ mapM_ (loadSysInterface doc) mods_to_load
      cls_env@InstEnvs{ie_global, ie_local} <- tcGetInstEnvs
      fam_env@(pkg_fie, home_fie) <- tcGetFamInstEnvs
      -- We use Data.Sequence.Seq because we are creating left associated
      -- mappends.
      -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts
      let cls_index =
            (Seq ClsInst -> Seq ClsInst -> Seq ClsInst)
-> [(Name, Seq ClsInst)] -> Map Name (Seq ClsInst)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
              Seq ClsInst -> Seq ClsInst -> Seq ClsInst
forall a. Monoid a => a -> a -> a
mappend
              [ (Name
n, ClsInst -> Seq ClsInst
forall a. a -> Seq a
Seq.singleton ClsInst
ispec)
              | ClsInst
ispec <- InstEnv -> [ClsInst]
instEnvElts InstEnv
ie_local [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ InstEnv -> [ClsInst]
instEnvElts InstEnv
ie_global
              , ModuleSet -> ClsInst -> Bool
instIsVisible ModuleSet
mods_visible ClsInst
ispec
              , Name
n <- NameSet -> [Name]
nameSetElemsStable (NameSet -> [Name]) -> NameSet -> [Name]
forall a b. (a -> b) -> a -> b
$ ClsInst -> NameSet
orphNamesOfClsInst ClsInst
ispec
              ]
          fam_index =
            (Seq FamInst -> Seq FamInst -> Seq FamInst)
-> [(Name, Seq FamInst)] -> Map Name (Seq FamInst)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
              Seq FamInst -> Seq FamInst -> Seq FamInst
forall a. Monoid a => a -> a -> a
mappend
              [ (Name
n, FamInst -> Seq FamInst
forall a. a -> Seq a
Seq.singleton FamInst
fispec)
              | FamInst
fispec <- FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
home_fie [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
pkg_fie
              , Name
n <- NameSet -> [Name]
nameSetElemsStable (NameSet -> [Name]) -> NameSet -> [Name]
forall a b. (a -> b) -> a -> b
$ FamInst -> NameSet
orphNamesOfFamInst FamInst
fispec
              ]
          instance_map =
            [(Name, ([ClsInst], [FamInst]))] -> NameEnv ([ClsInst], [FamInst])
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, ([ClsInst], [FamInst]))]
 -> NameEnv ([ClsInst], [FamInst]))
-> [(Name, ([ClsInst], [FamInst]))]
-> NameEnv ([ClsInst], [FamInst])
forall a b. (a -> b) -> a -> b
$
              [ (Name
nm, (Seq ClsInst -> [ClsInst]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq ClsInst
clss, Seq FamInst -> [FamInst]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq FamInst
fams))
              | (Name
nm, (Seq ClsInst
clss, Seq FamInst
fams)) <-
                  Map Name (Seq ClsInst, Seq FamInst)
-> [(Name, (Seq ClsInst, Seq FamInst))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Name (Seq ClsInst, Seq FamInst)
 -> [(Name, (Seq ClsInst, Seq FamInst))])
-> Map Name (Seq ClsInst, Seq FamInst)
-> [(Name, (Seq ClsInst, Seq FamInst))]
forall a b. (a -> b) -> a -> b
$
                    ((Seq ClsInst, Seq FamInst)
 -> (Seq ClsInst, Seq FamInst) -> (Seq ClsInst, Seq FamInst))
-> Map Name (Seq ClsInst, Seq FamInst)
-> Map Name (Seq ClsInst, Seq FamInst)
-> Map Name (Seq ClsInst, Seq FamInst)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith
                      (Seq ClsInst, Seq FamInst)
-> (Seq ClsInst, Seq FamInst) -> (Seq ClsInst, Seq FamInst)
forall a. Monoid a => a -> a -> a
mappend
                      ((Seq ClsInst -> (Seq ClsInst, Seq FamInst))
-> Map Name (Seq ClsInst) -> Map Name (Seq ClsInst, Seq FamInst)
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Seq FamInst
forall a. Seq a
Seq.empty) Map Name (Seq ClsInst)
cls_index)
                      ((Seq FamInst -> (Seq ClsInst, Seq FamInst))
-> Map Name (Seq FamInst) -> Map Name (Seq ClsInst, Seq FamInst)
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Seq ClsInst
forall a. Seq a
Seq.empty,) Map Name (Seq FamInst)
fam_index)
              ]
      pure $ (cls_env{ie_visible = mods_visible}, fam_env, instance_map)

  let empty_index = (InstEnv -> InstEnv -> ModuleSet -> InstEnvs
InstEnvs InstEnv
emptyInstEnv InstEnv
emptyInstEnv ModuleSet
mods_visible, FamInstEnvs
emptyFamInstEnvs, NameEnv ([ClsInst], [FamInst])
forall a. NameEnv a
emptyNameEnv)
  mapM (attach $ fromMaybe empty_index mb_index) ifaces
  where
    -- TODO: take an IfaceMap as input
    ifaceMap :: Map Module Interface
ifaceMap = [(Module, Interface)] -> Map Module Interface
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Interface -> Module
ifaceMod Interface
i, Interface
i) | Interface
i <- [Interface]
ifaces]

    attach :: (InstEnvs, FamInstEnvs, NameEnv ([ClsInst], [FamInst]))
-> Interface -> Ghc Interface
attach (InstEnvs
cls_insts, FamInstEnvs
fam_insts, NameEnv ([ClsInst], [FamInst])
inst_map) Interface
iface = do
      let getInstDoc :: Name -> Maybe (MDoc Name)
getInstDoc = Interface
-> Map Module Interface
-> InstIfaceMap
-> Name
-> Maybe (MDoc Name)
findInstDoc Interface
iface Map Module Interface
ifaceMap InstIfaceMap
instIfaceMap
          getFixity :: Name -> Maybe Fixity
getFixity = Interface
-> Map Module Interface -> InstIfaceMap -> Name -> Maybe Fixity
findFixity Interface
iface Map Module Interface
ifaceMap InstIfaceMap
instIfaceMap
          getInstLocIface :: Name -> Maybe RealSrcSpan
getInstLocIface Name
name = Name -> Map Name RealSrcSpan -> Maybe RealSrcSpan
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (Map Name RealSrcSpan -> Maybe RealSrcSpan)
-> (InstalledInterface -> Map Name RealSrcSpan)
-> InstalledInterface
-> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledInterface -> Map Name RealSrcSpan
instInstanceLocMap (InstalledInterface -> Maybe RealSrcSpan)
-> Maybe InstalledInterface -> Maybe RealSrcSpan
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> InstIfaceMap -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name) InstIfaceMap
instIfaceMap

      newItems <-
        (ExportItem GhcRn -> Ghc (ExportItem GhcRn))
-> [ExportItem GhcRn] -> Ghc [ExportItem GhcRn]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM
          (InstEnvs
-> FamInstEnvs
-> NameEnv ([ClsInst], [FamInst])
-> ExportInfo
-> (Name -> Maybe (MDoc Name))
-> (Name -> Maybe Fixity)
-> (Name -> Maybe RealSrcSpan)
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
attachToExportItem InstEnvs
cls_insts FamInstEnvs
fam_insts NameEnv ([ClsInst], [FamInst])
inst_map ExportInfo
expInfo Name -> Maybe (MDoc Name)
getInstDoc Name -> Maybe Fixity
getFixity Name -> Maybe RealSrcSpan
getInstLocIface)
          (Interface -> [ExportItem GhcRn]
ifaceExportItems Interface
iface)
      let orphanInstances = ExportInfo
-> (Name -> Maybe (MDoc Name))
-> [ClsInst]
-> FamInstEnvs
-> [DocInstance GhcRn]
attachOrphanInstances ExportInfo
expInfo Name -> Maybe (MDoc Name)
getInstDoc (Interface -> [ClsInst]
ifaceInstances Interface
iface) FamInstEnvs
fam_insts
      return $
        iface
          { ifaceExportItems = newItems
          , ifaceOrphanInstances = orphanInstances
          }

attachOrphanInstances
  :: ExportInfo
  -> (Name -> Maybe (MDoc Name))
  -- ^ how to lookup the doc of an instance
  -> [ClsInst]
  -- ^ a list of orphan instances
  -> FamInstEnvs
  -- ^ all the family instances (that we know of)
  -> [DocInstance GhcRn]
attachOrphanInstances :: ExportInfo
-> (Name -> Maybe (MDoc Name))
-> [ClsInst]
-> FamInstEnvs
-> [DocInstance GhcRn]
attachOrphanInstances ExportInfo
expInfo Name -> Maybe (MDoc Name)
getInstDoc [ClsInst]
cls_instances FamInstEnvs
fam_index =
  [ (([TyVar], [PredType], Class, [PredType])
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
-> InstHead GhcRn
synifyInstHead ([TyVar], [PredType], Class, [PredType])
i [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
famInsts, Name -> Maybe (MDoc Name)
getInstDoc Name
n, (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n) Name
n), Name -> Maybe Module
nameModule_maybe Name
n)
  | let is :: [(([TyVar], [PredType], Class, [PredType]), Name)]
is = [(ClsInst -> ([TyVar], [PredType], Class, [PredType])
instanceSig ClsInst
i, ClsInst -> Name
forall a. NamedThing a => a -> Name
getName ClsInst
i) | ClsInst
i <- [ClsInst]
cls_instances, IsOrphan -> Bool
isOrphan (ClsInst -> IsOrphan
is_orphan ClsInst
i)]
  , (i :: ([TyVar], [PredType], Class, [PredType])
i@([TyVar]
_, [PredType]
_, Class
cls, [PredType]
tys), Name
n) <- ((([TyVar], [PredType], Class, [PredType]), Name)
 -> (([TyVar], [PredType], Class, [PredType]), Name) -> Ordering)
-> [(([TyVar], [PredType], Class, [PredType]), Name)]
-> [(([TyVar], [PredType], Class, [PredType]), Name)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (((([TyVar], [PredType], Class, [PredType]), Name)
 -> (([Int], SName, [SimpleType]), Name))
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((([TyVar], [PredType], Class, [PredType]), Name)
  -> (([Int], SName, [SimpleType]), Name))
 -> (([TyVar], [PredType], Class, [PredType]), Name)
 -> (([TyVar], [PredType], Class, [PredType]), Name)
 -> Ordering)
-> ((([TyVar], [PredType], Class, [PredType]), Name)
    -> (([Int], SName, [SimpleType]), Name))
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> Ordering
forall a b. (a -> b) -> a -> b
$ (([TyVar], [PredType], Class, [PredType])
 -> ([Int], SName, [SimpleType]))
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> (([Int], SName, [SimpleType]), Name)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([TyVar], [PredType], Class, [PredType])
-> ([Int], SName, [SimpleType])
instHead) [(([TyVar], [PredType], Class, [PredType]), Name)]
is
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ExportInfo -> Name -> [PredType] -> Bool
isInstanceHidden ExportInfo
expInfo (Class -> Name
forall a. NamedThing a => a -> Name
getName Class
cls) [PredType]
tys
  , let famInsts :: [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
famInsts = ExportInfo
-> FamInstEnvs
-> (Name -> Maybe (MDoc Name))
-> Class
-> [PredType]
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
getFamInsts ExportInfo
expInfo FamInstEnvs
fam_index Name -> Maybe (MDoc Name)
getInstDoc Class
cls [PredType]
tys
  ]

attachToExportItem
  :: InstEnvs
  -- ^ all class instances (that we know of)
  -> FamInstEnvs
  -- ^ all the family instances (that we know of)
  -> NameEnv ([ClsInst], [FamInst])
  -- ^ all instances again, but for looking up instances for data families
  -> ExportInfo
  -> (Name -> Maybe (MDoc Name))
  -- ^ how to lookup the doc of an instance
  -> (Name -> Maybe Fixity)
  -- ^ how to lookup a fixity
  -> (Name -> Maybe RealSrcSpan)
  -- ^ how to lookup definition spans for instances
  -> ExportItem GhcRn
  -> Ghc (ExportItem GhcRn)
attachToExportItem :: InstEnvs
-> FamInstEnvs
-> NameEnv ([ClsInst], [FamInst])
-> ExportInfo
-> (Name -> Maybe (MDoc Name))
-> (Name -> Maybe Fixity)
-> (Name -> Maybe RealSrcSpan)
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
attachToExportItem InstEnvs
cls_index FamInstEnvs
fam_index NameEnv ([ClsInst], [FamInst])
index ExportInfo
expInfo Name -> Maybe (MDoc Name)
getInstDoc Name -> Maybe Fixity
getFixity Name -> Maybe RealSrcSpan
getInstLocIface ExportItem GhcRn
export =
  case ExportItem GhcRn -> ExportItem GhcRn
attachFixities ExportItem GhcRn
export of
    ExportDecl e :: XExportDecl GhcRn
e@(ExportD{expDDecl :: forall name. ExportD name -> LHsDecl name
expDDecl = L SrcSpanAnnA
eSpan (TyClD XTyClD GhcRn
_ TyClDecl GhcRn
d)}) -> do
      insts <-
        let nm :: IdP GhcRn
nm = TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
d
            ([ClsInst]
cls_instances, [FamInst]
fam_instances) = case TyClDecl GhcRn
d of
              -- For type classes we can be more efficient by looking up the class in the inst map
              ClassDecl{} -> (InstEnvs -> Name -> [ClsInst]
classNameInstances InstEnvs
cls_index IdP GhcRn
Name
nm, FamInstEnvs -> Name -> [FamInst]
familyNameInstances FamInstEnvs
fam_index IdP GhcRn
Name
nm)
              -- Otherwise, we have to filter through all the instances to see if they mention this
              -- name. See GHCi :info implementation
              TyClDecl GhcRn
_ -> ([ClsInst], [FamInst])
-> Maybe ([ClsInst], [FamInst]) -> ([ClsInst], [FamInst])
forall a. a -> Maybe a -> a
fromMaybe ([], []) (Maybe ([ClsInst], [FamInst]) -> ([ClsInst], [FamInst]))
-> Maybe ([ClsInst], [FamInst]) -> ([ClsInst], [FamInst])
forall a b. (a -> b) -> a -> b
$ NameEnv ([ClsInst], [FamInst])
-> Name -> Maybe ([ClsInst], [FamInst])
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv ([ClsInst], [FamInst])
index IdP GhcRn
Name
nm

            fam_insts :: [(Either String (InstHead GhcRn), Maybe (MDoc Name),
  GenLocated SrcSpan (Either String Name), Maybe Module)]
fam_insts =
              [ ( Either String (InstHead GhcRn)
synFamInst
                , Name -> Maybe (MDoc Name)
getInstDoc Name
n
                , Name
-> Either String (InstHead GhcRn)
-> Located Name
-> GenLocated SrcSpan (Either String Name)
spanNameE Name
n Either String (InstHead GhcRn)
synFamInst (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
eSpan) (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
d))
                , Maybe Module
mb_mdl
                )
              | FamInst
i <- (FamInst -> FamInst -> Ordering) -> [FamInst] -> [FamInst]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy ((FamInst -> ([Int], SName, [SimpleType], Int, SimpleType))
-> FamInst -> FamInst -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing FamInst -> ([Int], SName, [SimpleType], Int, SimpleType)
instFam) [FamInst]
fam_instances
              , let n :: Name
n = FamInst -> Name
forall a. NamedThing a => a -> Name
getName FamInst
i
              , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ExportInfo -> Name -> Bool
isNameHidden ExportInfo
expInfo (FamInst -> Name
fi_fam FamInst
i)
              , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PredType -> Bool) -> [PredType] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (ExportInfo -> PredType -> Bool
isTypeHidden ExportInfo
expInfo) (FamInst -> [PredType]
fi_tys FamInst
i)
              , let opaque :: Bool
opaque = ExportInfo -> PredType -> Bool
isTypeHidden ExportInfo
expInfo (FamInst -> PredType
fi_rhs FamInst
i)
                    synFamInst :: Either String (InstHead GhcRn)
synFamInst = FamInst -> Bool -> Either String (InstHead GhcRn)
synifyFamInst FamInst
i Bool
opaque
                    !mb_mdl :: Maybe Module
mb_mdl = Maybe Module -> Maybe Module
forall a. NFData a => a -> a
force (Maybe Module -> Maybe Module) -> Maybe Module -> Maybe Module
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
nameModule_maybe Name
n
              ]
            cls_insts :: [(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)]
cls_insts =
              [ ( InstHead GhcRn
synClsInst
                , Name -> Maybe (MDoc Name)
getInstDoc Name
n
                , Name -> InstHead GhcRn -> Located Name -> Located Name
spanName Name
n InstHead GhcRn
synClsInst (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
eSpan) (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
d))
                , Maybe Module
mb_mdl
                )
              | let is :: [(([TyVar], [PredType], Class, [PredType]), Name)]
is = [(ClsInst -> ([TyVar], [PredType], Class, [PredType])
instanceSig ClsInst
i, ClsInst -> Name
forall a. NamedThing a => a -> Name
getName ClsInst
i) | ClsInst
i <- [ClsInst]
cls_instances]
              , (i :: ([TyVar], [PredType], Class, [PredType])
i@([TyVar]
_, [PredType]
_, Class
cls, [PredType]
tys), Name
n) <- ((([TyVar], [PredType], Class, [PredType]), Name)
 -> (([TyVar], [PredType], Class, [PredType]), Name) -> Ordering)
-> [(([TyVar], [PredType], Class, [PredType]), Name)]
-> [(([TyVar], [PredType], Class, [PredType]), Name)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (((([TyVar], [PredType], Class, [PredType]), Name)
 -> (([Int], SName, [SimpleType]), Name))
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((([TyVar], [PredType], Class, [PredType]), Name)
  -> (([Int], SName, [SimpleType]), Name))
 -> (([TyVar], [PredType], Class, [PredType]), Name)
 -> (([TyVar], [PredType], Class, [PredType]), Name)
 -> Ordering)
-> ((([TyVar], [PredType], Class, [PredType]), Name)
    -> (([Int], SName, [SimpleType]), Name))
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> Ordering
forall a b. (a -> b) -> a -> b
$ (([TyVar], [PredType], Class, [PredType])
 -> ([Int], SName, [SimpleType]))
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> (([Int], SName, [SimpleType]), Name)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([TyVar], [PredType], Class, [PredType])
-> ([Int], SName, [SimpleType])
instHead) [(([TyVar], [PredType], Class, [PredType]), Name)]
is
              , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ExportInfo -> Name -> [PredType] -> Bool
isInstanceHidden ExportInfo
expInfo (Class -> Name
forall a. NamedThing a => a -> Name
getName Class
cls) [PredType]
tys
              , let synClsInst :: InstHead GhcRn
synClsInst = ([TyVar], [PredType], Class, [PredType])
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
-> InstHead GhcRn
synifyInstHead ([TyVar], [PredType], Class, [PredType])
i [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
famInsts
                    famInsts :: [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
famInsts = ExportInfo
-> FamInstEnvs
-> (Name -> Maybe (MDoc Name))
-> Class
-> [PredType]
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
getFamInsts ExportInfo
expInfo FamInstEnvs
fam_index Name -> Maybe (MDoc Name)
getInstDoc Class
cls [PredType]
tys
                    !mb_mdl :: Maybe Module
mb_mdl = Maybe Module -> Maybe Module
forall a. NFData a => a -> a
force (Maybe Module -> Maybe Module) -> Maybe Module -> Maybe Module
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
nameModule_maybe Name
n
              ]
            -- fam_insts but with failing type fams filtered out
            cleanFamInsts :: [(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)]
cleanFamInsts = [(InstHead GhcRn
fi, Maybe (MDoc Name)
n, SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l Name
r, Maybe Module
m) | (Right InstHead GhcRn
fi, Maybe (MDoc Name)
n, L SrcSpan
l (Right Name
r), Maybe Module
m) <- [(Either String (InstHead GhcRn), Maybe (MDoc Name),
  GenLocated SrcSpan (Either String Name), Maybe Module)]
fam_insts]
            famInstErrs :: [String]
famInstErrs = [String
errm | (Left String
errm, Maybe (MDoc Name)
_, GenLocated SrcSpan (Either String Name)
_, Maybe Module
_) <- [(Either String (InstHead GhcRn), Maybe (MDoc Name),
  GenLocated SrcSpan (Either String Name), Maybe Module)]
fam_insts]
         in do
              let mkBug :: String -> SDoc
mkBug = (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"haddock-bug:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>) (SDoc -> SDoc) -> (String -> SDoc) -> String -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
forall doc. IsLine doc => String -> doc
text
              SDoc -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => SDoc -> m ()
putMsgM ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
mkBug [String]
famInstErrs)
              [(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)]
-> Ghc
     [(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)]
 -> Ghc
      [(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)])
-> [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
     Maybe Module)]
-> Ghc
     [(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)]
forall a b. (a -> b) -> a -> b
$ [(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)]
cls_insts [(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)]
-> [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
     Maybe Module)]
-> [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
     Maybe Module)]
forall a. [a] -> [a] -> [a]
++ [(InstHead GhcRn, Maybe (MDoc Name), Located Name, Maybe Module)]
cleanFamInsts
      return $ ExportDecl e{expDInstances = insts}
    ExportItem GhcRn
e -> ExportItem GhcRn -> Ghc (ExportItem GhcRn)
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ExportItem GhcRn
e
  where
    attachFixities :: ExportItem GhcRn -> ExportItem GhcRn
attachFixities
      ( ExportDecl
          ( e :: XExportDecl GhcRn
e@ExportD
              { expDDecl :: forall name. ExportD name -> LHsDecl name
expDDecl = L SrcSpanAnnA
_ HsDecl GhcRn
d
              , expDPats :: forall name. ExportD name -> [(HsDecl name, DocForDecl (IdP name))]
expDPats = [(HsDecl GhcRn, DocForDecl (IdP GhcRn))]
patsyns
              , expDSubDocs :: forall name. ExportD name -> [(IdP name, DocForDecl (IdP name))]
expDSubDocs = [(IdP GhcRn, DocForDecl (IdP GhcRn))]
subDocs
              }
            )
        ) =
        XExportDecl GhcRn -> ExportItem GhcRn
forall name. XExportDecl name -> ExportItem name
ExportDecl
          XExportDecl GhcRn
e
            { expDFixities = fixities
            }
        where
          fixities :: [(Name, Fixity)]
          !fixities :: [(Name, Fixity)]
fixities = [(Name, Fixity)] -> [(Name, Fixity)]
forall a. NFData a => a -> a
force ([(Name, Fixity)] -> [(Name, Fixity)])
-> (Map Name Fixity -> [(Name, Fixity)])
-> Map Name Fixity
-> [(Name, Fixity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name Fixity -> [(Name, Fixity)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Name Fixity -> [(Name, Fixity)])
-> Map Name Fixity -> [(Name, Fixity)]
forall a b. (a -> b) -> a -> b
$ (Map Name Fixity -> Name -> Map Name Fixity)
-> Map Name Fixity -> [Name] -> Map Name Fixity
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map Name Fixity -> Name -> Map Name Fixity
f Map Name Fixity
forall k a. Map k a
Map.empty [Name]
all_names

          f :: Map.Map Name Fixity -> Name -> Map.Map Name Fixity
          f :: Map Name Fixity -> Name -> Map Name Fixity
f !Map Name Fixity
fs Name
n = (Maybe Fixity -> Maybe Fixity)
-> Name -> Map Name Fixity -> Map Name Fixity
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Maybe Fixity -> Maybe Fixity -> Maybe Fixity
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> Name -> Maybe Fixity
getFixity Name
n) Name
n Map Name Fixity
fs

          patsyn_names :: [Name]
          patsyn_names :: [Name]
patsyn_names = ((HsDecl GhcRn, DocForDecl Name) -> [Name])
-> [(HsDecl GhcRn, DocForDecl Name)] -> [Name]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (OccEnv Name -> HsDecl GhcRn -> [Name]
getMainDeclBinder OccEnv Name
forall a. OccEnv a
emptyOccEnv (HsDecl GhcRn -> [Name])
-> ((HsDecl GhcRn, DocForDecl Name) -> HsDecl GhcRn)
-> (HsDecl GhcRn, DocForDecl Name)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsDecl GhcRn, DocForDecl Name) -> HsDecl GhcRn
forall a b. (a, b) -> a
fst) [(HsDecl GhcRn, DocForDecl (IdP GhcRn))]
[(HsDecl GhcRn, DocForDecl Name)]
patsyns

          all_names :: [Name]
          all_names :: [Name]
all_names =
            OccEnv Name -> HsDecl GhcRn -> [Name]
getMainDeclBinder OccEnv Name
forall a. OccEnv a
emptyOccEnv HsDecl GhcRn
d
              [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ ((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 [(IdP GhcRn, DocForDecl (IdP GhcRn))]
[(Name, DocForDecl Name)]
subDocs
              [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
patsyn_names
    attachFixities ExportItem GhcRn
e = ExportItem GhcRn
e

    -- spanName: attach the location to the name that is the same file as the instance location
    spanName :: Name -> InstHead GhcRn -> Located Name -> Located Name
spanName Name
s (InstHead{ihdClsName :: forall name. InstHead name -> IdP name
ihdClsName = IdP GhcRn
clsn}) (L SrcSpan
instL Name
instn) =
      let s1 :: SrcSpan
s1 = let orig_span :: SrcSpan
orig_span = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
s
               in if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
orig_span
                  then SrcSpan
orig_span
                  else case Name -> Maybe RealSrcSpan
getInstLocIface Name
s of
                         Maybe RealSrcSpan
Nothing -> SrcSpan
orig_span
                         Just RealSrcSpan
rs -> RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
rs Maybe BufSpan
forall a. Monoid a => a
mempty
          sn :: Name
sn =
            if SrcSpan -> Maybe FastString
srcSpanFileName_maybe SrcSpan
s1 Maybe FastString -> Maybe FastString -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan -> Maybe FastString
srcSpanFileName_maybe SrcSpan
instL
              then Name
instn
              else IdP GhcRn
Name
clsn
       in SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
s1 Name
sn
    -- spanName on Either
    spanNameE :: Name
-> Either String (InstHead GhcRn)
-> Located Name
-> GenLocated SrcSpan (Either String Name)
spanNameE Name
s (Left String
e) Located Name
_ = SrcSpan
-> Either String Name -> GenLocated SrcSpan (Either String Name)
forall l e. l -> e -> GenLocated l e
L (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
s) (String -> Either String Name
forall a b. a -> Either a b
Left String
e)
    spanNameE Name
s (Right InstHead GhcRn
ok) Located Name
linst =
      let L SrcSpan
l Name
r = Name -> InstHead GhcRn -> Located Name -> Located Name
spanName Name
s InstHead GhcRn
ok Located Name
linst
       in SrcSpan
-> Either String Name -> GenLocated SrcSpan (Either String Name)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Name -> Either String Name
forall a b. b -> Either a b
Right Name
r)

substAgrees :: [(TyVar, Type)] -> [(TyVar, Type)] -> Bool
substAgrees :: [(TyVar, PredType)] -> [(TyVar, PredType)] -> Bool
substAgrees [(TyVar, PredType)]
xs [(TyVar, PredType)]
ys = [(TyVar, PredType)] -> Bool
go [(TyVar, PredType)]
xs
  where
    go :: [(TyVar, PredType)] -> Bool
go [] = Bool
True
    go ((TyVar
v, PredType
t1) : [(TyVar, PredType)]
zs) = case TyVar -> [(TyVar, PredType)] -> Maybe PredType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TyVar
v [(TyVar, PredType)]
ys of
      Maybe PredType
Nothing -> [(TyVar, PredType)] -> Bool
go [(TyVar, PredType)]
zs
      Just PredType
t2 -> HasCallStack => PredType -> PredType -> Bool
PredType -> PredType -> Bool
eqType PredType
t1 PredType
t2 Bool -> Bool -> Bool
&& [(TyVar, PredType)] -> Bool
go [(TyVar, PredType)]
zs

getFamInsts
  :: ExportInfo
  -> FamInstEnvs
  -- ^ all the family instances (that we know of)
  -> (Name -> Maybe (MDoc Name))
  -- ^ how to lookup the doc of an instance
  -> Class
  -> [Type]
  -> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
getFamInsts :: ExportInfo
-> FamInstEnvs
-> (Name -> Maybe (MDoc Name))
-> Class
-> [PredType]
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
getFamInsts ExportInfo
expInfo FamInstEnvs
fam_index Name -> Maybe (MDoc Name)
getInstDoc Class
cls [PredType]
tys =
  [ (FamInst
f_i, Bool
opaque, Name -> Maybe (MDoc Name)
getInstDoc Name
f_n, SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
f_n) Name
f_n, Name -> Maybe Module
nameModule_maybe Name
f_n)
  | TyCon
fam <- Class -> [TyCon]
classATs Class
cls
  , let vars :: [TyVar]
vars = TyCon -> [TyVar]
tyConTyVars TyCon
fam
        tv_env :: [(TyVar, PredType)]
tv_env = [TyVar] -> [PredType] -> [(TyVar, PredType)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Class -> [TyVar]
classTyVars Class
cls) [PredType]
tys
        m_instantiation :: Maybe [PredType]
m_instantiation = (TyVar -> Maybe PredType) -> [TyVar] -> Maybe [PredType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (\TyVar
v -> TyVar -> [(TyVar, PredType)] -> Maybe PredType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TyVar
v [(TyVar, PredType)]
tv_env) [TyVar]
vars
  , FamInst
f_i <- case Maybe [PredType]
m_instantiation of
      -- If we have a complete instantation, we can just lookup in the family environment
      Just [PredType]
instantiation -> (FamInstMatch -> FamInst) -> [FamInstMatch] -> [FamInst]
forall a b. (a -> b) -> [a] -> [b]
map FamInstMatch -> FamInst
fim_instance ([FamInstMatch] -> [FamInst]) -> [FamInstMatch] -> [FamInst]
forall a b. (a -> b) -> a -> b
$ FamInstEnvs -> TyCon -> [PredType] -> [FamInstMatch]
lookupFamInstEnv FamInstEnvs
fam_index TyCon
fam [PredType]
instantiation
      -- If we don't have a complete instantation, we need to look over all possible instances
      -- for the family and filter out the ones that don't agree with the typeclass instance
      Maybe [PredType]
Nothing ->
        [ FamInst
f_i
        | FamInst
f_i <- FamInstEnvs -> TyCon -> [FamInst]
familyInstances FamInstEnvs
fam_index TyCon
fam
        , let co_tvs :: [TyVar]
co_tvs = TyCon -> [TyVar]
tyConTyVars TyCon
fam
              ([TyVar]
_, [PredType]
lhs, PredType
_) = CoAxBranch -> ([TyVar], [PredType], PredType)
etaExpandCoAxBranch (CoAxBranch -> ([TyVar], [PredType], PredType))
-> CoAxBranch -> ([TyVar], [PredType], PredType)
forall a b. (a -> b) -> a -> b
$ CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch (CoAxiom Unbranched -> CoAxBranch)
-> CoAxiom Unbranched -> CoAxBranch
forall a b. (a -> b) -> a -> b
$ FamInst -> CoAxiom Unbranched
fi_axiom FamInst
f_i
        , [(TyVar, PredType)] -> [(TyVar, PredType)] -> Bool
substAgrees ([TyVar] -> [PredType] -> [(TyVar, PredType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar]
co_tvs [PredType]
lhs) [(TyVar, PredType)]
tv_env
        ]
  , let ax :: CoAxiom Unbranched
ax = FamInst -> CoAxiom Unbranched
fi_axiom FamInst
f_i
        f_n :: Name
f_n = CoAxiom Unbranched -> Name
forall (br :: BranchFlag). CoAxiom br -> Name
co_ax_name CoAxiom Unbranched
ax
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ExportInfo -> Name -> Bool
isNameHidden ExportInfo
expInfo (FamInst -> Name
fi_fam FamInst
f_i)
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PredType -> Bool) -> [PredType] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (ExportInfo -> PredType -> Bool
isTypeHidden ExportInfo
expInfo) (FamInst -> [PredType]
fi_tys FamInst
f_i)
  , let opaque :: Bool
opaque = ExportInfo -> PredType -> Bool
isTypeHidden ExportInfo
expInfo (FamInst -> PredType
fi_rhs FamInst
f_i)
  ]

-- | Lookup the doc associated with a certain instance
findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name)
findInstDoc :: Interface
-> Map Module Interface
-> InstIfaceMap
-> Name
-> Maybe (MDoc Name)
findInstDoc Interface
iface Map Module Interface
ifaceMap InstIfaceMap
instIfaceMap = \Name
name ->
  (Name -> Map Name (MDoc Name) -> Maybe (MDoc Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (Map Name (MDoc Name) -> Maybe (MDoc Name))
-> (Interface -> Map Name (MDoc Name))
-> Interface
-> Maybe (MDoc Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Map Name (MDoc Name)
ifaceDocMap (Interface -> Maybe (MDoc Name)) -> Interface -> Maybe (MDoc Name)
forall a b. (a -> b) -> a -> b
$ Interface
iface)
    Maybe (MDoc Name) -> Maybe (MDoc Name) -> Maybe (MDoc Name)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (Name -> Map Name (MDoc Name) -> Maybe (MDoc Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (Map Name (MDoc Name) -> Maybe (MDoc Name))
-> (Interface -> Map Name (MDoc Name))
-> Interface
-> Maybe (MDoc Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Map Name (MDoc Name)
ifaceDocMap (Interface -> Maybe (MDoc Name))
-> Maybe Interface -> Maybe (MDoc Name)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> Map Module Interface -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name) Map Module Interface
ifaceMap)
    Maybe (MDoc Name) -> Maybe (MDoc Name) -> Maybe (MDoc Name)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (Name -> Map Name (MDoc Name) -> Maybe (MDoc Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (Map Name (MDoc Name) -> Maybe (MDoc Name))
-> (InstalledInterface -> Map Name (MDoc Name))
-> InstalledInterface
-> Maybe (MDoc Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledInterface -> Map Name (MDoc Name)
instDocMap (InstalledInterface -> Maybe (MDoc Name))
-> Maybe InstalledInterface -> Maybe (MDoc Name)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> InstIfaceMap -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name) InstIfaceMap
instIfaceMap)

-- | Lookup the fixity associated with a certain name
findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity
findFixity :: Interface
-> Map Module Interface -> InstIfaceMap -> Name -> Maybe Fixity
findFixity Interface
iface Map Module Interface
ifaceMap InstIfaceMap
instIfaceMap = \Name
name ->
  (Name -> Map Name Fixity -> Maybe Fixity
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (Map Name Fixity -> Maybe Fixity)
-> (Interface -> Map Name Fixity) -> Interface -> Maybe Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Map Name Fixity
ifaceFixMap (Interface -> Maybe Fixity) -> Interface -> Maybe Fixity
forall a b. (a -> b) -> a -> b
$ Interface
iface)
    Maybe Fixity -> Maybe Fixity -> Maybe Fixity
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (Name -> Map Name Fixity -> Maybe Fixity
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (Map Name Fixity -> Maybe Fixity)
-> (Interface -> Map Name Fixity) -> Interface -> Maybe Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Map Name Fixity
ifaceFixMap (Interface -> Maybe Fixity) -> Maybe Interface -> Maybe Fixity
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> Map Module Interface -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name) Map Module Interface
ifaceMap)
    Maybe Fixity -> Maybe Fixity -> Maybe Fixity
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (Name -> Map Name Fixity -> Maybe Fixity
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (Map Name Fixity -> Maybe Fixity)
-> (InstalledInterface -> Map Name Fixity)
-> InstalledInterface
-> Maybe Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledInterface -> Map Name Fixity
instFixMap (InstalledInterface -> Maybe Fixity)
-> Maybe InstalledInterface -> Maybe Fixity
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> InstIfaceMap -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name) InstIfaceMap
instIfaceMap)

--------------------------------------------------------------------------------
-- Collecting and sorting instances
--------------------------------------------------------------------------------

instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], SName, [SimpleType])
instHead :: ([TyVar], [PredType], Class, [PredType])
-> ([Int], SName, [SimpleType])
instHead ([TyVar]
_, [PredType]
_, Class
cls, [PredType]
args) =
  ((PredType -> Int) -> [PredType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PredType -> Int
argCount [PredType]
args, Name -> SName
SName (Class -> Name
className Class
cls), (PredType -> SimpleType) -> [PredType] -> [SimpleType]
forall a b. (a -> b) -> [a] -> [b]
map PredType -> SimpleType
simplify [PredType]
args)

argCount :: Type -> Int
argCount :: PredType -> Int
argCount (AppTy PredType
t PredType
_) = PredType -> Int
argCount PredType
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
argCount (TyConApp TyCon
_ [PredType]
ts) = [PredType] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [PredType]
ts
argCount (FunTy FunTyFlag
_ PredType
_ PredType
_ PredType
_) = Int
2
argCount (ForAllTy ForAllTyBinder
_ PredType
t) = PredType -> Int
argCount PredType
t
argCount (CastTy PredType
t KindCoercion
_) = PredType -> Int
argCount PredType
t
argCount PredType
_ = Int
0

simplify :: Type -> SimpleType
simplify :: PredType -> SimpleType
simplify (FunTy FunTyFlag
_ PredType
_ PredType
t1 PredType
t2) = SName -> [SimpleType] -> SimpleType
SimpleType (Name -> SName
SName Name
unrestrictedFunTyConName) [PredType -> SimpleType
simplify PredType
t1, PredType -> SimpleType
simplify PredType
t2]
simplify (ForAllTy ForAllTyBinder
_ PredType
t) = PredType -> SimpleType
simplify PredType
t
simplify (AppTy PredType
t1 PredType
t2) = SName -> [SimpleType] -> SimpleType
SimpleType SName
s ([SimpleType]
ts [SimpleType] -> [SimpleType] -> [SimpleType]
forall a. [a] -> [a] -> [a]
++ Maybe SimpleType -> [SimpleType]
forall a. Maybe a -> [a]
maybeToList (PredType -> Maybe SimpleType
simplify_maybe PredType
t2))
  where
    (SimpleType SName
s [SimpleType]
ts) = PredType -> SimpleType
simplify PredType
t1
simplify (TyVarTy TyVar
v) = SName -> [SimpleType] -> SimpleType
SimpleType (Name -> SName
SName (TyVar -> Name
tyVarName TyVar
v)) []
simplify (TyConApp TyCon
tc [PredType]
ts) =
  SName -> [SimpleType] -> SimpleType
SimpleType
    (Name -> SName
SName (TyCon -> Name
tyConName TyCon
tc))
    ((PredType -> Maybe SimpleType) -> [PredType] -> [SimpleType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PredType -> Maybe SimpleType
simplify_maybe [PredType]
ts)
simplify (LitTy (NumTyLit Integer
n)) = Integer -> SimpleType
SimpleIntTyLit Integer
n
simplify (LitTy (StrTyLit FastString
s)) = String -> SimpleType
SimpleStringTyLit (FastString -> String
unpackFS FastString
s)
simplify (LitTy (CharTyLit Char
c)) = Char -> SimpleType
SimpleCharTyLit Char
c
simplify (CastTy PredType
ty KindCoercion
_) = PredType -> SimpleType
simplify PredType
ty
simplify (CoercionTy KindCoercion
_) = String -> SimpleType
forall a. HasCallStack => String -> a
error String
"simplify:Coercion"

simplify_maybe :: Type -> Maybe SimpleType
simplify_maybe :: PredType -> Maybe SimpleType
simplify_maybe (CoercionTy{}) = Maybe SimpleType
forall a. Maybe a
Nothing
simplify_maybe PredType
ty = SimpleType -> Maybe SimpleType
forall a. a -> Maybe a
Just (PredType -> SimpleType
simplify PredType
ty)

-- Used for sorting
instFam :: FamInst -> ([Int], SName, [SimpleType], Int, SimpleType)
instFam :: FamInst -> ([Int], SName, [SimpleType], Int, SimpleType)
instFam FamInst{fi_fam :: FamInst -> Name
fi_fam = Name
n, fi_tys :: FamInst -> [PredType]
fi_tys = [PredType]
ts, fi_rhs :: FamInst -> PredType
fi_rhs = PredType
t} =
  ((PredType -> Int) -> [PredType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PredType -> Int
argCount [PredType]
ts, Name -> SName
SName Name
n, (PredType -> SimpleType) -> [PredType] -> [SimpleType]
forall a b. (a -> b) -> [a] -> [b]
map PredType -> SimpleType
simplify [PredType]
ts, PredType -> Int
argCount PredType
t, PredType -> SimpleType
simplify PredType
t)

--------------------------------------------------------------------------------
-- Filtering hidden instances
--------------------------------------------------------------------------------

-- | A class or data type is hidden iff
--
-- * it is defined in one of the modules that are being processed
--
-- * and it is not exported by any non-hidden module
isNameHidden :: ExportInfo -> Name -> Bool
isNameHidden :: ExportInfo -> Name -> Bool
isNameHidden (ExportedNames
names, Modules
modules) Name
name =
  HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name Module -> Modules -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Modules
modules
    Bool -> Bool -> Bool
&& Bool -> Bool
not (Name
name Name -> ExportedNames -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ExportedNames
names)

-- | We say that an instance is «hidden» iff its class or any (part)
-- of its type(s) is hidden.
isInstanceHidden :: ExportInfo -> Name -> [Type] -> Bool
isInstanceHidden :: ExportInfo -> Name -> [PredType] -> Bool
isInstanceHidden ExportInfo
expInfo Name
cls [PredType]
tyNames =
  Bool
instClassHidden Bool -> Bool -> Bool
|| Bool
instTypeHidden
  where
    instClassHidden :: Bool
    instClassHidden :: Bool
instClassHidden = ExportInfo -> Name -> Bool
isNameHidden ExportInfo
expInfo Name
cls

    instTypeHidden :: Bool
    instTypeHidden :: Bool
instTypeHidden = (PredType -> Bool) -> [PredType] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (ExportInfo -> PredType -> Bool
isTypeHidden ExportInfo
expInfo) [PredType]
tyNames

isTypeHidden :: ExportInfo -> Type -> Bool
isTypeHidden :: ExportInfo -> PredType -> Bool
isTypeHidden ExportInfo
expInfo = PredType -> Bool
typeHidden
  where
    typeHidden :: Type -> Bool
    typeHidden :: PredType -> Bool
typeHidden PredType
t = (Name -> Bool) -> ExportedNames -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any Name -> Bool
nameHidden (ExportedNames -> Bool) -> ExportedNames -> Bool
forall a b. (a -> b) -> a -> b
$ PredType -> ExportedNames
typeNames PredType
t

    nameHidden :: Name -> Bool
    nameHidden :: Name -> Bool
nameHidden = ExportInfo -> Name -> Bool
isNameHidden ExportInfo
expInfo