Merge branch 'ghc-head' with 'ghc-8.4'

1 files changed, 340 insertions, 188 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 815ecee9..3fbe6eaf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,24 +39,34 @@ import GHC.Exts
 import Name
 import BooleanFormula
 import RdrName ( rdrNameOcc )
-
-ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI
-       -> [(HsDecl DocNameI, DocForDecl DocName)]
-       -> DocForDecl DocName ->  [DocInstance DocNameI] -> [(DocName, Fixity)]
-       -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode
-       -> Maybe Package -> Qualification -> Html
+import Outputable ( panic )
+
+-- | Pretty print a declaration
+ppDecl :: Bool                                     -- ^ print summary info only
+       -> LinksInfo                                -- ^ link information
+       -> LHsDecl DocNameI                         -- ^ declaration to print
+       -> [(HsDecl DocNameI, DocForDecl DocName)]  -- ^ relevant pattern synonyms
+       -> DocForDecl DocName                       -- ^ documentation for this decl
+       -> [DocInstance DocNameI]                   -- ^ relevant instances
+       -> [(DocName, Fixity)]                      -- ^ relevant fixities
+       -> [(DocName, DocForDecl DocName)]          -- ^ documentation for all decls
+       -> Splice
+       -> Unicode                                  -- ^ unicode output
+       -> Maybe Package
+       -> Qualification
+       -> Html
 ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of
-  TyClD (FamDecl d)            -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual
-  TyClD d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
-  TyClD d@(SynDecl {})         -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
-  TyClD d@(ClassDecl {})       -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
-  SigD (TypeSig lnames lty)    -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
+  TyClD _ (FamDecl _ d)          -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual
+  TyClD _ d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
+  TyClD _ d@(SynDecl {})         -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
+  TyClD _ d@(ClassDecl {})       -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
+  SigD _ (TypeSig _ lnames lty)  -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
                                          (hsSigWcType lty) fixities splice unicode pkg qual
-  SigD (PatSynSig lnames ty)   -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
-                                         ty fixities splice unicode pkg qual
-  ForD d                       -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
-  InstD _                      -> noHtml
-  DerivD _                     -> noHtml
+  SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
+                                         (hsSigType lty) fixities splice unicode pkg qual
+  ForD _ d                       -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
+  InstD _ _                      -> noHtml
+  DerivD _ _                     -> noHtml
   _                            -> error "declaration not supported by ppDecl"
 
 
@@ -76,21 +86,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual =
   where
     pp_typ = ppLType unicode qual HideEmptyContexts typ
 
-ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
-             [Located DocName] -> LHsSigType DocNameI ->
-             [(DocName, Fixity)] ->
-             Splice -> Unicode -> Maybe Package -> Qualification -> Html
-ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice
-          unicode pkg qual
-  | summary = pref1
-  | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual)
-                +++ docSection Nothing pkg qual doc
+-- | Pretty print a pattern synonym
+ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
+          -> [Located DocName]     -- ^ names of patterns in declaration
+          -> LHsType DocNameI      -- ^ type of patterns in declaration
+          -> [(DocName, Fixity)]
+          -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =
+  ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities
+            (unLoc typ, pp_typ) splice unicode pkg qual (patSigContext typ)
   where
-    pref1 = hsep [ keyword "pattern"
-                 , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames
-                 , dcolon unicode
-                 , ppPatSigType unicode qual (hsSigType typ)
-                 ]
+    pp_typ = ppPatSigType unicode qual typ
+
 
 ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
              [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
@@ -99,7 +106,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
           splice unicode pkg qual emptyCtxts =
   ppTypeOrFunSig summary links loc docnames typ doc
     ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
-    , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
+    , (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
     , dcolon unicode
     )
     splice unicode pkg qual emptyCtxts
@@ -118,36 +125,72 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
                splice unicode pkg qual emptyCtxts
   | summary = pref1
   | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc
-  | otherwise = topDeclElem links loc splice docnames pref2 +++
-      subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc
+  | otherwise = topDeclElem links loc splice docnames pref2
+                  +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts)
+                  +++ docSection curName pkg qual doc
   where
     curName = getName <$> listToMaybe docnames
+
+
+-- This splits up a type signature along `->` and adds docs (when they exist) to
+-- the arguments.
+--
+-- If one passes in a list of the available subdocs, any top-level `HsRecTy`
+-- found will be expanded out into their fields.
+ppSubSigLike :: Unicode -> Qualification
+             -> HsType DocNameI                  -- ^ type signature
+             -> FnArgsDoc DocName                -- ^ docs to add
+             -> [(DocName, DocForDecl DocName)]  -- ^ all subdocs (useful when
+                                                 -- we expand an `HsRecTy`)
+             -> Html -> HideEmptyContexts -> [SubDecl]
+ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
+  where
     argDoc n = Map.lookup n argDocs
 
     do_largs n leader (L _ t) = do_args n leader t
 
     do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
-    do_args n leader (HsForAllTy tvs ltype)
+    do_args n leader (HsForAllTy _ tvs ltype)
       = do_largs n leader' ltype
       where
         leader' = leader <+> ppForAll tvs unicode qual
 
-    do_args n leader (HsQualTy lctxt ltype)
+    do_args n leader (HsQualTy _ lctxt ltype)
       | null (unLoc lctxt)
       = do_largs n leader ltype
       | otherwise
       = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
         : do_largs n (darrow unicode) ltype
 
-    do_args n leader (HsFunTy lt r)
+    do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
+      = [ (ldr <+> html, mdoc, subs)
+        | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
+        , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field
+        ]
+        ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
+
+    do_args n leader (HsFunTy _ lt r)
       = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
         : do_largs (n+1) (arrow unicode) r
+
     do_args n leader t
       = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])]
 
+
+    -- FIXME: this should be done more elegantly
+    --
+    -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from
+    -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode
+    -- mode since `->` and `::` are rendered as single characters.
+    gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ","
+    gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}"
+    gadtOpen = toHtml "{"
+
+
+
 ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html
 ppForAll tvs unicode qual =
-  case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of
+  case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of
     [] -> noHtml
     ts -> forallSymbol unicode <+> hsep ts +++ dot
   where ppKTv n k = parens $
@@ -186,7 +229,7 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
 ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
       -> ForeignDecl DocNameI -> [(DocName, Fixity)]
       -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
+ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
       splice unicode pkg qual
   = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual
 ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -279,12 +322,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
      ClosedTypeFamily _ -> keyword "where ..."
      _                  -> mempty
   )
+ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader"
 
 ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html
 ppResultSig result unicode qual = case result of
-    NoSig               -> noHtml
-    KindSig kind        -> dcolon unicode  <+> ppLKind unicode qual kind
-    TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+    NoSig _               -> noHtml
+    KindSig _ kind        -> dcolon unicode  <+> ppLKind unicode qual kind
+    TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+    XFamilyResultSig _    -> panic "haddock:ppResultSig"
 
 ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
                      -> Html
@@ -330,6 +375,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
           <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
         , Nothing, [] )
+    ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam"
+    ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam"
 
 
 
@@ -363,6 +410,7 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =
 ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html
 ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
   ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)
+ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars"
 
 -- | Print a newtype / data binder and its variables
 ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
@@ -477,7 +525,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
 
             [ ppFunSig summary links loc doc names (hsSigWcType typ)
                        [] splice unicode pkg qual
-              | L _ (TypeSig lnames typ) <- sigs
+              | L _ (TypeSig _ lnames typ) <- sigs
               , let doc = lookupAnySubdoc (head names) subdocs
                     names = map unLoc lnames ]
               -- FIXME: is taking just the first name ok? Is it possible that
@@ -525,7 +573,7 @@ ppClassDecl summary links instances fixities loc d subdocs
 
     methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ)
                                       subfixs splice unicode pkg qual
-                           | L _ (ClassOpSig _ lnames typ) <- lsigs
+                           | L _ (ClassOpSig _ _ lnames typ) <- lsigs
                            , name <- map unLoc lnames
                            , let doc = lookupAnySubdoc name subdocs
                                  subfixs = [ f | f@(n',_) <- fixities
@@ -534,15 +582,15 @@ ppClassDecl summary links instances fixities loc d subdocs
                            -- N.B. taking just the first name is ok. Signatures with multiple names
                            -- are expanded so that each name gets its own signature.
 
-    minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
+    minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of
       -- Miminal complete definition = every shown method
       And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
-                   sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns]
+                   sort [getName n | TypeSig _ ns _ <- sigs, L _ n <- ns]
         -> noHtml
 
       -- Minimal complete definition = the only shown method
       Var (L _ n) : _ | [getName n] ==
-                        [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]
+                        [getName n' | L _ (TypeSig _ ns _) <- lsigs, L _ n' <- ns]
         -> noHtml
 
       -- Minimal complete definition = nothing
@@ -645,7 +693,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
               -> [Sig DocNameI]
               -> [Html]
 ppInstanceSigs links splice unicode qual sigs = do
-    TypeSig lnames typ <- sigs
+    TypeSig _ lnames typ <- sigs
     let names = map unLoc lnames
         L _ rtyp = hsSigWcType typ
     -- Instance methods signatures are synified and thus don't have a useful
@@ -706,21 +754,27 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
     isH98     = case unLoc (head cons) of
                   ConDeclH98 {} -> True
                   ConDeclGADT{} -> False
+                  XConDecl{}    -> False
 
     pats1 = [ hsep [ keyword "pattern"
                    , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
                    , dcolon unicode
                    , ppPatSigType unicode qual (hsSigType typ)
                    ]
-            | (SigD (PatSynSig lnames typ),_) <- pats
+            | (SigD _ (PatSynSig _ lnames typ),_) <- pats
             ]
 
 
-ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] ->
-              [(DocName, DocForDecl DocName)] ->
-              SrcSpan -> Documentation DocName -> TyClDecl DocNameI ->
-              [(HsDecl DocNameI, DocForDecl DocName)] ->
-              Splice -> Unicode -> Maybe Package -> Qualification -> Html
+-- | Pretty-print a data declaration
+ppDataDecl :: Bool -> LinksInfo
+           -> [DocInstance DocNameI]                  -- ^ relevant instances
+           -> [(DocName, Fixity)]                     -- ^ relevant fixities
+           -> [(DocName, DocForDecl DocName)]         -- ^ all decl documentation
+           -> SrcSpan
+           -> Documentation DocName                   -- ^ this decl's documentation
+           -> TyClDecl DocNameI                       -- ^ this decl
+           -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns
+           -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
 ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
            splice unicode pkg qual
 
@@ -733,6 +787,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
     isH98     = case unLoc (head cons) of
                   ConDeclH98 {} -> True
                   ConDeclGADT{} -> False
+                  XConDecl{}    -> False
 
     header_ = topDeclElem links loc splice [docname] $
              ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
@@ -749,25 +804,20 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
       [ ppSideBySideConstr subdocs subfixs unicode pkg qual c
       | c <- cons
       , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
-                                     (map unLoc (getConNames (unLoc c)))) fixities
+                                            (map unLoc (getConNames (unLoc c)))) fixities
       ]
 
     patternBit = subPatterns pkg qual
-      [ (hsep [ keyword "pattern"
-              , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
-              , dcolon unicode
-              , ppPatSigType unicode qual (hsSigType typ)
-              ] <+> ppFixities subfixs qual
-        ,combineDocumentation (fst d), [])
-      | (SigD (PatSynSig lnames typ),d) <- pats
-      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities
+      [ ppSideBySidePat subfixs unicode qual lnames typ d
+      | (SigD _ (PatSynSig _ lnames typ), d) <- pats
+      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
+                                            (map unLoc lnames)) fixities
       ]
 
     instancesBit = ppInstances links (OriginData docname) instances
         splice unicode pkg qual
 
 
-
 ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html
 ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
   where
@@ -777,121 +827,183 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
 -- returns three pieces: header, body, footer so that header & footer can be
 -- incorporated into the declaration
 ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html)
-ppShortConstrParts summary dataInst con unicode qual = case con of
-  ConDeclH98{} -> case con_details con of
-    PrefixCon args ->
-      (header_ unicode qual +++ hsep (ppOcc
-            : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml)
-    RecCon (L _ fields) ->
-      (header_ unicode qual +++ ppOcc <+> char '{',
-       doRecordFields fields,
-       char '}')
-    InfixCon arg1 arg2 ->
-      (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1,
-            ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2],
-       noHtml, noHtml)
-
-  ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml)
-
-  where
-    resTy = hsib_body (con_type con)
-
-    doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))
-
-    header_  = ppConstrHdr forall_ tyVars context
-    occ        = map (nameOccName . getName . unLoc) $ getConNames con
-
-    ppOcc      = case occ of
-      [one] -> ppBinder summary one
-      _     -> hsep (punctuate comma (map (ppBinder summary) occ))
+ppShortConstrParts summary dataInst con unicode qual
+  = case con of
+      ConDeclH98{ con_args = det
+                , con_ex_tvs = vars
+                , con_mb_cxt = cxt
+                } -> let tyVars = map (getName . hsLTyVarName) vars
+                         context = unLoc (fromMaybe (noLoc []) cxt)
+                         forall_ = False
+                         header_ = ppConstrHdr forall_ tyVars context unicode qual
+                     in case det of
+
+        -- Prefix constructor, e.g. 'Just a'
+        PrefixCon args ->
+          ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args)
+          , noHtml
+          , noHtml
+          )
 
-    ppOccInfix = case occ of
-      [one] -> ppBinderInfix summary one
-      _     -> hsep (punctuate comma (map (ppBinderInfix summary) occ))
+        -- Record constructor, e.g. 'Identity { runIdentity :: a }'
+        RecCon (L _ fields) ->
+          ( header_ +++ ppOcc <+> char '{'
+          , shortSubDecls dataInst [ ppShortField summary unicode qual field
+                                   | L _ field <- fields
+                                   ]
+          , char '}'
+          )
 
-    ltvs     = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)
-    tyVars   = tyvarNames ltvs
-    lcontext = fromMaybe (noLoc []) (con_cxt con)
-    context  = unLoc lcontext
-    forall_  = False
+        -- Infix constructor, e.g. 'a :| [a]'
+        InfixCon arg1 arg2 ->
+          ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1
+                             , ppOccInfix
+                             , ppLParendType unicode qual HideEmptyContexts arg2
+                             ]
+          , noHtml
+          , noHtml
+          )
 
+      -- GADT constructor, e.g. 'Foo :: Int -> Foo'
+      ConDeclGADT {} ->
+          ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ]
+          , noHtml
+          , noHtml
+          )
+      XConDecl {} -> panic "haddock:ppShortConstrParts"
 
--- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode
-            -> Qualification -> Html
-ppConstrHdr forall_ tvs ctxt unicode qual
- = (if null tvs then noHtml else ppForall)
-   +++
-   (if null ctxt then noHtml
-    else ppContextNoArrow ctxt unicode qual HideEmptyContexts
-         <+> darrow unicode +++ toHtml " ")
   where
-    ppForall | forall_   = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)
-                           <+> toHtml ". "
-             | otherwise = noHtml
+    occ        = map (nameOccName . getName . unLoc) $ getConNames con
+    ppOcc      = hsep (punctuate comma (map (ppBinder summary) occ))
+    ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ))
 
+
+-- | Pretty print an expanded constructor
 ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
-                   -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl
+                   -> Unicode -> Maybe Package -> Qualification
+                   -> LConDecl DocNameI -- ^ constructor declaration to print
+                   -> SubDecl
 ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
- = (decl, mbDoc, fieldPart)
+ = ( decl       -- Constructor header (name, fixity)
+   , mbDoc      -- Docs on the whole constructor
+   , fieldPart  -- Information on the fields (or arguments, if they have docs)
+   )
  where
-    decl = case con of
-      ConDeclH98{} -> case con_details con of
-        PrefixCon args ->
-          hsep ((header_ +++ ppOcc)
-            : map (ppLParendType unicode qual HideEmptyContexts) args)
-          <+> fixity
+    -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)
+    aConName = unLoc (head (getConNames con))
 
-        RecCon _ -> header_ +++ ppOcc <+> fixity
+    fixity   = ppFixities fixities qual
+    occ      = map (nameOccName . getName . unLoc) $ getConNames con
 
-        InfixCon arg1 arg2 ->
-          hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1,
-            ppOccInfix,
-            ppLParendType unicode qual HideEmptyContexts arg2]
-          <+> fixity
+    ppOcc      = hsep (punctuate comma (map (ppBinder False) occ))
+    ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))
 
-      ConDeclGADT{} -> doGADTCon resTy
+    -- Extract out the map of of docs corresponding to the constructors arguments
+    argDocs = maybe Map.empty snd (lookup aConName subdocs)
+    hasArgDocs = not $ Map.null argDocs
 
-    resTy = hsib_body (con_type con)
+    decl = case con of
+      ConDeclH98{ con_args = det
+                , con_ex_tvs = vars
+                , con_mb_cxt = cxt
+                } -> let tyVars = map (getName . hsLTyVarName) vars
+                         context = unLoc (fromMaybe (noLoc []) cxt)
+                         forall_ = False
+                         header_ = ppConstrHdr forall_ tyVars context unicode qual
+                     in case det of
+        -- Prefix constructor, e.g. 'Just a'
+        PrefixCon args
+          | hasArgDocs -> header_ +++ ppOcc <+> fixity
+          | otherwise -> hsep [ header_ +++ ppOcc
+                              , hsep (map (ppLParendType unicode qual HideEmptyContexts) args)
+                              , fixity
+                              ]
+
+        -- Record constructor, e.g. 'Identity { runIdentity :: a }'
+        RecCon _ -> header_ +++ ppOcc <+> fixity
+
+        -- Infix constructor, e.g. 'a :| [a]'
+        InfixCon arg1 arg2
+          | hasArgDocs -> header_ +++ ppOcc <+> fixity
+          | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1
+                              , ppOccInfix
+                              , ppLParendType unicode qual HideEmptyContexts arg2
+                              , fixity
+                              ]
+
+      -- GADT constructor, e.g. 'Foo :: Int -> Foo'
+      ConDeclGADT{}
+          | hasArgDocs || not (null fieldPart) -> ppOcc <+> fixity
+          | otherwise -> hsep [ ppOcc
+                              , dcolon unicode
+                              -- ++AZ++ make this prepend "{..}" when it is a record style GADT
+                              , ppLType unicode qual HideEmptyContexts (getGADTConType con)
+                              , fixity
+                              ]
+      XConDecl{} -> panic "haddock:ppSideBySideConstr"
+
+    fieldPart = case (con, getConArgs con) of
+        -- Record style GADTs
+        (ConDeclGADT{}, RecCon _)            -> [ doConstrArgsWithDocs [] ]
+
+        -- Regular record declarations
+        (_, RecCon (L _ fields))             -> [ doRecordFields fields ]
+
+        -- Any GADT or a regular H98 prefix data constructor
+        (_, PrefixCon args)     | hasArgDocs -> [ doConstrArgsWithDocs args ]
+
+        -- An infix H98 data constructor
+        (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
 
-    fieldPart = case getConDetails con of
-        RecCon (L _ fields) -> [doRecordFields fields]
         _ -> []
 
     doRecordFields fields = subFields pkg qual
       (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
 
-    doGADTCon :: Located (HsType DocNameI) -> Html
-    doGADTCon ty = ppOcc <+> dcolon unicode
-        -- ++AZ++ make this prepend "{..}" when it is a record style GADT
-        <+> ppLType unicode qual HideEmptyContexts ty
-        <+> fixity
-
-    fixity  = ppFixities fixities qual
-    header_ = ppConstrHdr forall_ tyVars context unicode qual
-    occ       = map (nameOccName . getName . unLoc) $ getConNames con
-
-    ppOcc     = case occ of
-      [one] -> ppBinder False one
-      _     -> hsep (punctuate comma (map (ppBinder False) occ))
+    doConstrArgsWithDocs args = subFields pkg qual $ case con of
+      ConDeclH98{} ->
+        [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])
+        | (i, arg) <- zip [0..] args
+        , let mdoc = Map.lookup i argDocs
+        ]
+      ConDeclGADT{} ->
+        ppSubSigLike unicode qual (unLoc (getGADTConType con))
+                     argDocs subdocs (dcolon unicode) HideEmptyContexts
+      XConDecl{} -> panic "haddock:doConstrArgsWithDocs"
 
-    ppOccInfix = case occ of
-      [one] -> ppBinderInfix False one
-      _     -> hsep (punctuate comma (map (ppBinderInfix False) occ))
-
-    tyVars  = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))
-    context = unLoc (fromMaybe (noLoc []) (con_cxt con))
-    forall_ = False
     -- don't use "con_doc con", in case it's reconstructed from a .hi file,
     -- or also because we want Haddock to do the doc-parsing, not GHC.
     mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>=
             combineDocumentation . fst
 
 
+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
+ppConstrHdr :: Bool               -- ^ print explicit foralls
+            -> [Name]             -- ^ type variables
+            -> HsContext DocNameI -- ^ context
+            -> Unicode -> Qualification -> Html
+ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
+  where
+    ppForall
+      | null tvs || not forall_ = noHtml
+      | otherwise = forallSymbol unicode
+                      <+> hsep (map (ppName Prefix) tvs)
+                      <+> toHtml ". "
+
+    ppCtxt
+      | null ctxt = noHtml
+      | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts
+                      <+> darrow unicode +++ toHtml " "
+
+
+-- | Pretty-print a record field
 ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
                   -> ConDeclField DocNameI -> SubDecl
-ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
-  ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
+ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
+  ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field)
+                          | L _ name <- names
+                          , let field = (unLoc . rdrNameFieldOcc) name
+                          ])
       <+> dcolon unicode
       <+> ppLType unicode qual HideEmptyContexts ltype
   , mbDoc
@@ -900,13 +1012,49 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
   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 (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+    mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"
 
 
 ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
-ppShortField summary unicode qual (ConDeclField names ltype _)
+ppShortField summary unicode qual (ConDeclField _ names ltype _)
   = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
     <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
+ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField"
+
+
+-- | Pretty print an expanded pattern (for bundled patterns)
+ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification
+                   -> [Located DocName]    -- ^ pattern name(s)
+                   -> LHsSigType DocNameI  -- ^ type of pattern(s)
+                   -> DocForDecl DocName   -- ^ doc map
+                   -> SubDecl
+ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
+  ( decl
+  , combineDocumentation doc
+  , fieldPart
+  )
+  where
+    hasArgDocs = not $ Map.null argDocs
+    fixity = ppFixities fixities qual
+    ppOcc = hsep (punctuate comma (map (ppBinder False . getOccName) lnames))
+
+    decl | hasArgDocs = keyword "pattern" <+> ppOcc <+> fixity
+         | otherwise = hsep [ keyword "pattern"
+                            , ppOcc
+                            , dcolon unicode
+                            , ppPatSigType unicode qual (hsSigType typ)
+                            , fixity
+                            ]
+
+    fieldPart
+      | not hasArgDocs = []
+      | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy)
+                                                        argDocs [] (dcolon unicode)
+                                                        emptyCtxt) ]
+
+    patTy = hsSigType typ
+    emptyCtxt = patSigContext patTy
 
 
 -- | Print the LHS of a data\/newtype declaration.
@@ -987,11 +1135,12 @@ ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual e
 ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts
 
 ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
-ppHsTyVarBndr _       qual (UserTyVar (L _ name)) =
+ppHsTyVarBndr _       qual (UserTyVar _ (L _ name)) =
     ppDocName qual Raw False name
-ppHsTyVarBndr unicode qual (KindedTyVar name kind) =
+ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =
     parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
             ppLKind unicode qual kind)
+ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr"
 
 ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
 ppLKind unicode qual y = ppKind unicode qual (unLoc y)
@@ -999,29 +1148,32 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
 ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
 ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts
 
-ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
-ppPatSigType unicode qual typ =
-  let emptyCtxts =
-        if hasNonEmptyContext typ && isFirstContextEmpty typ
-          then ShowEmptyToplevelContexts
-          else HideEmptyContexts
-  in ppLType unicode qual emptyCtxts typ
+patSigContext :: LHsType name -> HideEmptyContexts
+patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts
+                  | otherwise = HideEmptyContexts
   where
     hasNonEmptyContext :: LHsType name -> Bool
     hasNonEmptyContext t =
       case unLoc t of
-        HsForAllTy _ s -> hasNonEmptyContext s
-        HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
-        HsFunTy _ s -> hasNonEmptyContext s
+        HsForAllTy _ _ s -> hasNonEmptyContext s
+        HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+        HsFunTy _ _ s    -> hasNonEmptyContext s
         _ -> False
     isFirstContextEmpty :: LHsType name -> Bool
     isFirstContextEmpty t =
       case unLoc t of
-        HsForAllTy _ s -> isFirstContextEmpty s
-        HsQualTy cxt _ -> null (unLoc cxt)
-        HsFunTy _ s -> isFirstContextEmpty s
+        HsForAllTy _ _ s -> isFirstContextEmpty s
+        HsQualTy _ cxt _ -> null (unLoc cxt)
+        HsFunTy _ _ s    -> isFirstContextEmpty s
         _ -> False
 
+
+-- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in
+-- the right 'HideEmptyContext' value)
+ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
+ppPatSigType unicode qual typ =
+  let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
+
 ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
 ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
 
@@ -1030,50 +1182,50 @@ ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
 
 
 ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode qual emptyCtxts
   = maybeParen ctxt_prec pREC_FUN $
     ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
 
-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode qual emptyCtxts
   = maybeParen ctxt_prec pREC_FUN $
     ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
 
 -- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _
+ppr_mono_ty _ (HsTyVar _ _ (L _ name)) True _ _
   | getOccString (getName name) == "*"    = toHtml "★"
   | getOccString (getName name) == "(->)" = toHtml "(→)"
 
-ppr_mono_ty _         (HsBangTy b ty)     u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
-ppr_mono_ty _         (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
-ppr_mono_ty _         (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
-ppr_mono_ty _         (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)
-ppr_mono_ty _         (HsKindSig ty kind) u q e =
+ppr_mono_ty _         (HsBangTy _ b ty)     u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
+ppr_mono_ty _         (HsTyVar _ _ (L _ name)) _ q _ = ppDocName q Prefix True name
+ppr_mono_ty ctxt_prec (HsFunTy _ ty1 ty2)   u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
+ppr_mono_ty _         (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _         (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _         (HsKindSig _ ty kind) u q e =
     parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind)
-ppr_mono_ty _         (HsListTy ty)       u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
-ppr_mono_ty _         (HsPArrTy ty)       u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
-ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ =
+ppr_mono_ty _         (HsListTy _ ty)       u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty _         (HsPArrTy _ ty)       u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty ctxt_prec (HsIParamTy _ (L _ n) ty) u q _ =
     maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts
 ppr_mono_ty _         (HsSpliceTy {})     _ _ _ = error "ppr_mono_ty HsSpliceTy"
 ppr_mono_ty _         (HsRecTy {})        _ _ _ = toHtml "{..}"
        -- Can now legally occur in ConDeclGADT, the output here is to provide a
        -- placeholder in the signature, which is followed by the field
        -- declarations.
-ppr_mono_ty _         (HsCoreTy {})       _ _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _         (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
-ppr_mono_ty _         (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _         (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _         (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _         (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
 ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
 ppr_mono_ty _         (HsAppsTy {})       _ _ _ = error "ppr_mono_ty HsAppsTy"
 
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _
+ppr_mono_ty ctxt_prec (HsEqTy _ ty1 ty2) unicode qual _
   = maybeParen ctxt_prec pREC_CTX $
     ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
 
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _
+ppr_mono_ty ctxt_prec (HsAppTy _ fun_ty arg_ty) unicode qual _
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts]
 
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _
+ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode qual _
   = maybeParen ctxt_prec pREC_FUN $
     ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
   where
@@ -1084,15 +1236,15 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _
         | otherwise = ppr_op'
     ppr_op' = ppLDocName qual Infix op
 
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode qual emptyCtxts
 --  = parens (ppr_mono_lty pREC_TOP ty)
   = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
 
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode qual emptyCtxts
   = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
 
 ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
-ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n
+ppr_mono_ty _ (HsTyLit _ n) _ _ _ = ppr_tylit n
 
 ppr_tylit :: HsTyLit -> Html
 ppr_tylit (HsNumTy _ n) = toHtml (show n)