Track wip/spj-wildcard-refactor on main repo

5 files changed, 80 insertions, 61 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 55075e20..8664db27 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -64,7 +64,8 @@ dropHsDocTy :: HsType a -> HsType a
 dropHsDocTy = f
     where
         g (L src x) = L src (f x)
-        f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e)
+        f (HsForAllTy a e) = HsForAllTy a (g e)
+        f (HsQualTy a e) = HsQualTy a (g e)
         f (HsBangTy a b) = HsBangTy a (g b)
         f (HsAppTy a b) = HsAppTy (g a) (g b)
         f (HsFunTy a b) = HsFunTy (g a) (g b)
@@ -81,14 +82,6 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
 outHsType dflags = out dflags . dropHsDocTy
 
 
-makeExplicit :: HsType a -> HsType a
-makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d
-makeExplicit x = x
-
-makeExplicitL :: LHsType a -> LHsType a
-makeExplicitL (L src x) = L src (makeExplicit x)
-
-
 dropComment :: String -> String
 dropComment (' ':'-':'-':' ':_) = []
 dropComment (x:xs) = x : dropComment xs
@@ -120,22 +113,19 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
         f (TyClD d@DataDecl{})  = ppData dflags d subdocs
         f (TyClD d@SynDecl{})   = ppSynonym dflags d
         f (TyClD d@ClassDecl{}) = ppClass dflags d
-        f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
-        f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
+        f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+        f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
         f (SigD sig) = ppSig dflags sig
         f _ = []
 ppExport _ _ = []
 
 
 ppSig :: DynFlags -> Sig Name -> [String]
-ppSig dflags (TypeSig names sig _)
+ppSig dflags (TypeSig names sig)
     = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
     where
         prettyNames = intercalate ", " $ map (out dflags) names
-        typ = case unL sig of
-                   HsForAllTy Explicit a b c d  -> HsForAllTy Implicit a b c d
-                   HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d
-                   x -> x
+        typ = unL (hsSigType sig)
 ppSig _ _ = []
 
 
@@ -144,12 +134,13 @@ ppClass :: DynFlags -> TyClDecl Name -> [String]
 ppClass dflags x = out dflags x{tcdSigs=[]} :
             concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
     where
-        addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
+        addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig)))
         addContext (MinimalSig src sig) = MinimalSig src sig
         addContext _ = error "expected TypeSig"
 
-        f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d
-        f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t)
+        f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty))
+        f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty
+        f ty = HsQualTy (reL [context]) ty
 
         context = nlHsTyConApp (tcdName x)
             (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
@@ -194,10 +185,10 @@ ppCtor dflags dat subdocs con
                            [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))
+        funs = foldr1 (\x y -> reL $ HsFunTy x y)
         apps = foldl1 (\x y -> reL $ HsAppTy x y)
 
-        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
+        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
         name = out dflags $ map unL $ con_names con
 
         resType = case con_res con of
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index f0fc108b..d74d528e 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -96,7 +96,7 @@ tyThingToLHsDecl t = case t of
 
   -- a data-constructor alone just gets rendered as a function:
   AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]
-    (synifyType ImplicitizeForAll (dataConUserType dc)) [])
+    (synifyType ImplicitizeForAll (dataConUserType dc)))
 
   AConLike (PatSynCon ps) ->
       let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps
@@ -118,10 +118,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
         hs_rhs     = synifyType WithinType rhs
         (kvs, tvs) = partition isKindVar tkvs
     in TyFamEqn { tfe_tycon = name
-                , tfe_pats  = HsWB { hswb_cts = typats
-                                    , hswb_kvs = map tyVarName kvs
-                                    , hswb_tvs = map tyVarName tvs
-                                    , hswb_wcs = [] }
+                , tfe_pats  = HsIB { hsib_body = typats
+                                   , hsib_kvs = map tyVarName kvs
+                                   , hsib_tvs = map tyVarName tvs }
                 , tfe_rhs   = hs_rhs }
 
 synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)
@@ -310,8 +309,14 @@ synifyDataCon use_gadt_syntax dc =
               else ResTyH98
  -- finally we get synifyDataCon's result!
  in hs_arg_tys >>=
-      \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care
-                qvars ctx hat hs_res_ty Nothing
+      \hat -> return $ noLoc $
+              ConDecl { con_names = [name]
+                      , con_explicit = False    -- we don't know nor care
+                      , con_qvars = qvars
+                      , con_cxt   = ctx
+                      , con_details =  hat
+                      , con_res = hs_res_ty
+                      , con_doc =  Nothing }
                 -- we don't want any "deprecated GADT syntax" warnings!
                 False
 
@@ -327,7 +332,7 @@ synifyCtx :: [PredType] -> LHsContext Name
 synifyCtx = noLoc . map (synifyType WithinType)
 
 
-synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
+synifyTyVars :: [TyVar] -> LHsQTyVars Name
 synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
                            , hsq_tvs = map synifyTyVar tvs }
   where
@@ -393,15 +398,13 @@ synifyType _ (FunTy t1 t2) = let
   in noLoc $ HsFunTy s1 s2
 synifyType s forallty@(ForAllTy _tv _ty) =
   let (tvs, ctx, tau) = tcSplitSigmaTy forallty
-      sTvs = synifyTyVars tvs
-      sCtx = synifyCtx ctx
-      sTau = synifyType WithinType tau
-      mkHsForAllTy forallPlicitness =
-        noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau
+      sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx)
+                      , hst_body = noLoc (synify WithinType tau) }
   in case s of
     DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
-    WithinType -> mkHsForAllTy Explicit
-    ImplicitizeForAll -> mkHsForAllTy Implicit
+    WithinType        -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs
+                                            , hst_body  = noLoc sPhi }
+    ImplicitizeForAll -> noLoc sPhi
 
 synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
 
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index aa9a1c32..49d6a420 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -69,7 +69,7 @@ getMainDeclBinder _ = []
 -- to correlate InstDecls with their Instance/CoAxiom Names, via the
 -- instanceMap.
 getInstLoc :: InstDecl name -> SrcSpan
-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l
+getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
 getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
 getInstLoc (TyFamInstD (TyFamInstDecl
   -- Since CoAxioms' Names refer to the whole line for type family instances
@@ -92,10 +92,10 @@ filterSigNames p (FixSig (FixitySig ns ty)) =
     []       -> Nothing
     filtered -> Just (FixSig (FixitySig filtered ty))
 filterSigNames _ orig@(MinimalSig _ _)      = Just orig
-filterSigNames p (TypeSig ns ty nwcs) =
+filterSigNames p (TypeSig ns ty) =
   case filter (p . unLoc) ns of
     []       -> Nothing
-    filtered -> Just (TypeSig filtered ty nwcs)
+    filtered -> Just (TypeSig filtered ty)
 filterSigNames _ _                           = Nothing
 
 ifTrueJust :: Bool -> name -> Maybe name
@@ -106,8 +106,8 @@ sigName :: LSig name -> [name]
 sigName (L _ sig) = sigNameNoLoc sig
 
 sigNameNoLoc :: Sig name -> [name]
-sigNameNoLoc (TypeSig   ns _ _)        = map unLoc ns
-sigNameNoLoc (PatSynSig n _ _ _ _)     = [unLoc n]
+sigNameNoLoc (TypeSig   ns _)          = map unLoc ns
+sigNameNoLoc (PatSynSig n _)           = [unLoc n]
 sigNameNoLoc (SpecSig   n _ _)         = [unLoc n]
 sigNameNoLoc (InlineSig n _)           = [unLoc n]
 sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
@@ -199,7 +199,7 @@ instance Parent (TyClDecl Name) where
                               $ (dd_cons . tcdDataDefn) $ d
     | isClassDecl d =
         map (unL . fdLName . unL) (tcdATs d) ++
-        [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ]
+        [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
     | otherwise = []
 
 
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 033246a8..318a88c0 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -170,6 +170,12 @@ renameFnArgsDoc = mapM renameDoc
 renameLType :: LHsType Name -> RnM (LHsType DocName)
 renameLType = mapM renameType
 
+renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
+renameLSigType = renameWc renameLType
+
+renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
+renameLWcSigType = renameImplicit renameLSigType
+
 renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
 renameLKind = renameLType
 
@@ -198,11 +204,15 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
 
 renameType :: HsType Name -> RnM (HsType DocName)
 renameType t = case t of
-  HsForAllTy expl extra tyvars lcontext ltype -> do
+  HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
     tyvars'   <- renameLTyVarBndrs tyvars
+    ltype'    <- renameLType ltype
+    return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })
+
+  HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do
     lcontext' <- renameLContext lcontext
     ltype'    <- renameLType ltype
-    return (HsForAllTy expl extra tyvars' lcontext' ltype')
+    return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
 
   HsTyVar n -> return . HsTyVar =<< rename n
   HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
@@ -252,7 +262,7 @@ renameType t = case t of
   HsSpliceTy _ _          -> error "renameType: HsSpliceTy"
   HsWildCardTy a          -> HsWildCardTy <$> renameWildCardInfo a
 
-renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
+renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
 renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
   = do { tvs' <- mapM renameLTyVarBndr tvs
        ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
@@ -423,16 +433,16 @@ renameLFieldOcc (L l (FieldOcc lbl sel)) = do
 
 renameSig :: Sig Name -> RnM (Sig DocName)
 renameSig sig = case sig of
-  TypeSig lnames ltype _ -> do
+  TypeSig lnames ltype -> do
     lnames' <- mapM renameL lnames
-    ltype' <- renameLType ltype
-    return (TypeSig lnames' ltype' PlaceHolder)
+    ltype' <- renameLWcSigType ltype
+    return (TypeSig lnames' ltype')
   PatSynSig lname (flag, qtvs) lreq lprov lty -> do
     lname' <- renameL lname
     qtvs' <- renameLTyVarBndrs qtvs
     lreq' <- renameLContext lreq
     lprov' <- renameLContext lprov
-    lty' <- renameLType lty
+    lty' <- renameLSigType lty
     return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
   FixSig (FixitySig lnames fixity) -> do
     lnames' <- mapM renameL lnames
@@ -445,11 +455,11 @@ renameSig sig = case sig of
 renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
 renameForD (ForeignImport lname ltype co x) = do
   lname' <- renameL lname
-  ltype' <- renameLType ltype
+  ltype' <- renameLSigType ltype
   return (ForeignImport lname' ltype' co x)
 renameForD (ForeignExport lname ltype co x) = do
   lname' <- renameL lname
-  ltype' <- renameLType ltype
+  ltype' <- renameLSigType ltype
   return (ForeignExport lname' ltype' co x)
 
 
@@ -484,33 +494,48 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
                                , tfid_fvs = placeHolderNames }) }
 
 renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)
-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs }))
+renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs }))
   = do { tc' <- renameL tc
-       ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+       ; pats' <- renameImplicit (mapM renameLType) pats
        ; rhs' <- renameLType rhs
        ; return (L loc (TyFamEqn { tfe_tycon = tc'
-                                 , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder
+                                 , tfe_pats = pats'
                                  , tfe_rhs = rhs' })) }
 
 renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
 renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))
-  = do { tc' <- renameL tc
-       ; tvs'  <- renameLTyVarBndrs tvs
+  = do { tc'  <- renameL tc
+       ; tvs' <- renameLTyVarBndrs tvs
        ; rhs' <- renameLType rhs
        ; return (L loc (TyFamEqn { tfe_tycon = tc'
                                  , tfe_pats = tvs'
                                  , tfe_rhs = rhs' })) }
 
 renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn })
   = do { tc' <- renameL tc
-       ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+       ; pats' <- renameImplicit (mapM renameLType) pats
        ; defn' <- renameDataDefn defn
        ; return (DataFamInstDecl { dfid_tycon = tc'
-                                 , dfid_pats
-                                       = HsWB pats' PlaceHolder PlaceHolder PlaceHolder
+                                 , dfid_pats = pats'
                                  , dfid_defn = defn', dfid_fvs = placeHolderNames }) }
 
+renameImplicit :: (in_thing -> RnM out_thing)
+               -> HsImplicitBndrs Name in_thing
+               -> RnM (HsImplicitBndrs DocName out_thing)
+renameImplicit rn_thing (HsIB { hsib_body = thing })
+  = do { thing' <- rn_thing thing
+       ; return (HsIB { hsib_body = thing'
+                      , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder })
+
+renameWc :: (in_thing -> RnM out_thing)
+               -> HsWildcardBndrs Name in_thing
+               -> RnM (HsWildcardBndrs DocName out_thing)
+renameWc rn_thing (HsWC { hswc_body = thing })
+  = do { thing' <- rn_thing thing
+       ; return (HsWC { hswc_body = thing'
+                      , hswc_wcs = PlaceHolder, hswc_ctx = Nothing })
+
 renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
 renameExportItem item = case item of
   ExportModule mdl -> return (ExportModule mdl)
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index c2e1b09a..3964c86a 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -177,7 +177,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
 restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]
 restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
 
-emptyHsQTvs :: LHsTyVarBndrs Name
+emptyHsQTvs :: LHsQTyVars Name
 -- This function is here, rather than in HsTypes, because it *renamed*, but
 -- does not necessarily have all the rigt kind variables.  It is used
 -- in Haddock just for printing, so it doesn't matter