Follow API changes in D426

Signed-off-by: Austin Seipp <aseipp@pobox.com>

2 files changed, 31 insertions, 26 deletions

diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 551e6e7e..afff7e10 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -194,8 +194,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
 
 parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
 parseWarning dflags gre w = force $ case w of
-  DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)
-  WarningTxt    msg -> format "Warning: "    (concatFS msg)
+  DeprecatedTxt msg -> format "Deprecated: " (concatFS $ map unLoc msg)
+  WarningTxt    msg -> format "Warning: "    (concatFS $ map unLoc msg)
   where
     format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
                   . processDocString dflags gre $ HsDocString xs
@@ -328,11 +328,12 @@ subordinates instMap decl = case decl of
     dataSubs dd = constrs ++ fields
       where
         cons = map unL $ (dd_cons dd)
-        constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
-                  | c <- cons ]
+        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)
                   | RecCon flds <- map con_details cons
-                  , ConDeclField n _ doc <- flds ]
+                  , L _ (ConDeclField ns _ doc) <- flds
+                  , n <- ns ]
 
 -- | Extract function argument docs from inside types.
 typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -374,7 +375,8 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
 -- | Extract a map of fixity declarations only
 mkFixMap :: HsGroup Name -> FixMap
 mkFixMap group_ = M.fromList [ (n,f)
-                             | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]
+                             | L _ (FixitySig ns f) <- hs_fixds group_,
+                               L _ n <- ns ]
 
 
 -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
@@ -490,11 +492,11 @@ mkExportItems
     Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
     Just exports -> liftM concat $ mapM lookupExport exports
   where
-    lookupExport (IEVar x)             = declWith x
-    lookupExport (IEThingAbs t)        = declWith t
-    lookupExport (IEThingAll t)        = declWith t
-    lookupExport (IEThingWith t _)     = declWith t
-    lookupExport (IEModuleContents m)  =
+    lookupExport (IEVar (L _ x))         = declWith x
+    lookupExport (IEThingAbs t)          = declWith t
+    lookupExport (IEThingAll (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 $
       return . ExportGroup lev "" $ processDocString dflags gre docStr
@@ -772,7 +774,8 @@ extractDecl name mdl decl
       InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
         let matches = [ d | L _ d <- insts
                           , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
-                          , ConDeclField { cd_fld_name = L _ n } <- rec
+                          , ConDeclField { cd_fld_names = ns } <- map unLoc rec
+                          , L _ n <- ns
                           , n == name
                       ]
         in case matches of
@@ -804,11 +807,11 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
 
 extractRecSel nm mdl t tvs (L _ con : rest) =
   case con_details con of
-    RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
+    RecCon fields | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
       L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))
     _ -> extractRecSel nm mdl t tvs rest
  where
-  matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
+  matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc 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/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index aa1a170f..566e3acb 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -260,7 +260,6 @@ renameLContext (L loc context) = do
   context' <- mapM renameLType context
   return (L loc context')
 
-
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
 renameInstHead (className, k, types, rest) = do
   className' <- rename className
@@ -365,19 +364,22 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
                        , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
 
 renameCon :: ConDecl Name -> RnM (ConDecl DocName)
-renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
+renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
                         , con_cxt = lcontext, con_details = details
                         , con_res = restype, con_doc = mbldoc }) = do
-      lname'    <- renameL lname
+      lnames'   <- mapM renameL lnames
       ltyvars'  <- renameLTyVarBndrs ltyvars
       lcontext' <- renameLContext lcontext
       details'  <- renameDetails details
       restype'  <- renameResType restype
       mbldoc'   <- mapM renameLDocHsSyn mbldoc
-      return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
+      return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext'
                    , con_details = details', con_res = restype', con_doc = mbldoc' })
+
   where
-    renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields
+    renameDetails (RecCon fields) = do
+      fields' <- mapM renameConDeclFieldField fields
+      return (RecCon fields')
     renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
     renameDetails (InfixCon a b) = do
       a' <- renameLType a
@@ -388,12 +390,12 @@ renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
     renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
 
 
-renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)
-renameConDeclFieldField (ConDeclField name t doc) = do
-  name' <- renameL name
+renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
+renameConDeclFieldField (L l (ConDeclField names t doc)) = do
+  names' <- mapM renameL names
   t'   <- renameLType t
   doc' <- mapM renameLDocHsSyn doc
-  return (ConDeclField name' t' doc')
+  return $ L l (ConDeclField names' t' doc')
 
 
 renameSig :: Sig Name -> RnM (Sig DocName)
@@ -409,9 +411,9 @@ renameSig sig = case sig of
     lprov' <- renameLContext lprov
     lty' <- renameLType lty
     return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
-  FixSig (FixitySig lname fixity) -> do
-    lname' <- renameL lname
-    return $ FixSig (FixitySig lname' fixity)
+  FixSig (FixitySig lnames fixity) -> do
+    lnames' <- mapM renameL lnames
+    return $ FixSig (FixitySig lnames' fixity)
   MinimalSig s -> MinimalSig <$> traverse renameL s
   -- we have filtered out all other kinds of signatures in Interface.Create
   _ -> error "expected TypeSig"