AttachInstances.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
{-# 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 Data.Ord (comparing)
import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

import GHC.Data.FastString (unpackFS)
import GHC.Core.Class
import GHC.Core.FamInstEnv
import GHC
import GHC.Core.InstEnv
import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts )
import GHC.Types.Name
import GHC.Types.Name.Env
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

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 expInfo ifaces instIfaceMap mods = do
  (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mods'
  mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces
  where
    mods' = Just (moduleSetElts mods)

    -- TODO: take an IfaceMap as input
    ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]

    attach index iface = do

      let getInstDoc = findInstDoc iface ifaceMap instIfaceMap
          getFixity = findFixity iface ifaceMap instIfaceMap

      newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity)
                       (ifaceExportItems iface)
      let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface)
      return $ iface { ifaceExportItems = newItems
                     , ifaceOrphanInstances = orphanInstances
                     }

attachOrphanInstances
  :: ExportInfo
  -> (Name -> Maybe (MDoc Name))      -- ^ how to lookup the doc of an instance
  -> [HaddockClsInst]                 -- ^ a list of instances
  -> [DocInstance GhcRn]
attachOrphanInstances expInfo getInstDoc cls_instances =
  [ (synified, getInstDoc instName, (L (getSrcSpan instName) instName), Nothing)
  | let is =
          [ ( haddockClsInstHead i
            , haddockClsInstSynified i
            , haddockClsInstName i
            , haddockClsInstClsName i
            , haddockClsInstTyNames i
            )
          | i <- cls_instances, haddockClsInstIsOrphan i
          ]
  , (_, synified, instName, cls, tyNames) <- sortBy (comparing $ (\(ih,_,_,_,_) -> ih)) is
  , not $ isInstanceHidden expInfo cls tyNames
  ]


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 index expInfo getInstDoc getFixity export =
  case attachFixities export of
    ExportDecl e@(ExportD { expDDecl = L eSpan (TyClD _ d) }) -> do
      insts <-
        let mb_instances  = lookupNameEnv index (tcdName d)
            cls_instances = maybeToList mb_instances >>= fst
            fam_instances = maybeToList mb_instances >>= snd
            fam_insts = [ ( synFamInst
                          , getInstDoc n
                          , spanNameE n synFamInst (L (locA eSpan) (tcdName d))
                          , mb_mdl
                          )
                        | i <- sortBy (comparing instFam) fam_instances
                        , let n = getName i
                        , not $ isNameHidden expInfo (fi_fam i)
                        , not $ any (isTypeHidden expInfo) (fi_tys i)
                        , let opaque = isTypeHidden expInfo (fi_rhs i)
                        , let synFamInst = synifyFamInst i opaque
                        , let !mb_mdl = force $ nameModule_maybe n
                        ]
            cls_insts = [ ( synClsInst
                          , getInstDoc n
                          , spanName n synClsInst (L (locA eSpan) (tcdName d))
                          , mb_mdl
                          )
                        | let is = [ (instanceSig i, getName i) | i <- cls_instances ]
                        , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
                        , not $ isInstanceHidden
                                  expInfo
                                  (getName cls)
                                  (foldl' (\acc t -> acc `Set.union` typeNames t) Set.empty tys)
                        , let synClsInst = synifyInstHead i
                        , let !mb_mdl = force $ nameModule_maybe n
                        ]
              -- fam_insts but with failing type fams filtered out
            cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
            famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ]
        in do
          let mkBug = (text "haddock-bug:" <+>) . text
          putMsgM (sep $ map mkBug famInstErrs)
          return $ cls_insts ++ cleanFamInsts
      return $ ExportDecl e { expDInstances = insts }
    e -> return e
  where
    attachFixities
        ( ExportDecl
          ( e@ExportD
              { expDDecl = L _ d
              , expDPats = patsyns
              , expDSubDocs = subDocs
              }
          )
        )
      = ExportDecl e
          { expDFixities = fixities
          }
      where
        fixities :: [(Name, Fixity)]
        !fixities = force . Map.toList $ foldl' f Map.empty all_names

        f :: Map.Map Name Fixity -> Name -> Map.Map Name Fixity
        f !fs n = Map.alter (<|> getFixity n) n fs

        patsyn_names :: [Name]
        patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns

        all_names :: [Name]
        all_names =
             getMainDeclBinder emptyOccEnv d
          ++ map fst subDocs
          ++ patsyn_names

    attachFixities e = e

    -- spanName: attach the location to the name that is the same file as the instance location
    spanName s (InstHead { ihdClsName = clsn }) (L instL instn) =
        let s1 = getSrcSpan s
            sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL
                    then instn
                    else clsn
        in L (getSrcSpan s) sn
    -- spanName on Either
    spanNameE s (Left e) _ =  L (getSrcSpan s) (Left e)
    spanNameE s (Right ok) linst =
      let L l r = spanName s ok linst
      in L l (Right r)

-- | Lookup the doc associated with a certain instance
findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name)
findInstDoc iface ifaceMap instIfaceMap = \name ->
  (Map.lookup name . ifaceDocMap $ iface) <|>
  (Map.lookup name . ifaceDocMap =<< Map.lookup (nameModule name) ifaceMap) <|>
  (Map.lookup name . instDocMap =<< Map.lookup (nameModule name) instIfaceMap)

-- | Lookup the fixity associated with a certain name
findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity
findFixity iface ifaceMap instIfaceMap = \name ->
  (Map.lookup name . ifaceFixMap $ iface) <|>
  (Map.lookup name . ifaceFixMap =<< Map.lookup (nameModule name) ifaceMap) <|>
  (Map.lookup name . instFixMap =<< Map.lookup (nameModule name) instIfaceMap)


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

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

argCount :: Type -> Int
argCount (AppTy t _)     = argCount t + 1
argCount (TyConApp _ ts) = length ts
argCount (FunTy _ _ _ _) = 2
argCount (ForAllTy _ t)  = argCount t
argCount (CastTy t _)    = argCount t
argCount _ = 0

simplify :: Type -> SimpleType
simplify (FunTy _ _ t1 t2)  = SimpleType (SName unrestrictedFunTyConName) [simplify t1, simplify t2]
simplify (ForAllTy _ t) = simplify t
simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2))
  where (SimpleType s ts) = simplify t1
simplify (TyVarTy v) = SimpleType (SName (tyVarName v)) []
simplify (TyConApp tc ts) = SimpleType (SName (tyConName tc))
                                       (mapMaybe simplify_maybe ts)
simplify (LitTy (NumTyLit n)) = SimpleIntTyLit n
simplify (LitTy (StrTyLit s)) = SimpleStringTyLit (unpackFS s)
simplify (LitTy (CharTyLit c)) = SimpleCharTyLit c
simplify (CastTy ty _) = simplify ty
simplify (CoercionTy _) = error "simplify:Coercion"

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

-- Used for sorting
instFam :: FamInst -> ([Int], SName, [SimpleType], Int, SimpleType)
instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }
  = (map argCount ts, SName n, map simplify ts, argCount t, simplify 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 (names, modules) name =
  nameModule name `Set.member` modules &&
  not (name `Set.member` names)

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

    instTypeHidden :: Bool
    instTypeHidden = any (isNameHidden expInfo) tyNames

isTypeHidden :: ExportInfo -> Type -> Bool
isTypeHidden expInfo = typeHidden
  where
    typeHidden :: Type -> Bool
    typeHidden t = any nameHidden $ typeNames t

    nameHidden :: Name -> Bool
    nameHidden = isNameHidden expInfo