From 6f354c0c94c7eb01425212a5c7641d947bccf3de Mon Sep 17 00:00:00 2001
From: Isaac Dupree <id@isaac.cedarswampstudios.org>
Date: Tue, 18 Aug 2009 02:23:31 +0000
Subject: Find instances using GHC, which is more complete. In particular, it
 works cross-package.

An intermediate patch also moved the instance-finding into
createInterface, but that move turned out not to be necessary,
so if we want to do that, it'd go in a separate patch.
(Is that possible? Or will we need GHC to have loaded all the modules
first, before we can go searching for the instances (e.g. if the
modules are recursive or something)?)
---
 src/Haddock/Interface.hs                 |  3 +-
 src/Haddock/Interface/AttachInstances.hs | 61 ++++++++++++--------------------
 2 files changed, 24 insertions(+), 40 deletions(-)

diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index d81a5c9f..98da7245 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -68,11 +68,10 @@ createInterfaces verbosity session modules flags extIfaces = do
       homeLinks = buildHomeLinks interfaces -- build the environment for the home
                                             -- package
       links     = homeLinks `Map.union` extLinks
-      allNames  = Map.keys links
 
   -- part 3, attach instances
   out verbosity verbose "Attaching instances..."
-  let interfaces' = attachInstances interfaces allNames
+  interfaces' <- attachInstances interfaces
 
   -- part 4, rename interfaces
   out verbosity verbose "Renaming interfaces..."
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 9da78108..46451c5a 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -16,14 +16,14 @@ module Haddock.Interface.AttachInstances (attachInstances) where
 import Haddock.Types
 import Haddock.Convert
 
-import qualified Data.Map as Map
-import Data.Map (Map)
 import Data.List
 
 import GHC
 import Name
 import InstEnv
 import Class
+import HscTypes (withSession, ioMsg)
+import TcRnDriver (tcRnGetInfo)
 
 #if __GLASGOW_HASKELL__ >= 610 && __GHC_PATCHLEVEL__ >= 2
 import TypeRep hiding (funTyConName)
@@ -38,24 +38,26 @@ import FastString
 #define FSLIT(x) (mkFastString# (x#))
 
 
-attachInstances :: [Interface] -> [Name] -> [Interface]
-attachInstances ifaces filterNames = map attach ifaces
+attachInstances :: [Interface] -> Ghc [Interface]
+attachInstances = mapM attach
   where
-    instMap =
-      fmap (map toHsInstHead . sortImage instHead) $
-      collectInstances ifaces filterNames
-
-    attach iface = iface { ifaceExportItems = newItems }
-      where
-        newItems = map attachExport (ifaceExportItems iface)
-
-        attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _)
-          | isClassDecl d || isDataDecl d || isFamilyDecl d =
-             ExportDecl decl doc subs (case Map.lookup (tcdName d) instMap of
-                                    Nothing -> []
-                                    Just instheads -> instheads)
-        attachExport export = export
-
+    attach iface = do
+      newItems <- mapM attachExport $ ifaceExportItems iface
+      return $ iface { ifaceExportItems = newItems }
+    attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _) = do
+       mb_info <- getAllInfo (unLoc (tcdLName d))
+       return $ ExportDecl decl doc subs $ case mb_info of
+         Just (_, _, instances) ->
+           map toHsInstHead . sortImage instHead . map instanceHead $ instances
+         Nothing ->
+           []
+    attachExport export = return export
+
+
+-- | Like GHC's getInfo but doesn't cut things out depending on the
+-- interative context, which we don't set sufficiently anyway.
+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
+getAllInfo name = withSession $ \hsc_env -> ioMsg $ tcRnGetInfo hsc_env name
 
 --------------------------------------------------------------------------------
 -- Collecting and sorting instances
@@ -64,28 +66,11 @@ attachInstances ifaces filterNames = map attach ifaces
 
 -- | 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] deriving (Eq,Ord)
 
 
-collectInstances
-   :: [Interface]
-   -> [Name]
-   -> Map Name [([TyVar], [PredType], Class, [Type])]  -- maps class/type names to instances
-
-collectInstances ifaces _ -- filterNames
-  = Map.fromListWith (flip (++)) tyInstPairs `Map.union`
-    Map.fromListWith (flip (++)) classInstPairs
-  where
-    allInstances = concatMap ifaceInstances ifaces
-    classInstPairs = [ (is_cls inst, [instanceHead inst]) | 
-                       inst <- allInstances ]
-                    -- unfinished filtering of internal instances
-                    -- Just n <- nub (is_tcs inst) ]
-                    --   n `elem` filterNames ]
-    tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, 
-                    Just tycon <- nub (is_tcs inst) ]    
-
-
 -- TODO: should we support PredTy here?
 instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
 instHead (_, _, cls, args)
-- 
cgit v1.2.3