Merge remote-tracking branch 'phadej/orphans' into ghc-head

3 files changed, 31 insertions, 10 deletions

diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index faf043aa..20971071 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -60,7 +60,18 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
     attach iface = do
       newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)
                        (ifaceExportItems iface)
-      return $ iface { ifaceExportItems = newItems }
+      let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface)
+      return $ iface { ifaceExportItems = newItems
+                     , ifaceOrphanInstances = orphanInstances
+                     }
+
+attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name]
+attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
+  [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))
+  | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
+  , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
+  , not $ isInstanceHidden expInfo cls tys
+  ]
 
 
 attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c41946f5..6466acfb 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -150,6 +150,8 @@ createInterface tm flags modMap instIfaceMap = do
   , ifaceModuleAliases   = aliases
   , ifaceInstances       = instances
   , ifaceFamInstances    = fam_instances
+  , ifaceOrphanInstances   = [] -- Filled in `attachInstances`
+  , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
   , ifaceHaddockCoverage = coverage
   , ifaceWarningMap      = warningMap
   , ifaceTokenizedSrc    = tokenizedSrc
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 2478ce23..a6223445 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -47,13 +47,17 @@ renameInterface dflags renamingEnv warnings iface =
 
       (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
 
-      (finalModuleDoc, missingNames4)
+      (renamedOrphanInstances, missingNames4)
+        = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface))
+
+      (finalModuleDoc, missingNames5)
         = runRnFM localEnv (renameDocumentation (ifaceDoc iface))
 
       -- combine the missing names and filter out the built-ins, which would
-      -- otherwise allways be missing.
+      -- otherwise always be missing.
       missingNames = nub $ filter isExternalName  -- XXX: isExternalName filters out too much
-                    (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4)
+                    (missingNames1 ++ missingNames2 ++ missingNames3
+                     ++ missingNames4 ++ missingNames5)
 
       -- filter out certain built in type constructors using their string
       -- representation. TODO: use the Name constants from the GHC API.
@@ -72,7 +76,8 @@ renameInterface dflags renamingEnv warnings iface =
     return $ iface { ifaceRnDoc         = finalModuleDoc,
                      ifaceRnDocMap      = rnDocMap,
                      ifaceRnArgMap      = rnArgMap,
-                     ifaceRnExportItems = renamedExportItems }
+                     ifaceRnExportItems = renamedExportItems,
+                     ifaceRnOrphanInstances = renamedOrphanInstances}
 
 
 --------------------------------------------------------------------------------
@@ -561,6 +566,13 @@ renameWc rn_thing (HsWC { hswc_body = thing })
        ; return (HsWC { hswc_body = thing'
                       , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }
 
+renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName)
+renameDocInstance (inst, idoc, L l n) = do
+  inst' <- renameInstHead inst
+  n' <- rename n
+  idoc' <- mapM renameDoc idoc
+  return (inst', idoc',L l n')
+
 renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
 renameExportItem item = case item of
   ExportModule mdl -> return (ExportModule mdl)
@@ -571,11 +583,7 @@ renameExportItem item = case item of
     decl' <- renameLDecl decl
     doc'  <- renameDocForDecl doc
     subs' <- mapM renameSub subs
-    instances' <- forM instances $ \(inst, idoc, L l n) -> do
-      inst' <- renameInstHead inst
-      n' <- rename n
-      idoc' <- mapM renameDoc idoc
-      return (inst', idoc',L l n')
+    instances' <- forM instances renameDocInstance
     fixities' <- forM fixities $ \(name, fixity) -> do
       name' <- lookupRn name
       return (name', fixity)