{-# LANGUAGE MagicHash, BangPatterns #-}
{-# 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) where


import Haddock.Types
import Haddock.Convert
import Haddock.GhcUtils

import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
import qualified Data.Map as Map
import qualified Data.Set as Set

import Class
import DynFlags
import CoreSyn (isOrphan)
import ErrUtils
import FamInstEnv
import GHC
import InstEnv
import Module ( ModuleSet, moduleSetElts )
import MonadUtils (liftIO)
import Name
import NameEnv
import Outputable (text, sep, (<+>))
import SrcLoc
import TyCon
import TyCoRep
import TysPrim( funTyConName )
import Var hiding (varName)

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

-- Also attaches fixities
attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface]
attachInstances :: ExportInfo
-> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface]
attachInstances ExportInfo
expInfo [Interface]
ifaces InstIfaceMap
instIfaceMap ModuleSet
mods = do
  (Messages
_msgs, Maybe (NameEnv ([ClsInst], [FamInst]))
mb_index) <- [Module]
-> Maybe [Module]
-> Ghc (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
forall (m :: * -> *).
GhcMonad m =>
[Module]
-> Maybe [Module]
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex ((Interface -> Module) -> [Interface] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> Module
ifaceMod [Interface]
ifaces) Maybe [Module]
mods'
  (Interface -> Ghc Interface) -> [Interface] -> Ghc [Interface]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NameEnv ([ClsInst], [FamInst]) -> Interface -> Ghc Interface
attach (NameEnv ([ClsInst], [FamInst]) -> Interface -> Ghc Interface)
-> NameEnv ([ClsInst], [FamInst]) -> Interface -> Ghc Interface
forall a b. (a -> b) -> a -> b
$ NameEnv ([ClsInst], [FamInst])
-> Maybe (NameEnv ([ClsInst], [FamInst]))
-> NameEnv ([ClsInst], [FamInst])
forall a. a -> Maybe a -> a
fromMaybe NameEnv ([ClsInst], [FamInst])
forall a. NameEnv a
emptyNameEnv Maybe (NameEnv ([ClsInst], [FamInst]))
mb_index) [Interface]
ifaces
  where
    mods' :: Maybe [Module]
mods' = [Module] -> Maybe [Module]
forall a. a -> Maybe a
Just (ModuleSet -> [Module]
moduleSetElts ModuleSet
mods)

    -- 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 :: NameEnv ([ClsInst], [FamInst]) -> Interface -> Ghc Interface
attach NameEnv ([ClsInst], [FamInst])
index 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

      [ExportItem GhcRn]
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)
mapM (NameEnv ([ClsInst], [FamInst])
-> ExportInfo
-> (Name -> Maybe (MDoc Name))
-> (Name -> Maybe Fixity)
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
attachToExportItem NameEnv ([ClsInst], [FamInst])
index ExportInfo
expInfo Name -> Maybe (MDoc Name)
getInstDoc Name -> Maybe Fixity
getFixity)
                       (Interface -> [ExportItem GhcRn]
ifaceExportItems Interface
iface)
      let orphanInstances :: [DocInstance GhcRn]
orphanInstances = ExportInfo
-> (Name -> Maybe (MDoc Name)) -> [ClsInst] -> [DocInstance GhcRn]
attachOrphanInstances ExportInfo
expInfo Name -> Maybe (MDoc Name)
getInstDoc (Interface -> [ClsInst]
ifaceInstances Interface
iface)
      Interface -> Ghc Interface
forall (m :: * -> *) a. Monad m => a -> m a
return (Interface -> Ghc Interface) -> Interface -> Ghc Interface
forall a b. (a -> b) -> a -> b
$ Interface
iface { ifaceExportItems :: [ExportItem GhcRn]
ifaceExportItems = [ExportItem GhcRn]
newItems
                     , ifaceOrphanInstances :: [DocInstance GhcRn]
ifaceOrphanInstances = [DocInstance GhcRn]
orphanInstances
                     }

attachOrphanInstances
  :: ExportInfo
  -> (Name -> Maybe (MDoc Name))      -- ^ how to lookup the doc of an instance
  -> [ClsInst]                        -- ^ a list of orphan instances
  -> [DocInstance GhcRn]
attachOrphanInstances :: ExportInfo
-> (Name -> Maybe (MDoc Name)) -> [ClsInst] -> [DocInstance GhcRn]
attachOrphanInstances ExportInfo
expInfo Name -> Maybe (MDoc Name)
getInstDoc [ClsInst]
cls_instances =
  [ (([TyVar], [PredType], Class, [PredType]) -> InstHead GhcRn
synifyInstHead ([TyVar], [PredType], Class, [PredType])
i, Name -> Maybe (MDoc Name)
getInstDoc Name
n, (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n) Name
n), Maybe Module
forall a. Maybe a
Nothing)
  | 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], Name, [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], Name, [SimpleType]), Name))
 -> (([TyVar], [PredType], Class, [PredType]), Name)
 -> (([TyVar], [PredType], Class, [PredType]), Name)
 -> Ordering)
-> ((([TyVar], [PredType], Class, [PredType]), Name)
    -> (([Int], Name, [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], Name, [SimpleType]))
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> (([Int], Name, [SimpleType]), Name)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([TyVar], [PredType], Class, [PredType])
-> ([Int], Name, [SimpleType])
instHead) [(([TyVar], [PredType], Class, [PredType]), Name)]
is
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ExportInfo -> Class -> [PredType] -> Bool
isInstanceHidden ExportInfo
expInfo Class
cls [PredType]
tys
  ]


attachToExportItem
  :: NameEnv ([ClsInst], [FamInst])   -- ^ all instances (that we know of)
  -> 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 :: NameEnv ([ClsInst], [FamInst])
-> ExportInfo
-> (Name -> Maybe (MDoc Name))
-> (Name -> Maybe Fixity)
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
attachToExportItem 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
    e :: ExportItem GhcRn
e@ExportDecl { expItemDecl :: forall name. ExportItem name -> LHsDecl name
expItemDecl = L SrcSpan
eSpan (TyClD XTyClD GhcRn
_ TyClDecl GhcRn
d) } -> do
      [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
  Maybe Module)]
insts <-
        let mb_instances :: Maybe ([ClsInst], [FamInst])
mb_instances  = NameEnv ([ClsInst], [FamInst])
-> Name -> Maybe ([ClsInst], [FamInst])
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv ([ClsInst], [FamInst])
index (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass). TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
d)
            cls_instances :: [ClsInst]
cls_instances = Maybe ([ClsInst], [FamInst]) -> [([ClsInst], [FamInst])]
forall a. Maybe a -> [a]
maybeToList Maybe ([ClsInst], [FamInst])
mb_instances [([ClsInst], [FamInst])]
-> (([ClsInst], [FamInst]) -> [ClsInst]) -> [ClsInst]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([ClsInst], [FamInst]) -> [ClsInst]
forall a b. (a, b) -> a
fst
            fam_instances :: [FamInst]
fam_instances = Maybe ([ClsInst], [FamInst]) -> [([ClsInst], [FamInst])]
forall a. Maybe a -> [a]
maybeToList Maybe ([ClsInst], [FamInst])
mb_instances [([ClsInst], [FamInst])]
-> (([ClsInst], [FamInst]) -> [FamInst]) -> [FamInst]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([ClsInst], [FamInst]) -> [FamInst]
forall a b. (a, b) -> b
snd
            fam_insts :: [(Either ErrMsg (InstHead GhcRn), Maybe (MDoc Name),
  GenLocated SrcSpan (Either ErrMsg Name), Maybe Module)]
fam_insts = [ ( Either ErrMsg (InstHead GhcRn)
synFamInst
                          , Name -> Maybe (MDoc Name)
getInstDoc Name
n
                          , Name
-> Either ErrMsg (InstHead GhcRn)
-> GenLocated SrcSpan (IdP GhcRn)
-> GenLocated SrcSpan (Either ErrMsg (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 ErrMsg (InstHead GhcRn)
synFamInst (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
eSpan (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass). TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
d))
                          , Name -> Maybe Module
nameModule_maybe Name
n
                          )
                        | FamInst
i <- (FamInst -> FamInst -> Ordering) -> [FamInst] -> [FamInst]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((FamInst -> ([Int], Name, [SimpleType], Int, SimpleType))
-> FamInst -> FamInst -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing FamInst -> ([Int], Name, [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)
                        , let synFamInst :: Either ErrMsg (InstHead GhcRn)
synFamInst = FamInst -> Bool -> Either ErrMsg (InstHead GhcRn)
synifyFamInst FamInst
i Bool
opaque
                        ]
            cls_insts :: [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan 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 -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
eSpan (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass). TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
d))
                          , 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 ]
                        , (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], Name, [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], Name, [SimpleType]), Name))
 -> (([TyVar], [PredType], Class, [PredType]), Name)
 -> (([TyVar], [PredType], Class, [PredType]), Name)
 -> Ordering)
-> ((([TyVar], [PredType], Class, [PredType]), Name)
    -> (([Int], Name, [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], Name, [SimpleType]))
-> (([TyVar], [PredType], Class, [PredType]), Name)
-> (([Int], Name, [SimpleType]), Name)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([TyVar], [PredType], Class, [PredType])
-> ([Int], Name, [SimpleType])
instHead) [(([TyVar], [PredType], Class, [PredType]), Name)]
is
                        , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ExportInfo -> Class -> [PredType] -> Bool
isInstanceHidden ExportInfo
expInfo Class
cls [PredType]
tys
                        , let synClsInst :: InstHead GhcRn
synClsInst = ([TyVar], [PredType], Class, [PredType]) -> InstHead GhcRn
synifyInstHead ([TyVar], [PredType], Class, [PredType])
i
                        ]
              -- fam_insts but with failing type fams filtered out
            cleanFamInsts :: [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
  Maybe Module)]
cleanFamInsts = [ (InstHead GhcRn
fi, Maybe (MDoc Name)
n, SrcSpan -> Name -> GenLocated SrcSpan 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 ErrMsg (InstHead GhcRn), Maybe (MDoc Name),
  GenLocated SrcSpan (Either ErrMsg Name), Maybe Module)]
fam_insts ]
            famInstErrs :: [ErrMsg]
famInstErrs = [ ErrMsg
errm | (Left ErrMsg
errm, Maybe (MDoc Name)
_, GenLocated SrcSpan (Either ErrMsg Name)
_, Maybe Module
_) <- [(Either ErrMsg (InstHead GhcRn), Maybe (MDoc Name),
  GenLocated SrcSpan (Either ErrMsg Name), Maybe Module)]
fam_insts ]
        in do
          DynFlags
dfs <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
          let mkBug :: ErrMsg -> SDoc
mkBug = (ErrMsg -> SDoc
text ErrMsg
"haddock-bug:" SDoc -> SDoc -> SDoc
<+>) (SDoc -> SDoc) -> (ErrMsg -> SDoc) -> ErrMsg -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> SDoc
text
          IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
putMsg DynFlags
dfs ([SDoc] -> SDoc
sep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ErrMsg -> SDoc) -> [ErrMsg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> SDoc
mkBug [ErrMsg]
famInstErrs)
          [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
  Maybe Module)]
-> Ghc
     [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
       Maybe Module)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
   Maybe Module)]
 -> Ghc
      [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
        Maybe Module)])
-> [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
     Maybe Module)]
-> Ghc
     [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
       Maybe Module)]
forall a b. (a -> b) -> a -> b
$ [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
  Maybe Module)]
cls_insts [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
  Maybe Module)]
-> [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
     Maybe Module)]
-> [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
     Maybe Module)]
forall a. [a] -> [a] -> [a]
++ [(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
  Maybe Module)]
cleanFamInsts
      ExportItem GhcRn -> Ghc (ExportItem GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExportItem GhcRn -> Ghc (ExportItem GhcRn))
-> ExportItem GhcRn -> Ghc (ExportItem GhcRn)
forall a b. (a -> b) -> a -> b
$ ExportItem GhcRn
e { expItemInstances :: [DocInstance GhcRn]
expItemInstances = [DocInstance GhcRn]
[(InstHead GhcRn, Maybe (MDoc Name), GenLocated SrcSpan Name,
  Maybe Module)]
insts }
    ExportItem GhcRn
e -> ExportItem GhcRn -> Ghc (ExportItem GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return ExportItem GhcRn
e
  where
    attachFixities :: ExportItem GhcRn -> ExportItem GhcRn
attachFixities e :: ExportItem GhcRn
e@ExportDecl{ expItemDecl :: forall name. ExportItem name -> LHsDecl name
expItemDecl = L SrcSpan
_ HsDecl GhcRn
d
                               , expItemPats :: forall name.
ExportItem name -> [(HsDecl name, DocForDecl (IdP name))]
expItemPats = [(HsDecl GhcRn, DocForDecl (IdP GhcRn))]
patsyns
                               , expItemSubDocs :: forall name. ExportItem name -> [(IdP name, DocForDecl (IdP name))]
expItemSubDocs = [(IdP GhcRn, DocForDecl (IdP GhcRn))]
subDocs
                               } = ExportItem GhcRn
e { expItemFixities :: [(IdP GhcRn, Fixity)]
expItemFixities =
      ((Name, Fixity) -> Name) -> [(Name, Fixity)] -> [(Name, Fixity)]
forall a. (a -> Name) -> [a] -> [a]
nubByName (Name, Fixity) -> Name
forall a b. (a, b) -> a
fst ([(Name, Fixity)] -> [(Name, Fixity)])
-> [(Name, Fixity)] -> [(Name, Fixity)]
forall a b. (a -> b) -> a -> b
$ ExportItem GhcRn -> [(IdP GhcRn, Fixity)]
forall name. ExportItem name -> [(IdP name, Fixity)]
expItemFixities ExportItem GhcRn
e [(Name, Fixity)] -> [(Name, Fixity)] -> [(Name, Fixity)]
forall a. [a] -> [a] -> [a]
++
      [ (Name
n',Fixity
f) | Name
n <- HsDecl GhcRn -> [IdP GhcRn]
forall (p :: Pass). HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder HsDecl GhcRn
d
               , Name
n' <- Name
n 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)
               , Fixity
f <- Maybe Fixity -> [Fixity]
forall a. Maybe a -> [a]
maybeToList (Name -> Maybe Fixity
getFixity Name
n')
      ] }
      where
        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 (HsDecl GhcRn -> [Name]
forall (p :: Pass). HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder (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

    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)

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


-- | Simplified type for sorting types, ignoring qualification (not visible
-- in Haddock output) and unifying special tycons with normal ones.
-- For the benefit of the user (looks nice and predictable) and the
-- tests (which prefer output to be deterministic).
data SimpleType = SimpleType Name [SimpleType]
                | SimpleTyLit TyLit
                  deriving (SimpleType -> SimpleType -> Bool
(SimpleType -> SimpleType -> Bool)
-> (SimpleType -> SimpleType -> Bool) -> Eq SimpleType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleType -> SimpleType -> Bool
$c/= :: SimpleType -> SimpleType -> Bool
== :: SimpleType -> SimpleType -> Bool
$c== :: SimpleType -> SimpleType -> Bool
Eq,Eq SimpleType
Eq SimpleType
-> (SimpleType -> SimpleType -> Ordering)
-> (SimpleType -> SimpleType -> Bool)
-> (SimpleType -> SimpleType -> Bool)
-> (SimpleType -> SimpleType -> Bool)
-> (SimpleType -> SimpleType -> Bool)
-> (SimpleType -> SimpleType -> SimpleType)
-> (SimpleType -> SimpleType -> SimpleType)
-> Ord SimpleType
SimpleType -> SimpleType -> Bool
SimpleType -> SimpleType -> Ordering
SimpleType -> SimpleType -> SimpleType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SimpleType -> SimpleType -> SimpleType
$cmin :: SimpleType -> SimpleType -> SimpleType
max :: SimpleType -> SimpleType -> SimpleType
$cmax :: SimpleType -> SimpleType -> SimpleType
>= :: SimpleType -> SimpleType -> Bool
$c>= :: SimpleType -> SimpleType -> Bool
> :: SimpleType -> SimpleType -> Bool
$c> :: SimpleType -> SimpleType -> Bool
<= :: SimpleType -> SimpleType -> Bool
$c<= :: SimpleType -> SimpleType -> Bool
< :: SimpleType -> SimpleType -> Bool
$c< :: SimpleType -> SimpleType -> Bool
compare :: SimpleType -> SimpleType -> Ordering
$ccompare :: SimpleType -> SimpleType -> Ordering
$cp1Ord :: Eq SimpleType
Ord)


instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
instHead :: ([TyVar], [PredType], Class, [PredType])
-> ([Int], Name, [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, 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 (t :: * -> *) a. Foldable t => t a -> Int
length [PredType]
ts
argCount (FunTy AnonArgFlag
_ PredType
_ PredType
_)   = Int
2
argCount (ForAllTy TyCoVarBinder
_ 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 AnonArgFlag
_ PredType
t1 PredType
t2) = Name -> [SimpleType] -> SimpleType
SimpleType Name
funTyConName [PredType -> SimpleType
simplify PredType
t1, PredType -> SimpleType
simplify PredType
t2]
simplify (ForAllTy TyCoVarBinder
_ PredType
t) = PredType -> SimpleType
simplify PredType
t
simplify (AppTy PredType
t1 PredType
t2) = Name -> [SimpleType] -> SimpleType
SimpleType Name
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 Name
s [SimpleType]
ts) = PredType -> SimpleType
simplify PredType
t1
simplify (TyVarTy TyVar
v) = Name -> [SimpleType] -> SimpleType
SimpleType (TyVar -> Name
tyVarName TyVar
v) []
simplify (TyConApp TyCon
tc [PredType]
ts) = Name -> [SimpleType] -> SimpleType
SimpleType (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 TyLit
l) = TyLit -> SimpleType
SimpleTyLit TyLit
l
simplify (CastTy PredType
ty KindCoercion
_) = PredType -> SimpleType
simplify PredType
ty
simplify (CoercionTy KindCoercion
_) = ErrMsg -> SimpleType
forall a. HasCallStack => ErrMsg -> a
error ErrMsg
"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], Name, [SimpleType], Int, SimpleType)
instFam :: FamInst -> ([Int], Name, [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
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 -> Class -> [Type] -> Bool
isInstanceHidden :: ExportInfo -> Class -> [PredType] -> Bool
isInstanceHidden ExportInfo
expInfo Class
cls [PredType]
tys =
    Bool
instClassHidden Bool -> Bool -> Bool
|| Bool
instTypeHidden
  where
    instClassHidden :: Bool
    instClassHidden :: Bool
instClassHidden = ExportInfo -> Name -> Bool
isNameHidden ExportInfo
expInfo (Name -> Bool) -> Name -> Bool
forall a b. (a -> b) -> a -> b
$ Class -> Name
forall a. NamedThing a => a -> Name
getName Class
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]
tys

isTypeHidden :: ExportInfo -> Type -> Bool
isTypeHidden :: ExportInfo -> PredType -> Bool
isTypeHidden ExportInfo
expInfo = PredType -> Bool
typeHidden
  where
    typeHidden :: Type -> Bool
    typeHidden :: PredType -> Bool
typeHidden PredType
t =
      case PredType
t of
        TyVarTy {} -> Bool
False
        AppTy PredType
t1 PredType
t2 -> PredType -> Bool
typeHidden PredType
t1 Bool -> Bool -> Bool
|| PredType -> Bool
typeHidden PredType
t2
        FunTy AnonArgFlag
_ PredType
t1 PredType
t2 -> PredType -> Bool
typeHidden PredType
t1 Bool -> Bool -> Bool
|| PredType -> Bool
typeHidden PredType
t2
        TyConApp TyCon
tcon [PredType]
args -> Name -> Bool
nameHidden (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tcon) Bool -> Bool -> Bool
|| (PredType -> Bool) -> [PredType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PredType -> Bool
typeHidden [PredType]
args
        ForAllTy TyCoVarBinder
bndr PredType
ty -> PredType -> Bool
typeHidden (TyVar -> PredType
tyVarKind (TyCoVarBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
bndr)) Bool -> Bool -> Bool
|| PredType -> Bool
typeHidden PredType
ty
        LitTy TyLit
_ -> Bool
False
        CastTy PredType
ty KindCoercion
_ -> PredType -> Bool
typeHidden PredType
ty
        CoercionTy {} -> Bool
False

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