Roughly fix up haddock for DuplicateRecordFields changes

This compiles, but will probably need more work to produce good
documentation when the DuplicateRecordFields extension is used.

9 files changed, 45 insertions, 26 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index fe656a4b..55075e20 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -190,8 +190,8 @@ ppCtor dflags dat subdocs con
         f (PrefixCon args) = [typeSig name $ args ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
         f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
-                          [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++
-                           [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+                          [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++
+                           [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
 
         funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b8558f4f..68149b41 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -24,9 +24,10 @@ import qualified Pretty
 import GHC
 import OccName
 import Name                 ( nameOccName )
-import RdrName              ( rdrNameOcc )
+import RdrName              ( rdrNameOcc, mkRdrUnqual )
 import FastString           ( unpackFS, unpackLitString, zString )
 import Outputable           ( panic)
+import PrelNames            ( mkUnboundName )
 
 import qualified Data.Map as Map
 import System.Directory
@@ -686,12 +687,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
 
 ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  LaTeX
 ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
-  decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names))
+  decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . rdrNameFieldOcc . unLoc) names))
     <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
   where
     -- don't use cd_fld_doc for same reason we don't use con_doc above
     -- Where there is more than one name, they all have the same documentation
-    mbDoc = lookup (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
+    mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
 
 -- {-
 -- ppHsFullConstr :: HsConDecl -> LaTeX
@@ -900,7 +901,9 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode
   = maybeParen ctxt_prec pREC_FUN $
     hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]
  where
-   anonWC = HsWildCardTy (AnonWildCard PlaceHolder)
+   anonWC :: HsType DocName
+   anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
+   underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
    ctxt'
      | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
      | otherwise         = ctxt
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 56b64120..f94daabf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -38,6 +38,8 @@ import GHC
 import GHC.Exts
 import Name
 import BooleanFormula
+import RdrName ( rdrNameOcc, mkRdrUnqual )
+import PrelNames            ( mkUnboundName )
 
 ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
        -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
@@ -741,18 +743,18 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
 ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
                   -> ConDeclField DocName -> SubDecl
 ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
-  (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
+  (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
     mbDoc,
     [])
   where
     -- don't use cd_fld_doc for same reason we don't use con_doc above
     -- Where there is more than one name, they all have the same documentation
-    mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst
+    mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
 
 
 ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
 ppShortField summary unicode qual (ConDeclField names ltype _)
-  = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names))
+  = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names))
     <+> dcolon unicode <+> ppLType unicode qual ltype
 
 
@@ -874,7 +876,8 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual
   = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual
                                     <+> ppr_mono_lty pREC_TOP ty unicode qual
  where
-   anonWC = HsWildCardTy (AnonWildCard PlaceHolder)
+   anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
+   underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
    ctxt'
      | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
      | otherwise         = ctxt
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 3fd783aa..f0fc108b 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -30,6 +30,7 @@ import Haddock.Types
 import HsSyn
 import Kind ( splitKindFunTys, tyConResKind, isKind )
 import Name
+import RdrName ( mkVarUnqual )
 import PatSyn
 import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
 import TcType ( tcSplitSigmaTy )
@@ -293,9 +294,10 @@ synifyDataCon use_gadt_syntax dc =
                     bang' -> noLoc $ HsBangTy bang' tySyn)
             arg_tys (dataConSrcBangs dc)
 
-  field_tys = zipWith (\field synTy -> noLoc $ ConDeclField
-                                               [synifyName field] synTy Nothing)
-                (dataConFieldLabels dc) linear_tys
+  field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
+  con_decl_field fl synTy = noLoc $
+    ConDeclField [noLoc $ FieldOcc (mkVarUnqual $ flLabel fl) (flSelector fl)] synTy
+                 Nothing
   hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
           (True,True) -> Left "synifyDataCon: contradiction!"
           (True,False) -> return $ RecCon (noLoc field_tys)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 5caefa77..aa9a1c32 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -189,7 +189,8 @@ class Parent a where
 instance Parent (ConDecl Name) where
   children con =
     case con_details con of
-      RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields)
+      RecCon fields -> map (selectorFieldOcc . unL) $
+                         concatMap (cd_fld_names . unL) (unL fields)
       _             -> []
 
 instance Parent (TyClDecl Name) where
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 75702b50..8f3b9f9a 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -331,15 +331,16 @@ subordinates instMap decl = case decl of
     classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
                    , name <- getMainDeclBinder d, not (isValD d)
                    ]
+    dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]
     dataSubs dd = constrs ++ fields
       where
         cons = map unL $ (dd_cons dd)
         constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
                   | c <- cons, cname <- con_names c ]
-        fields  = [ (unL n, maybeToList $ fmap unL doc, M.empty)
+        fields  = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
                   | RecCon flds <- map con_details cons
                   , L _ (ConDeclField ns _ doc) <- (unLoc flds)
-                  , n <- ns ]
+                  , L _ n <- ns ]
 
 -- | Extract function argument docs from inside types.
 typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -501,7 +502,7 @@ mkExportItems
     lookupExport (IEVar (L _ x))         = declWith x
     lookupExport (IEThingAbs (L _ t))    = declWith t
     lookupExport (IEThingAll (L _ t))    = declWith t
-    lookupExport (IEThingWith (L _ t) _) = declWith t
+    lookupExport (IEThingWith (L _ t) _ _) = declWith t
     lookupExport (IEModuleContents (L _ m)) =
       moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
     lookupExport (IEGroup lev docStr)  = return $
@@ -790,7 +791,7 @@ extractDecl name mdl decl
                           , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
                           , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
                           , L _ n <- ns
-                          , n == name
+                          , selectorFieldOcc n == name
                       ]
         in case matches of
           [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
@@ -821,11 +822,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
 
 extractRecSel nm mdl t tvs (L _ con : rest) =
   case con_details con of
-    RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
-      L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
+    RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
+      L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
     _ -> extractRecSel nm mdl t tvs rest
  where
-  matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ]
+  matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
+  matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
+                                 , L l n <- ns, selectorFieldOcc n == nm ]
   data_ty
     | ResTyGADT _ ty <- con_res con = ty
     | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index b8fac887..033246a8 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -273,7 +273,7 @@ renameLContext (L loc context) = do
   return (L loc context')
 
 renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)
-renameWildCardInfo (AnonWildCard  _)    = pure (AnonWildCard PlaceHolder)
+renameWildCardInfo (AnonWildCard  name) = AnonWildCard  <$> rename name
 renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name
 
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
@@ -411,11 +411,15 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
 
 renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
 renameConDeclFieldField (L l (ConDeclField names t doc)) = do
-  names' <- mapM renameL names
+  names' <- mapM renameLFieldOcc names
   t'   <- renameLType t
   doc' <- mapM renameLDocHsSyn doc
   return $ L l (ConDeclField names' t' doc')
 
+renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName)
+renameLFieldOcc (L l (FieldOcc lbl sel)) = do
+  sel' <- rename sel
+  return $ L l (FieldOcc lbl sel')
 
 renameSig :: Sig Name -> RnM (Sig DocName)
 renameSig sig = case sig of
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 5737c77c..33ab9592 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -281,7 +281,6 @@ data DocName
      -- documentation, as far as Haddock knows.
   deriving Eq
 
-
 instance NamedThing DocName where
   getName (Documented name _) = name
   getName (Undocumented name) = name
@@ -562,8 +561,9 @@ instance Monad ErrMsgGhc where
 type instance PostRn DocName NameSet  = PlaceHolder
 type instance PostRn DocName Fixity   = PlaceHolder
 type instance PostRn DocName Bool     = PlaceHolder
-type instance PostRn DocName Name     = PlaceHolder
+type instance PostRn DocName Name     = DocName
 type instance PostRn DocName [Name]   = PlaceHolder
+type instance PostRn DocName DocName  = DocName
 
 type instance PostTc DocName Kind     = PlaceHolder
 type instance PostTc DocName Type     = PlaceHolder
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 4fed3a1e..c2e1b09a 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -63,6 +63,7 @@ import Haddock.GhcUtils
 
 import GHC
 import Name
+import HsTypes (selectorFieldOcc)
 
 import Control.Monad ( liftM )
 import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
@@ -162,7 +163,9 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
           -- it's the best we can do.
         InfixCon _ _ -> Just d
       where
-        field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns
+        field_avail :: LConDeclField Name -> Bool
+        field_avail (L _ (ConDeclField fs _ _))
+            = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs
         field_types flds = [ t | ConDeclField _ t _ <- flds ]
 
     keep _ = Nothing