{-# 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 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 (isNameHidden, isTypeHidden)
import Haddock.Types

-- 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
$ HasCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_homeUnitState (UnitEnv -> UnitState) -> UnitEnv -> UnitState
forall a b. (a -> b) -> a -> b
$ HscEnv -> UnitEnv
hsc_unit_env HscEnv
env
      mods =
        [GenModule Unit] -> ModuleSet
mkModuleSet
          [ GenModule Unit
m
          | UniqMap (GenModule Unit) ModuleOrigin
mod_map <- ModuleNameProvidersMap -> [UniqMap (GenModule Unit) ModuleOrigin]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap ModuleNameProvidersMap
mod_to_pkg_conf
          , ( GenModule Unit
m
              , ModOrigin
                  { fromOrigUnit :: ModuleOrigin -> Maybe Bool
fromOrigUnit = Maybe Bool
fromOrig
                  , fromExposedReexport :: ModuleOrigin -> [UnitInfo]
fromExposedReexport = [UnitInfo]
reExp
                  }
              ) <-
              UniqMap (GenModule Unit) ModuleOrigin
-> [(GenModule Unit, ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap (GenModule Unit) 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 -> [GenModule Unit]
moduleSetElts ModuleSet
mods
      -- We need to ensure orphans in modules outside of this package are included.
      -- See https://gitlab.haskell.org/ghc/ghc/-/issues/25147
      -- and https://gitlab.haskell.org/ghc/ghc/-/issues/26079
      mods_visible = [GenModule Unit] -> ModuleSet
mkModuleSet ([GenModule Unit] -> ModuleSet) -> [GenModule Unit] -> ModuleSet
forall a b. (a -> b) -> a -> b
$ (Interface -> [GenModule Unit]) -> [Interface] -> [GenModule Unit]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ((GenModule Unit -> [GenModule Unit] -> [GenModule Unit])
-> (Interface -> GenModule Unit)
-> (Interface -> [GenModule Unit])
-> Interface
-> [GenModule Unit]
forall a b c.
(a -> b -> c)
-> (Interface -> a) -> (Interface -> b) -> Interface -> c
forall (f :: Type -> Type) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) Interface -> GenModule Unit
ifaceMod Interface -> [GenModule Unit]
ifaceOrphanDeps) [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]))]
-> UniqFM Name ([ClsInst], [FamInst])
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, ([ClsInst], [FamInst]))]
 -> UniqFM Name ([ClsInst], [FamInst]))
-> [(Name, ([ClsInst], [FamInst]))]
-> UniqFM Name ([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, (FamInstEnv, FamInstEnv)
emptyFamInstEnvs, UniqFM Name ([ClsInst], [FamInst])
forall a. NameEnv a
emptyNameEnv)
  mapM (attach $ fromMaybe empty_index mb_index) ifaces
  where
    -- TODO: take an IfaceMap as input
    ifaceMap :: Map (GenModule Unit) Interface
ifaceMap = [(GenModule Unit, Interface)] -> Map (GenModule Unit) Interface
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Interface -> GenModule Unit
ifaceMod Interface
i, Interface
i) | Interface
i <- [Interface]
ifaces]

    attach :: (InstEnvs, (FamInstEnv, FamInstEnv),
 UniqFM Name ([ClsInst], [FamInst]))
-> Interface -> Ghc Interface
attach (InstEnvs
cls_insts, (FamInstEnv, FamInstEnv)
fam_insts, UniqFM Name ([ClsInst], [FamInst])
inst_map) Interface
iface = do
      let getInstDoc :: Name -> Maybe (MDoc Name)
getInstDoc = Interface
-> Map (GenModule Unit) Interface
-> InstIfaceMap
-> Name
-> Maybe (MDoc Name)
findInstDoc Interface
iface Map (GenModule Unit) Interface
ifaceMap InstIfaceMap
instIfaceMap
          getFixity :: Name -> Maybe Fixity
getFixity = Interface
-> Map (GenModule Unit) Interface
-> InstIfaceMap
-> Name
-> Maybe Fixity
findFixity Interface
iface Map (GenModule Unit) 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
=<< GenModule Unit -> InstIfaceMap -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasCallStack => Name -> GenModule Unit
Name -> GenModule Unit
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
-> (FamInstEnv, FamInstEnv)
-> UniqFM Name ([ClsInst], [FamInst])
-> ExportInfo
-> (Name -> Maybe (MDoc Name))
-> (Name -> Maybe Fixity)
-> (Name -> Maybe RealSrcSpan)
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
attachToExportItem InstEnvs
cls_insts (FamInstEnv, FamInstEnv)
fam_insts UniqFM Name ([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]
-> (FamInstEnv, FamInstEnv)
-> [DocInstance GhcRn]
attachOrphanInstances ExportInfo
expInfo Name -> Maybe (MDoc Name)
getInstDoc (Interface -> [ClsInst]
ifaceInstances Interface
iface) (FamInstEnv, FamInstEnv)
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]
-> (FamInstEnv, FamInstEnv)
-> [DocInstance GhcRn]
attachOrphanInstances ExportInfo
expInfo Name -> Maybe (MDoc Name)
getInstDoc [ClsInst]
cls_instances (FamInstEnv, FamInstEnv)
fam_index =
  [ (([TyVar], [PredType], Class, [PredType])
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name,
     Maybe (GenModule Unit))]
-> InstHead GhcRn
synifyInstHead ([TyVar], [PredType], Class, [PredType])
i [(FamInst, Bool, Maybe (MDoc Name), Located Name,
  Maybe (GenModule Unit))]
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 (GenModule Unit)
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 (GenModule Unit))]
famInsts = ExportInfo
-> (FamInstEnv, FamInstEnv)
-> (Name -> Maybe (MDoc Name))
-> Class
-> [PredType]
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name,
     Maybe (GenModule Unit))]
getFamInsts ExportInfo
expInfo (FamInstEnv, FamInstEnv)
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
-> (FamInstEnv, FamInstEnv)
-> UniqFM Name ([ClsInst], [FamInst])
-> ExportInfo
-> (Name -> Maybe (MDoc Name))
-> (Name -> Maybe Fixity)
-> (Name -> Maybe RealSrcSpan)
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
attachToExportItem InstEnvs
cls_index (FamInstEnv, FamInstEnv)
fam_index UniqFM Name ([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, (FamInstEnv, FamInstEnv) -> Name -> [FamInst]
familyNameInstances (FamInstEnv, FamInstEnv)
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
$ UniqFM Name ([ClsInst], [FamInst])
-> Name -> Maybe ([ClsInst], [FamInst])
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv UniqFM Name ([ClsInst], [FamInst])
index IdP GhcRn
Name
nm

            fam_insts :: [(Either String (InstHead GhcRn), Maybe (MDoc Name),
  GenLocated SrcSpan (Either String Name), Maybe (GenModule Unit))]
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 (GenModule Unit)
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 (GenModule Unit)
mb_mdl = Maybe (GenModule Unit) -> Maybe (GenModule Unit)
forall a. NFData a => a -> a
force (Maybe (GenModule Unit) -> Maybe (GenModule Unit))
-> Maybe (GenModule Unit) -> Maybe (GenModule Unit)
forall a b. (a -> b) -> a -> b
$ Name -> Maybe (GenModule Unit)
nameModule_maybe Name
n
              ]
            cls_insts :: [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
  Maybe (GenModule Unit))]
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 (GenModule Unit)
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 (GenModule Unit))]
-> InstHead GhcRn
synifyInstHead ([TyVar], [PredType], Class, [PredType])
i [(FamInst, Bool, Maybe (MDoc Name), Located Name,
  Maybe (GenModule Unit))]
famInsts
                    famInsts :: [(FamInst, Bool, Maybe (MDoc Name), Located Name,
  Maybe (GenModule Unit))]
famInsts = ExportInfo
-> (FamInstEnv, FamInstEnv)
-> (Name -> Maybe (MDoc Name))
-> Class
-> [PredType]
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name,
     Maybe (GenModule Unit))]
getFamInsts ExportInfo
expInfo (FamInstEnv, FamInstEnv)
fam_index Name -> Maybe (MDoc Name)
getInstDoc Class
cls [PredType]
tys
                    !mb_mdl :: Maybe (GenModule Unit)
mb_mdl = Maybe (GenModule Unit) -> Maybe (GenModule Unit)
forall a. NFData a => a -> a
force (Maybe (GenModule Unit) -> Maybe (GenModule Unit))
-> Maybe (GenModule Unit) -> Maybe (GenModule Unit)
forall a b. (a -> b) -> a -> b
$ Name -> Maybe (GenModule Unit)
nameModule_maybe Name
n
              ]
            -- fam_insts but with failing type fams filtered out
            cleanFamInsts :: [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
  Maybe (GenModule Unit))]
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 (GenModule Unit)
m) | (Right InstHead GhcRn
fi, Maybe (MDoc Name)
n, L SrcSpan
l (Right Name
r), Maybe (GenModule Unit)
m) <- [(Either String (InstHead GhcRn), Maybe (MDoc Name),
  GenLocated SrcSpan (Either String Name), Maybe (GenModule Unit))]
fam_insts]
            famInstErrs :: [String]
famInstErrs = [String
errm | (Left String
errm, Maybe (MDoc Name)
_, GenLocated SrcSpan (Either String Name)
_, Maybe (GenModule Unit)
_) <- [(Either String (InstHead GhcRn), Maybe (MDoc Name),
  GenLocated SrcSpan (Either String Name), Maybe (GenModule Unit))]
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 (GenModule Unit))]
-> Ghc
     [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
       Maybe (GenModule Unit))]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(InstHead GhcRn, Maybe (MDoc Name), Located Name,
   Maybe (GenModule Unit))]
 -> Ghc
      [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
        Maybe (GenModule Unit))])
-> [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
     Maybe (GenModule Unit))]
-> Ghc
     [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
       Maybe (GenModule Unit))]
forall a b. (a -> b) -> a -> b
$ [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
  Maybe (GenModule Unit))]
cls_insts [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
  Maybe (GenModule Unit))]
-> [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
     Maybe (GenModule Unit))]
-> [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
     Maybe (GenModule Unit))]
forall a. [a] -> [a] -> [a]
++ [(InstHead GhcRn, Maybe (MDoc Name), Located Name,
  Maybe (GenModule Unit))]
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
-> (FamInstEnv, FamInstEnv)
-> (Name -> Maybe (MDoc Name))
-> Class
-> [PredType]
-> [(FamInst, Bool, Maybe (MDoc Name), Located Name,
     Maybe (GenModule Unit))]
getFamInsts ExportInfo
expInfo (FamInstEnv, FamInstEnv)
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 (GenModule Unit)
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
$ (FamInstEnv, FamInstEnv) -> TyCon -> [PredType] -> [FamInstMatch]
lookupFamInstEnv (FamInstEnv, FamInstEnv)
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 <- (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
familyInstances (FamInstEnv, FamInstEnv)
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 (GenModule Unit) Interface
-> InstIfaceMap
-> Name
-> Maybe (MDoc Name)
findInstDoc Interface
iface Map (GenModule Unit) 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
=<< GenModule Unit -> Map (GenModule Unit) Interface -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasCallStack => Name -> GenModule Unit
Name -> GenModule Unit
nameModule Name
name) Map (GenModule Unit) 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
=<< GenModule Unit -> InstIfaceMap -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasCallStack => Name -> GenModule Unit
Name -> GenModule Unit
nameModule Name
name) InstIfaceMap
instIfaceMap)

-- | Lookup the fixity associated with a certain name
findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity
findFixity :: Interface
-> Map (GenModule Unit) Interface
-> InstIfaceMap
-> Name
-> Maybe Fixity
findFixity Interface
iface Map (GenModule Unit) 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
=<< GenModule Unit -> Map (GenModule Unit) Interface -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasCallStack => Name -> GenModule Unit
Name -> GenModule Unit
nameModule Name
name) Map (GenModule Unit) 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
=<< GenModule Unit -> InstIfaceMap -> Maybe InstalledInterface
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasCallStack => Name -> GenModule Unit
Name -> GenModule Unit
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
--------------------------------------------------------------------------------

-- | 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