Merge branch 'ghc-head' into ghc-9.0

1 files changed, 72 insertions, 54 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9a304030..f7e1c77b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -18,8 +18,9 @@ module Haddock.Backends.Hoogle (
     ppHoogle
   ) where
 
-import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..)
-                  , PromotionFlag(..), TopLevelFlag(..) )
+import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..),
+                         PromotionFlag(..), TopLevelFlag(..) )
+import GHC.Types.SourceText
 import GHC.Core.InstEnv (ClsInst(..))
 import Documentation.Haddock.Markup
 import Haddock.GhcUtils
@@ -27,8 +28,11 @@ import Haddock.Types hiding (Version)
 import Haddock.Utils hiding (out)
 
 import GHC
+import GHC.Driver.Ppr
 import GHC.Utils.Outputable as Outputable
+import GHC.Utils.Panic
 import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+import GHC.Unit.State
 
 import Data.Char
 import Data.List (intercalate, isPrefixOf)
@@ -37,15 +41,14 @@ import Data.Version
 
 import System.Directory
 import System.FilePath
-
 prefix :: [String]
 prefix = ["-- Hoogle documentation, generated by Haddock"
          ,"-- See Hoogle, http://www.haskell.org/hoogle/"
          ,""]
 
 
-ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
-ppHoogle dflags package version synopsis prologue ifaces odir = do
+ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
+ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do
     let -- Since Hoogle is line based, we want to avoid breaking long lines.
         dflags' = dflags{ pprCols = maxBound }
         filename = package ++ ".txt"
@@ -54,42 +57,46 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
                    ["@package " ++ package] ++
                    ["@version " ++ showVersion version
                    | not (null (versionBranch version)) ] ++
-                   concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+                   concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]
     createDirectoryIfMissing True odir
     writeUtf8File (odir </> filename) (unlines contents)
 
-ppModule :: DynFlags -> Interface -> [String]
-ppModule dflags iface =
+ppModule :: DynFlags -> UnitState -> Interface -> [String]
+ppModule dflags unit_state iface =
   "" : ppDocumentation dflags (ifaceDoc iface) ++
   ["module " ++ moduleString (ifaceMod iface)] ++
   concatMap (ppExport dflags) (ifaceExportItems iface) ++
-  concatMap (ppInstance dflags) (ifaceInstances iface)
+  concatMap (ppInstance dflags unit_state) (ifaceInstances iface)
 
 
 ---------------------------------------------------------------------
 -- Utility functions
 
-dropHsDocTy :: HsType a -> HsType a
-dropHsDocTy = f
+dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p)
+dropHsDocTy = drop_sig_ty
     where
-        g (L src x) = L src (f x)
-        f (HsForAllTy x a e) = HsForAllTy x a (g e)
-        f (HsQualTy x a e) = HsQualTy x a (g e)
-        f (HsBangTy x a b) = HsBangTy x a (g b)
-        f (HsAppTy x a b) = HsAppTy x (g a) (g b)
-        f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)
-        f (HsFunTy x w a b) = HsFunTy x w (g a) (g b)
-        f (HsListTy x a) = HsListTy x (g a)
-        f (HsTupleTy x a b) = HsTupleTy x a (map g b)
-        f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
-        f (HsParTy x a) = HsParTy x (g a)
-        f (HsKindSig x a b) = HsKindSig x (g a) b
-        f (HsDocTy _ a _) = f $ unLoc a
-        f x = x
-
-outHsType :: (OutputableBndrId p)
-          => DynFlags -> HsType (GhcPass p) -> String
-outHsType dflags = out dflags . reparenType . dropHsDocTy
+        drop_sig_ty (HsSig x a b)  = HsSig x a (drop_lty b)
+        drop_sig_ty x@XHsSigType{} = x
+
+        drop_lty (L src x) = L src (drop_ty x)
+
+        drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e)
+        drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e)
+        drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)
+        drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)
+        drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)
+        drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
+        drop_ty (HsListTy x a) = HsListTy x (drop_lty a)
+        drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)
+        drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)
+        drop_ty (HsParTy x a) = HsParTy x (drop_lty a)
+        drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b
+        drop_ty (HsDocTy _ a _) = drop_ty $ unL a
+        drop_ty x = x
+
+outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p)
+             => DynFlags -> HsSigType (GhcPass p) -> String
+outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy
 
 
 dropComment :: String -> String
@@ -106,14 +113,14 @@ outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr
         f [] = []
 
 out :: Outputable a => DynFlags -> a -> String
-out dflags = outWith $ showSDocUnqual dflags
+out dflags = outWith $ showSDoc dflags
 
 operator :: String -> String
 operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
 operator x = x
 
 commaSeparate :: Outputable a => DynFlags -> [a] -> String
-commaSeparate dflags = showSDocUnqual dflags . interpp'SP
+commaSeparate dflags = showSDoc dflags . interpp'SP
 
 ---------------------------------------------------------------------
 -- How to print each export
@@ -133,8 +140,8 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
         f (TyClD _ d@SynDecl{})   = ppSynonym dflags d
         f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
         f (TyClD _ (FamDecl _ d)) = ppFam dflags d
-        f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
-        f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
+        f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]
+        f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ]
         f (SigD _ sig) = ppSig dflags sig
         f _ = []
 
@@ -143,8 +150,8 @@ ppExport _ _ = []
 
 ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
 ppSigWithDoc dflags sig subdocs = case sig of
-    TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names
-    PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names
+    TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names
+    PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names
     _ -> []
   where
     mkDocSig leader typ n = mkSubdoc dflags n subdocs
@@ -153,9 +160,9 @@ ppSigWithDoc dflags sig subdocs = case sig of
 ppSig :: DynFlags -> Sig GhcRn -> [String]
 ppSig dflags x  = ppSigWithDoc dflags x []
 
-pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String
+pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String
 pp_sig dflags names (L _ typ)  =
-    operator prettyNames ++ " :: " ++ outHsType dflags typ
+    operator prettyNames ++ " :: " ++ outHsSigType dflags typ
     where
       prettyNames = intercalate ", " $ map (out dflags) names
 
@@ -173,7 +180,7 @@ ppClass dflags decl subdocs =
 
         ppTyFams
             | null $ tcdATs decl = ""
-            | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
+            | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat
                 [ map pprTyFam (tcdATs decl)
                 , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)
                 ]
@@ -198,9 +205,9 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info })
               ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
               _                  -> decl
 
-ppInstance :: DynFlags -> ClsInst -> [String]
-ppInstance dflags x =
-  [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]
+ppInstance :: DynFlags -> UnitState -> ClsInst -> [String]
+ppInstance dflags unit_state x =
+  [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls]
   where
     -- As per #168, we don't want safety information about the class
     -- in Hoogle output. The easiest way to achieve this is to set the
@@ -234,13 +241,13 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
   _ -> []
 
 ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]
-ppCtor dflags dat subdocs con@ConDeclH98 {}
+ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
   -- AZ:TODO get rid of the concatMap
-   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)
+   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args'
     where
-        f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
-        f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
-        f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
+        f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
+        f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]
+        f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
                           [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++
                            [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
@@ -248,11 +255,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
         funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)
         apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
 
-        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
+        typeSig nm flds = operator nm ++ " :: " ++
+                          outHsSigType dflags (unL $ mkEmptySigType $ funs flds)
 
         -- We print the constructors as comma-separated list. See GHC
         -- docs for con_names on why it is a list to begin with.
-        name = commaSeparate dflags . map unLoc $ getConNames con
+        name = commaSeparate dflags . map unL $ getConNames con
 
         tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
         tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty
@@ -262,13 +270,23 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
                         (HsTyVar noExtField NotPromoted (reL (tcdName dat))) :
                         map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
 
-ppCtor dflags _dat subdocs con@(ConDeclGADT { })
-   = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
+ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
+                                        , con_bndrs = L _ outer_bndrs
+                                        , con_mb_cxt = mcxt
+                                        , con_g_args = args
+                                        , con_res_ty = res_ty })
+   = concatMap (lookupCon dflags subdocs) names ++ [typeSig]
     where
-        f = [typeSig name (getGADTConTypeG con)]
-
-        typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty)
-        name = out dflags $ map unLoc $ getConNames con
+        typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty
+        name = out dflags $ map unL names
+        con_sig_ty = HsSig noExtField outer_bndrs theta_ty where
+          theta_ty = case mcxt of
+            Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
+            Nothing -> tau_ty
+          tau_ty = foldr mkFunTy res_ty $
+            case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
+                         RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds
+          mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
 
 ppFixity :: DynFlags -> (Name, Fixity) -> [String]
 ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]