diff options
Diffstat (limited to 'haddock-api/src/Haddock/Utils.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Utils.hs | 63 |
1 files changed, 27 insertions, 36 deletions
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 84f58ab8..e3cc9655 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -63,7 +63,8 @@ import Haddock.GhcUtils import GHC import Name import NameSet ( emptyNameSet ) -import HsTypes (selectorFieldOcc) +import HsTypes (extFieldOcc) +import Outputable ( panic ) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -131,16 +132,19 @@ mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature -addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) - = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) +addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) + = L pos (TypeSig noExt lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty }) + = L loc (HsForAllTy { hst_xforall = noExt + , hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty }) + = L loc (HsQualTy { hst_xqual = noExt + , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty) - = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + = L loc (HsQualTy { hst_xqual = noExt + , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) add_ctxt (L loc preds) = L loc (extra_pred : preds) @@ -149,7 +153,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- @@ -159,10 +163,10 @@ lHsQTyVarsToTypes tvs restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d -> - TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), + TyClD x d | isDataDecl d -> + TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD x d | isClassDecl d -> + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl @@ -175,42 +179,28 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" +restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case getConDetails h98d of + case con_args d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d - | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) }) + | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. InfixCon _ _ -> Just d where - h98d = h98ConDecl d - h98ConDecl c@ConDeclH98{} = c - h98ConDecl c@ConDeclGADT{} = c' - where - (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) - c' :: ConDecl GhcRn - c' = ConDeclH98 - { con_name = head (con_names c) - , con_qvars = Just $ HsQTvs { hsq_implicit = mempty - , hsq_explicit = tvs - , hsq_dependent = emptyNameSet } - , con_cxt = Just cxt - , con_details = details - , con_doc = con_doc c - } - field_avail :: LConDeclField GhcRn -> Bool - field_avail (L _ (ConDeclField fs _ _)) - = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs - field_types flds = [ t | ConDeclField _ t _ <- flds ] + field_avail (L _ (ConDeclField _ fs _ _)) + = all (\f -> extFieldOcc (unLoc f) `elem` names) fs + field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail" + field_types flds = [ t | ConDeclField _ _ t _ <- flds ] keep _ = Nothing @@ -221,13 +211,14 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsQTyVars Name +emptyHsQTvs :: LHsQTyVars GhcRn -- 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 -emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" - , hsq_explicit = [] - , hsq_dependent = error "haddock:emptyHsQTvs" } +emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_dependent = error "haddock:emptyHsQTvs" } + , hsq_explicit = [] } -------------------------------------------------------------------------------- |