{-# LANGUAGE MagicHash       #-}
{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE TypeFamilies    #-}
{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE NamedFieldPuns  #-}

{-# 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 Haddock.Convert
import Haddock.GhcUtils (typeNames)
import Haddock.Types

import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
import Control.DeepSeq (force)
import Data.Foldable (foldl')
import Data.List (sortBy)
import qualified Data.Sequence as Seq
import Data.Ord (comparing)
import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Foldable (toList)

import GHC.Data.FastString (unpackFS)
import GHC.Core.Class
import GHC.Core (isOrphan)
import GHC.Core.FamInstEnv
import GHC
import GHC.Core.InstEnv
import GHC.Unit.Module.Env ( moduleSetElts, mkModuleSet )
import GHC.Unit.State
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.Unique.Map
import GHC.Utils.Outputable (text, sep, (<+>))
import GHC.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Builtin.Types( unrestrictedFunTyConName )
import GHC.Types.Var hiding (varName)
import GHC.HsToCore.Docs
import GHC.Driver.Env.Types
import GHC.Unit.Env
import GHC.Core.Coercion.Axiom
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Instance.Family
import GHC.Iface.Load
import GHC.Core.TyCo.Compare (eqType)
import GHC.Core.Coercion

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

-- Also attaches fixities
attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
attachInstances ExportInfo
expInfo [Interface]
ifaces InstIfaceMap
instIfaceMap = 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 :: * -> *). 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 :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
reExp)
                         ]
      mods_to_load = ModuleSet -> [Module]
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 = [Module] -> ModuleSet
mkModuleSet ([Module] -> ModuleSet) -> [Module] -> ModuleSet
forall a b. (a -> b) -> a -> b
$ (Interface -> [Module]) -> [Interface] -> [Module]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Module -> [Module] -> [Module])
-> (Interface -> Module)
-> (Interface -> [Module])
-> Interface
-> [Module]
forall a b c.
(a -> b -> c)
-> (Interface -> a) -> (Interface -> b) -> Interface -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) Interface -> Module
ifaceMod Interface -> [Module]
ifaceOrphanDeps) [Interface]
ifaces

  (_msgs, mb_index) <- do
    hsc_env <- getSession
    liftIO $ runTcInteractive hsc_env $ 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 :: * -> *) a. Foldable t => t a -> [a]
toList Seq ClsInst
clss, Seq FamInst -> [FamInst]
forall a. Seq a -> [a]
forall (t :: * -> *) 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 :: * -> *) 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 :: * -> *) 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

      newItems <- (ExportItem GhcRn -> Ghc (ExportItem GhcRn))
-> [ExportItem GhcRn] -> Ghc [ExportItem GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (InstEnvs
-> FamInstEnvs
-> NameEnv ([ClsInst], [FamInst])
-> ExportInfo
-> (Name -> Maybe (MDoc Name))
-> (Name -> Maybe Fixity)
-> 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)
                       (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]
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 :: * -> * -> *) 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
  -> ExportItem GhcRn
  -> Ghc (ExportItem GhcRn)
attachToExportItem :: InstEnvs
-> FamInstEnvs
-> NameEnv ([ClsInst], [FamInst])
-> ExportInfo
-> (Name -> Maybe (MDoc Name))
-> (Name -> Maybe Fixity)
-> 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 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)
-> GenLocated SrcSpan (IdP GhcRn)
-> GenLocated SrcSpan (Either String (IdP GhcRn))
forall {a} {a} {name}.
NamedThing a =>
a
-> Either a (InstHead name)
-> GenLocated SrcSpan (IdP name)
-> GenLocated SrcSpan (Either a (IdP 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]
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 :: * -> *) 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
-> GenLocated SrcSpan (IdP GhcRn)
-> GenLocated SrcSpan (IdP GhcRn)
forall {a} {name}.
NamedThing a =>
a
-> InstHead name
-> GenLocated SrcSpan (IdP name)
-> GenLocated SrcSpan (IdP 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]
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 :: * -> * -> *) 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 :: * -> *). 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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 :: * -> *) 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 :: * -> *) 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 :: a
-> InstHead name
-> GenLocated SrcSpan (IdP name)
-> GenLocated SrcSpan (IdP name)
spanName a
s (InstHead { ihdClsName :: forall name. InstHead name -> IdP name
ihdClsName = IdP name
clsn }) (L SrcSpan
instL IdP name
instn) =
        let s1 :: SrcSpan
s1 = a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
s
            sn :: IdP 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 IdP name
instn
                    else IdP name
clsn
        in SrcSpan -> IdP name -> GenLocated SrcSpan (IdP name)
forall l e. l -> e -> GenLocated l e
L (a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
s) IdP name
sn
    -- spanName on Either
    spanNameE :: a
-> Either a (InstHead name)
-> GenLocated SrcSpan (IdP name)
-> GenLocated SrcSpan (Either a (IdP name))
spanNameE a
s (Left a
e) GenLocated SrcSpan (IdP name)
_ =  SrcSpan
-> Either a (IdP name) -> GenLocated SrcSpan (Either a (IdP name))
forall l e. l -> e -> GenLocated l e
L (a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
s) (a -> Either a (IdP name)
forall a b. a -> Either a b
Left a
e)
    spanNameE a
s (Right InstHead name
ok) GenLocated SrcSpan (IdP name)
linst =
      let L SrcSpan
l IdP name
r = a
-> InstHead name
-> GenLocated SrcSpan (IdP name)
-> GenLocated SrcSpan (IdP name)
forall {a} {name}.
NamedThing a =>
a
-> InstHead name
-> GenLocated SrcSpan (IdP name)
-> GenLocated SrcSpan (IdP name)
spanName a
s InstHead name
ok GenLocated SrcSpan (IdP name)
linst
      in SrcSpan
-> Either a (IdP name) -> GenLocated SrcSpan (Either a (IdP name))
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (IdP name -> Either a (IdP name)
forall a b. b -> Either a b
Right IdP 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 -> 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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