module Haddock.Interface.AttachInstances (attachInstances) where
import Haddock.Types
import Haddock.Convert
import Control.Arrow
import Data.List
import qualified Data.Map as Map
import GHC
import Name
import InstEnv
import Class
import HscTypes (withSession, ioMsg)
#ifdef GHCI
import TcRnDriver (tcRnGetInfo)
#endif
import TypeRep hiding (funTyConName)
import Var hiding (varName)
import TyCon
import PrelNames
import FastString
#define FSLIT(x) (mkFastString# (x#))
attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface]
attachInstances ifaces instIfaceMap = mapM attach ifaces
where
attach iface = do
newItems <- mapM attachExport $ ifaceExportItems iface
return $ iface { ifaceExportItems = newItems }
where
attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do
#ifdef GHCI
mb_info <- getAllInfo (unLoc (tcdLName d))
#else
let mb_info = Nothing
#endif
return $ export { expItemInstances = case mb_info of
Just (_, _, instances) ->
let insts = map (first synifyInstHead) $ sortImage (first instHead)
[ (instanceHead i, getName i) | i <- instances ]
in [ (inst, lookupInstDoc name iface instIfaceMap)
| (inst, name) <- insts ]
Nothing -> []
}
attachExport export = return export
lookupInstDoc :: Name -> Interface -> InstIfaceMap -> Maybe (Doc Name)
lookupInstDoc name iface ifaceMap =
case Map.lookup name (ifaceInstanceDocMap iface) of
Just doc -> Just doc
Nothing -> do
instIface <- Map.lookup modName ifaceMap
(Just doc, _) <- Map.lookup name (instDocMap instIface)
return doc
where
modName = nameModule name
#ifdef GHCI
getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
getAllInfo name = withSession $ \hsc_env -> ioMsg $ tcRnGetInfo hsc_env name
#endif
data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
instHead (_, _, cls, args)
= (map argCount args, className cls, map simplify args)
where
argCount (AppTy t _) = argCount t + 1
argCount (TyConApp _ ts) = length ts
argCount (FunTy _ _ ) = 2
argCount (ForAllTy _ t) = argCount t
argCount _ = 0
simplify (ForAllTy _ t) = simplify t
simplify (FunTy t1 t2) =
SimpleType funTyConName [simplify t1, simplify t2]
simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
where (SimpleType s ts) = simplify t1
simplify (TyVarTy v) = SimpleType (tyVarName v) []
simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
simplify _ = error "simplify"
sortImage :: Ord b => (a -> b) -> [a] -> [a]
sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs]
where cmp_fst (x,_) (y,_) = compare x y
funTyConName :: Name
funTyConName = mkWiredInName gHC_PRIM
(mkOccNameFS tcName FSLIT("(->)"))
funTyConKey
(ATyCon funTyCon)
BuiltInSyntax