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

8 files changed, 90 insertions, 27 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 1554a33c..660bbe90 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -522,10 +522,10 @@ ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do
 
 ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
 ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
-  = ppModuleContents qual exports +++
+  = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++
     description +++
     synopsis +++
-    divInterface (maybe_doc_hdr +++ bdy)
+    divInterface (maybe_doc_hdr +++ bdy +++ orphans)
   where
     exports = numberSectionHeadings (ifaceRnExportItems iface)
 
@@ -564,6 +564,9 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
       foldr (+++) noHtml $
         mapMaybe (processExport False linksInfo unicode qual) exports
 
+    orphans =
+      ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual
+
     linksInfo = (maybe_source_url, maybe_wiki_url)
 
 
@@ -604,16 +607,22 @@ ppTyClBinderWithVarsMini mdl decl =
       ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
   in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
 
-ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
-ppModuleContents qual exports
-  | null sections = noHtml
-  | otherwise     = contentsDiv
+ppModuleContents :: Qualification
+                 -> [ExportItem DocName]
+                 -> Bool -- ^ Orphans sections
+                 -> Html
+ppModuleContents qual exports orphan
+  | null sections && not orphan  = noHtml
+  | otherwise                    = contentsDiv
  where
   contentsDiv = divTableOfContents << (
     sectionName << "Contents" +++
-    unordList sections)
+    unordList (sections ++ orphanSection))
 
   (sections, _leftovers{-should be []-}) = process 0 exports
+  orphanSection
+    | orphan =  [ linkedAnchor "section.orphans" << "Orphan instances" ]
+    | otherwise = []
 
   process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])
   process _ [] = ([], [])
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 49149b8c..f8599355 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -16,7 +16,7 @@
 module Haddock.Backends.Xhtml.Decl (
   ppDecl,
 
-  ppTyName, ppTyFamHeader, ppTypeApp,
+  ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances,
   tyvarNames
 ) where
 
@@ -561,14 +561,32 @@ ppInstances links origin instances splice unicode qual
     instName = getOccString origin
     instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
     instDecl no (inst, mdoc, loc) =
-        ((ppInstHead links splice unicode qual mdoc origin no inst), loc)
+        ((ppInstHead links splice unicode qual mdoc origin False no inst), loc)
+
+
+ppOrphanInstances :: LinksInfo
+                  -> [DocInstance DocName]
+                  -> Splice -> Unicode -> Qualification
+                  -> Html
+ppOrphanInstances links instances splice unicode qual
+  = subOrphanInstances qual links True (zipWith instDecl [1..] instances)
+  where
+    instOrigin :: InstHead name -> InstOrigin name
+    instOrigin inst = OriginClass (ihdClsName inst)
+
+    instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
+    instDecl no (inst, mdoc, loc) =
+        ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc)
 
 
 ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
            -> Maybe (MDoc DocName)
-           -> InstOrigin DocName -> Int -> InstHead DocName
+           -> InstOrigin DocName
+           -> Bool -- ^ Is instance orphan
+           -> Int  -- ^ Normal
+           -> InstHead DocName
            -> SubDecl
-ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) =
+ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
     case ihdInstType of
         ClassInst { .. } ->
             ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ
@@ -576,7 +594,7 @@ ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) =
             , [subInstDetails iid ats sigs]
             )
           where
-            iid = instanceId origin no ihd
+            iid = instanceId origin no orphan ihd
             sigs = ppInstanceSigs links splice unicode qual clsiSigs
             ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys
         TypeInst rhs ->
@@ -618,8 +636,9 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
 
-instanceId :: InstOrigin DocName -> Int -> InstHead DocName -> String
-instanceId origin no ihd = concat
+instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String
+instanceId origin no orphan ihd = concat $
+    [ "o:" | orphan ] ++
     [ qual origin
     , ":" ++ getOccString origin
     , ":" ++ (occNameString . getOccName . ihdClsName) ihd
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index d24ed9c4..98df09fe 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout (
   subConstructors,
   subEquations,
   subFields,
-  subInstances, subInstHead, subInstDetails,
+  subInstances, subOrphanInstances, subInstHead, subInstDetails,
   subMethods,
   subMinimal,
 
@@ -200,7 +200,17 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable
     subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
     id_ = makeAnchorId $ "i:" ++ nm
 
- 
+
+subOrphanInstances :: Qualification
+                   -> LinksInfo -> Bool
+                   -> [(SubDecl,Located DocName)] -> Html
+subOrphanInstances qual lnks splice  = maybe noHtml wrap . instTable
+  where
+    wrap = ((h1 << "Orphan instances") +++)
+    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice
+    id_ = makeAnchorId $ "orphans"
+
+
 subInstHead :: String -- ^ Instance unique id (for anchor generation)
             -> Html -- ^ Header content (instance name and type)
             -> Html
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index afb5111e..62b0aea9 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -228,7 +228,7 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
         foldl' keep_old old_env exported_names
       | otherwise = foldl' keep_new old_env exported_names
       where
-        exported_names = ifaceVisibleExports iface
+        exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface)
         mdl            = ifaceMod iface
         keep_old env n = Map.insertWith (\_ old -> old) n mdl env
         keep_new env n = Map.insert n mdl env
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)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index b837970b..34e99a8a 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -126,6 +126,10 @@ data Interface = Interface
   , ifaceInstances       :: ![ClsInst]
   , ifaceFamInstances    :: ![FamInst]
 
+    -- | Orphan instances
+  , ifaceOrphanInstances :: ![DocInstance Name]
+  , ifaceRnOrphanInstances :: ![DocInstance DocName]
+
     -- | The number of haddockable and haddocked items in the module, as a
     -- tuple. Haddockable items are the exports and the module itself.
   , ifaceHaddockCoverage :: !(Int, Int)