Merge branch 'ghc-head' into ghc-9.0

1 files changed, 84 insertions, 57 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 0b0050df..de37e42a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -63,9 +63,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
   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
+                                         (dropWildCards lty) fixities splice unicode pkg qual
   SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
-                                         (hsSigTypeI lty) fixities splice unicode pkg qual
+                                         lty fixities splice unicode pkg qual
   ForD _ d                       -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
   InstD _ _                      -> noHtml
   DerivD _ _                     -> noHtml
@@ -73,25 +73,25 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
 
 
 ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
-             [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
+             [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
              Splice -> Unicode -> Maybe Package -> Qualification -> Html
 ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
   ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities
            splice unicode pkg qual
 
 ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
-            [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
+            [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
             Splice -> Unicode -> Maybe Package -> Qualification -> Html
 ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual =
   ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ)
             splice unicode pkg qual HideEmptyContexts
   where
-    pp_typ = ppLType unicode qual HideEmptyContexts typ
+    pp_typ = ppLSigType unicode qual HideEmptyContexts typ
 
 -- | 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
+          -> LHsSigType 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 =
@@ -102,7 +102,7 @@ ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =
 
 
 ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
-             [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
+             [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) ->
              Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html
 ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
           splice unicode pkg qual emptyCtxts =
@@ -119,7 +119,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
       | otherwise = html <+> ppFixities fixities qual
 
 
-ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI
                -> DocForDecl DocName -> (Html, Html, Html)
                -> Splice -> Unicode -> Maybe Package -> Qualification
                -> HideEmptyContexts -> Html
@@ -140,15 +140,24 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
 -- 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
+             -> HsSigType 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
+ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ
   where
+    do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl]
+    do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =
+      case outer_bndrs of
+        HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype
+        HsOuterImplicit{}                  -> do_largs n leader          ltype
+      where
+        leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs)
+
     argDoc n = Map.lookup n argDocs
 
+    do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl]
     do_largs n leader (L _ t) = do_args n leader t
 
     do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
@@ -222,7 +231,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
       -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
 ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
       splice unicode pkg qual
-  = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual
+  = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual
 ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
 
 
@@ -233,13 +242,14 @@ ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
 ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
                                                 , tcdRhs = ltype })
         splice unicode pkg qual
-  = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
+  = ppTypeOrFunSig summary links loc [name] sig_type doc
                    (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
                    splice unicode pkg qual ShowEmptyToplevelContexts
   where
+    sig_type = mkHsImplicitSigTypeI ltype
     hdr  = hsep ([keyword "type", ppBinder summary occ]
                  ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
-    full = hdr <+> equals <+> ppPatSigType unicode qual ltype
+    full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type)
     occ  = nameOccName . getName $ name
     fixs
       | summary   = noHtml
@@ -253,15 +263,14 @@ ppTypeSig summary nms pp_ty unicode =
   where
     htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
 
-
 ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
-            -> [DocName] -> HsType DocNameI
+            -> [DocName] -> HsSigType DocNameI
             -> Html
 ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
     topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
   where
     topDeclElem' = topDeclElem links loc splice
-    ppTyp = ppType unicode qual emptyCtxts typ
+    ppTyp = ppSigType unicode qual emptyCtxts typ
     occNames = map getOccName names
 
 
@@ -301,9 +310,9 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
 
     -- Individual equation of a closed type family
     ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl
-    ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
-                                            , feqn_rhs = rhs
-                                            , feqn_pats = ts } })
+    ppFamDeclEqn (FamEqn { feqn_tycon = L _ n
+                         , feqn_rhs = rhs
+                         , feqn_pats = ts })
       = ( ppAppNameTypeArgs n ts unicode qual
           <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
         , Nothing
@@ -497,7 +506,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
 
                 -- ToDo: add associated type defaults
 
-            [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ)
+            [ ppFunSig summary links loc noHtml doc names typ
                        [] splice unicode pkg qual
               | L _ (ClassOpSig _ False lnames typ) <- sigs
               , let doc = lookupAnySubdoc (head names) subdocs
@@ -561,14 +570,14 @@ ppClassDecl summary links instances fixities loc d subdocs
     lookupDAT name = Map.lookup (getName name) defaultAssocTys
     defaultAssocTys = Map.fromList
       [ (getName name, (vs, typ))
-      | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ
-                                           , feqn_tycon = L _ name
-                                           , feqn_pats = vs }))) <- atsDefs
+      | L _ (TyFamInstDecl (FamEqn { feqn_rhs = typ
+                                   , feqn_tycon = L _ name
+                                   , feqn_pats = vs })) <- atsDefs
       ]
 
     -- Methods
     methodBit = subMethods
-      [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ)
+      [ ppFunSig summary links loc noHtml doc [name] typ
                  subfixs splice unicode pkg qual
           <+>
         subDefaults (maybeToList defSigs)
@@ -583,7 +592,7 @@ ppClassDecl summary links instances fixities loc d subdocs
 
     -- Default methods
     ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")
-      d' [n] (hsSigTypeI t) [] splice unicode pkg qual
+      d' [n] t [] splice unicode pkg qual
 
     lookupDM name = Map.lookup (getOccString name) defaultMethods
     defaultMethods = Map.fromList
@@ -709,7 +718,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
 ppInstanceSigs links splice unicode qual sigs = do
     TypeSig _ lnames typ <- sigs
     let names = map unLoc lnames
-        L _ rtyp = hsSigWcType typ
+        L _ rtyp = dropWildCards typ
     -- Instance methods signatures are synified and thus don't have a useful
     -- SrcSpan value. Use the methods name location instead.
     return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp
@@ -772,7 +781,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
     pats1 = [ hsep [ keyword "pattern"
                    , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
                    , dcolon unicode
-                   , ppPatSigType unicode qual (hsSigTypeI typ)
+                   , ppPatSigType unicode qual typ
                    ]
             | (SigD _ (PatSynSig _ lnames typ),_) <- pats
             ]
@@ -851,7 +860,7 @@ ppShortConstrParts summary dataInst con unicode qual
                      in case det of
 
         -- Prefix constructor, e.g. 'Just a'
-        PrefixCon args ->
+        PrefixCon _ args ->
           ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)
           , noHtml
           , noHtml
@@ -878,7 +887,7 @@ ppShortConstrParts summary dataInst con unicode qual
 
       -- GADT constructor, e.g. 'Foo :: Int -> Foo'
       ConDeclGADT {} ->
-          ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ]
+          ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ]
           , noHtml
           , noHtml
           )
@@ -922,7 +931,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
                          header_ = ppConstrHdr forall_ tyVars context unicode qual
                      in case det of
         -- Prefix constructor, e.g. 'Just a'
-        PrefixCon args
+        PrefixCon _ args
           | hasArgDocs -> header_ <+> ppOcc <+> fixity
           | otherwise -> hsep [ header_ <+> ppOcc
                               , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)
@@ -947,24 +956,26 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
           | otherwise -> hsep [ ppOcc
                               , dcolon unicode
                               -- ++AZ++ make this prepend "{..}" when it is a record style GADT
-                              , ppLType unicode qual HideEmptyContexts (getGADTConType con)
+                              , ppLSigType unicode qual HideEmptyContexts (getGADTConType con)
                               , fixity
                               ]
 
-    fieldPart = case (con, getConArgsI 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 con of
+        ConDeclGADT{con_g_args = con_args'} -> case con_args' of
+          -- GADT record declarations
+          RecConGADT _                    -> [ doConstrArgsWithDocs [] ]
+          -- GADT prefix data constructors
+          PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]
+          _                               -> []
+
+        ConDeclH98{con_args = con_args'} -> case con_args' of
+          -- H98 record declarations
+          RecCon (L _ fields)             -> [ doRecordFields fields ]
+          -- H98 prefix data constructors
+          PrefixCon _ args | hasArgDocs   -> [ doConstrArgsWithDocs args ]
+          -- H98 infix data constructor
+          InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
+          _                               -> []
 
     doRecordFields fields = subFields pkg qual
       (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
@@ -1049,18 +1060,17 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
          | otherwise = hsep [ keyword "pattern"
                             , ppOcc
                             , dcolon unicode
-                            , ppPatSigType unicode qual (hsSigTypeI typ)
+                            , ppPatSigType unicode qual typ
                             , fixity
                             ]
 
     fieldPart
       | not hasArgDocs = []
-      | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy)
+      | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ)
                                                         argDocs [] (dcolon unicode)
                                                         emptyCtxt) ]
 
-    patTy = hsSigTypeI typ
-    emptyCtxt = patSigContext patTy
+    emptyCtxt = patSigContext typ
 
 
 -- | Print the LHS of a data\/newtype declaration.
@@ -1114,6 +1124,9 @@ ppLType       unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc
 ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
 ppLFunLhType  unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)
 
+ppLSigType ::  Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html
+ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y)
+
 ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html
 ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts
 
@@ -1122,6 +1135,9 @@ ppType       unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP
 ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts
 ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts
 
+ppSigType ::  Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html
+ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts
+
 ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html
 ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty
 ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <>
@@ -1156,18 +1172,18 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
 ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
 ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts
 
-patSigContext :: LHsType name -> HideEmptyContexts
-patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts
-                  | otherwise = HideEmptyContexts
+patSigContext :: LHsSigType DocNameI -> HideEmptyContexts
+patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts
+                      | otherwise = HideEmptyContexts
   where
-    hasNonEmptyContext :: LHsType name -> Bool
+    typ = sig_body (unLoc sig_typ)
+
     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
         _ -> False
-    isFirstContextEmpty :: LHsType name -> Bool
     isFirstContextEmpty t =
       case unLoc t of
         HsForAllTy _ _ s -> isFirstContextEmpty s
@@ -1178,10 +1194,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmp
 
 -- | 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 -> Qualification -> LHsSigType DocNameI -> Html
 ppPatSigType unicode qual typ =
-  let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
+  let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ
 
+ppHsOuterTyVarBndrs :: RenderableBndrFlag flag
+                    => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html
+ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of
+  HsOuterImplicit{} -> noHtml
+  HsOuterExplicit{hso_bndrs = bndrs} ->
+    hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot
 
 ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html
 ppForAllPart unicode qual tele = case tele of
@@ -1191,6 +1213,10 @@ ppForAllPart unicode qual tele = case tele of
   HsForAllInvis { hsf_invis_bndrs = bndrs } ->
     hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot
 
+ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts
+  = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts
+
 ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
 ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
 
@@ -1236,7 +1262,7 @@ 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 (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (XHsType {})        _ _ _ = error "ppr_mono_ty HsCoreTy"
 ppr_mono_ty (HsExplicitListTy _ IsPromoted 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
@@ -1272,3 +1298,4 @@ ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
 ppr_tylit :: HsTyLit -> Html
 ppr_tylit (HsNumTy _ n) = toHtml (show n)
 ppr_tylit (HsStrTy _ s) = toHtml (show s)
+ppr_tylit (HsCharTy _ c) = toHtml (show c)