diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 6 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 92 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 164 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 14 |
4 files changed, 139 insertions, 137 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index dd6c70a5..35f24ee5 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -194,13 +194,13 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ ) = 2 +argCount (FunTy _ _ _) = 2 argCount (ForAllTy _ t) = argCount t argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType -simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] +simplify (FunTy _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 @@ -255,7 +255,7 @@ isTypeHidden expInfo = typeHidden case t of TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 - FunTy t1 t2 -> typeHidden t1 || typeHidden t2 + FunTy _ t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty LitTy _ -> False diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index dd1d4eb3..d5cbdaf5 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -52,7 +53,7 @@ import Packages ( lookupModuleInAllPackages, PackageName(..) ) import Bag import RdrName import TcRnTypes -import FastString ( unpackFS, fastStringToByteString) +import FastString ( unpackFS, bytesFS ) import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified Outputable as O @@ -297,8 +298,8 @@ moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) parseWarning dflags gre w = case w of - DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (fastStringToByteString . sl_fs . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (foldMap (fastStringToByteString . sl_fs . unLoc) msg) + DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (bytesFS . sl_fs . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (foldMap (bytesFS . sl_fs . unLoc) msg) where format x bs = DocWarning . DocParagraph . DocAppend (DocString x) <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs) @@ -468,11 +469,22 @@ subordinates instMap decl = case decl of , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) - | HsIB { hsib_body = L l (HsDocTy _ _ doc) } - <- concatMap (unLoc . deriv_clause_tys . unLoc) $ - unLoc $ dd_derivs dd + | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ + concatMap (unLoc . deriv_clause_tys . unLoc) $ + unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] + extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) + extract_deriv_ty ty = + case dL ty of + -- deriving (forall a. C a {- ^ Doc comment -}) + L l (HsForAllTy{ hst_fvf = ForallInvis + , hst_body = dL->L _ (HsDocTy _ _ doc) }) + -> Just (l, doc) + -- deriving (C a {- ^ Doc comment -}) + L l (HsDocTy _ _ doc) -> Just (l, doc) + _ -> Nothing + -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int HsDocString conArgDocs con = case getConArgs con of @@ -515,10 +527,10 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs (DocD noExt) class_ - defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_ - sigs = mkDecls tcdSigs (SigD noExt) class_ - ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_ + docs = mkDecls tcdDocs (DocD noExtField) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_ + sigs = mkDecls tcdSigs (SigD noExtField) class_ + ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ -- | The top-level declarations of a module that we care about, @@ -537,14 +549,14 @@ mkFixMap group_ = M.fromList [ (n,f) -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++ - mkDecls hs_derivds (DerivD noExt) group_ ++ - mkDecls hs_defds (DefD noExt) group_ ++ - mkDecls hs_fords (ForD noExt) group_ ++ - mkDecls hs_docs (DocD noExt) group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++ - mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++ - mkDecls (valbinds . hs_valds) (ValD noExt) group_ + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++ + mkDecls hs_derivds (DerivD noExtField) group_ ++ + mkDecls hs_defds (DefD noExtField) group_ ++ + mkDecls hs_fords (ForD noExtField) group_ ++ + mkDecls hs_docs (DocD noExtField) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExtField) group_ where typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" @@ -736,14 +748,14 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames L loc (SigD _ sig) -> -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. - let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig + let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ L loc (TyClD _ cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail - (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_ + (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_ _ -> availExportDecl avail decl docs_ @@ -1057,8 +1069,8 @@ extractDecl declMap name decl in case (matchesMethod, matchesAssociatedType) of ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD noExt sig) - (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl)) + in L pos (SigD noExtField sig) + (_, [L pos fam_decl]) -> L pos (TyClD noExtField (FamDecl noExtField fam_decl)) ([], []) | Just (famInstDecl:_) <- M.lookup name declMap @@ -1070,8 +1082,8 @@ extractDecl declMap name decl TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name - then SigD noExt <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) - else SigD noExt <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) + then SigD noExtField <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) + else SigD noExtField <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap @@ -1081,8 +1093,8 @@ extractDecl declMap name decl , feqn_pats = tys , feqn_rhs = defn }}))) -> if isDataConName name - then SigD noExt <$> extractPatternSyn name n tys (dd_cons defn) - else SigD noExt <$> extractRecSel name n tys (dd_cons defn) + then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn) + else SigD noExtField <$> extractRecSel name n tys (dd_cons defn) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = @@ -1092,7 +1104,7 @@ extractDecl declMap name decl , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of - [d0] -> extractDecl declMap name (noLoc (InstD noExt (DataFamInstD noExt d0))) + [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) _ -> error "internal: extractDecl (ClsInstD)" | otherwise -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) @@ -1104,7 +1116,7 @@ extractDecl declMap name decl , extFieldOcc n == name ] in case matches of - [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0) + [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> O.pprPanic "extractDecl" $ O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":" @@ -1128,21 +1140,21 @@ extractPatternSyn nm t tvs cons = typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ) _ -> typ - typ'' = noLoc (HsQualTy noExt (noLoc []) typ') - in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'') + typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') + in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn - mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExt f + mkAppTyArg f (HsArgPar _) = HsParTy noExtField f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn @@ -1151,7 +1163,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) + L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] @@ -1160,11 +1172,11 @@ extractRecSel nm t tvs (L _ con : rest) = data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn - mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExt f + mkAppTyArg f (HsArgPar _) = HsParTy noExtField f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index ceea2444..72d063dc 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -204,14 +204,14 @@ renameMaybeLKind = traverse renameLKind renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) renameFamilyResultSig (L loc (NoSig _)) - = return (L loc (NoSig noExt)) + = return (L loc (NoSig noExtField)) renameFamilyResultSig (L loc (KindSig _ ki)) = do { ki' <- renameLKind ki - ; return (L loc (KindSig noExt ki')) } + ; return (L loc (KindSig noExtField ki')) } renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr - ; return (L loc (TyVarSig noExt bndr')) } -renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig" + ; return (L loc (TyVarSig noExtField bndr')) } +renameFamilyResultSig (L _ (XFamilyResultSig nec)) = noExtCon nec renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) @@ -225,63 +225,64 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of - HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do + HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype - return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' }) + return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField + , hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n - HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar noExtField ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy noExtField b =<< renameLType ltype - HsStarTy _ isUni -> return (HsStarTy NoExt isUni) + HsStarTy _ isUni -> return (HsStarTy noExtField isUni) HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy NoExt a' b') + return (HsAppTy noExtField a' b') HsAppKindTy _ a b -> do a' <- renameLType a b' <- renameLKind b - return (HsAppKindTy NoExt a' b') + return (HsAppKindTy noExtField a' b') HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy NoExt a' b') + return (HsFunTy noExtField a' b') - HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty - HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty) + HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty) - HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts - HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy noExtField b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy noExtField <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy NoExt a' (L loc op') b') + return (HsOpTy noExtField a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty + HsParTy _ ty -> return . (HsParTy noExtField) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig NoExt ty' k') + return (HsKindSig noExtField ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy NoExt ty' doc') + return (HsDocTy noExtField ty' doc') - HsTyLit _ x -> return (HsTyLit NoExt x) + HsTyLit _ x -> return (HsTyLit noExtField x) - HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a + HsRecTy _ a -> HsRecTy noExtField <$> mapM renameConDeclFieldField a (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a)) HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b @@ -302,9 +303,9 @@ renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced" renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_ext = noExt + ; return (HsQTvs { hsq_ext = noExtField , hsq_explicit = tvs' }) } -renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars" +renameLHsQTyVars (XLHsQTyVars nec) = noExtCon nec renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar x (L l n))) @@ -352,19 +353,19 @@ renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of TyClD _ d -> do d' <- renameTyClD d - return (TyClD noExt d') + return (TyClD noExtField d') SigD _ s -> do s' <- renameSig s - return (SigD noExt s') + return (SigD noExtField s') ForD _ d -> do d' <- renameForD d - return (ForD noExt d') + return (ForD noExtField d') InstD _ d -> do d' <- renameInstD d - return (InstD noExt d') + return (InstD noExtField d') DerivD _ d -> do d' <- renameDerivD d - return (DerivD noExt d') + return (DerivD noExtField d') _ -> error "renameDecl" renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) @@ -375,20 +376,20 @@ renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl - return (FamDecl { tcdFExt = noExt, tcdFam = decl' }) + return (FamDecl { tcdFExt = noExtField, tcdFam = decl' }) SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs - return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + return (SynDecl { tcdSExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' , tcdFixity = fixity, tcdRhs = rhs' }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + return (DataDecl { tcdDExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' , tcdFixity = fixity, tcdDataDefn = defn' }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity @@ -399,13 +400,13 @@ renameTyClD d = case d of lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats - at_defs' <- mapM renameLTyFamDefltEqn at_defs + at_defs' <- mapM (mapM renameTyFamDefltD) at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag - , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt }) - XTyClDecl _ -> panic "haddock:renameTyClD" + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField }) + XTyClDecl nec -> noExtCon nec where renameLFunDep (L loc (xs, ys)) = do @@ -426,12 +427,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity - return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname' + return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' }) -renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl" +renameFamilyDecl (XFamilyDecl nec) = noExtCon nec renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn @@ -457,11 +458,11 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing - return (HsDataDefn { dd_ext = noExt + return (HsDataDefn { dd_ext = noExtField , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) -renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn" +renameDataDefn (XHsDataDefn nec) = noExtCon nec renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars @@ -472,7 +473,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars' + return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' , con_args = details', con_doc = mbldoc' }) @@ -486,10 +487,10 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars details' <- renameDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars' + return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' , con_mb_cxt = lcontext', con_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) -renameCon (XConDecl _) = panic "haddock:renameCon" +renameCon (XConDecl nec) = noExtCon nec renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do @@ -506,8 +507,8 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return $ L l (ConDeclField noExt names' t' doc') -renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField" + return $ L l (ConDeclField noExtField names' t' doc') +renameConDeclFieldField (L _ (XConDeclField nec)) = noExtCon nec renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do @@ -520,21 +521,21 @@ renameSig sig = case sig of TypeSig _ lnames ltype -> do lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype - return (TypeSig noExt lnames' ltype') + return (TypeSig noExtField lnames' ltype') ClassOpSig _ is_default lnames sig_ty -> do lnames' <- mapM renameL lnames ltype' <- renameLSigType sig_ty - return (ClassOpSig noExt is_default lnames' ltype') + return (ClassOpSig noExtField is_default lnames' ltype') PatSynSig _ lnames sig_ty -> do lnames' <- mapM renameL lnames sig_ty' <- renameLSigType sig_ty - return $ PatSynSig noExt lnames' sig_ty' + return $ PatSynSig noExtField lnames' sig_ty' FixSig _ (FixitySig _ lnames fixity) -> do lnames' <- mapM renameL lnames - return $ FixSig noExt (FixitySig noExt lnames' fixity) + return $ FixSig noExtField (FixitySig noExtField lnames' fixity) MinimalSig _ src (L l s) -> do s' <- traverse renameL s - return $ MinimalSig noExt src (L l s') + return $ MinimalSig noExtField src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -543,25 +544,25 @@ renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignImport noExt lname' ltype' x) + return (ForeignImport noExtField lname' ltype' x) renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignExport noExt lname' ltype' x) -renameForD (XForeignDecl _) = panic "haddock:renameForD" + return (ForeignExport noExtField lname' ltype' x) +renameForD (XForeignDecl nec) = noExtCon nec renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d - return (ClsInstD { cid_d_ext = noExt, cid_inst = d' }) + return (ClsInstD { cid_d_ext = noExtField, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do d' <- renameTyFamInstD d - return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' }) + return (TyFamInstD { tfid_ext = noExtField, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d - return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' }) -renameInstD (XInstDecl _) = panic "haddock:renameInstD" + return (DataFamInstD { dfid_ext = noExtField, dfid_inst = d' }) +renameInstD (XInstDecl nec) = noExtCon nec renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty @@ -569,11 +570,11 @@ renameDerivD (DerivDecl { deriv_type = ty , deriv_overlap_mode = omode }) = do ty' <- renameLSigWcType ty strat' <- mapM (mapM renameDerivStrategy) strat - return (DerivDecl { deriv_ext = noExt + return (DerivDecl { deriv_ext = noExtField , deriv_type = ty' , deriv_strategy = strat' , deriv_overlap_mode = omode }) -renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD" +renameDerivD (XDerivDecl nec) = noExtCon nec renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) renameDerivStrategy StockStrategy = pure StockStrategy @@ -588,11 +589,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs - return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode + return (ClsInstDecl { cid_ext = noExtField, cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameClsInstD (XClsInstDecl _) = panic "haddock:renameClsInstD" +renameClsInstD (XClsInstDecl nec) = noExtCon nec renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) @@ -605,8 +606,8 @@ renameTyFamInstEqn eqn = renameImplicit rename_ty_fam_eqn eqn where rename_ty_fam_eqn - :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn) - -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI)) + :: FamEqn GhcRn (LHsType GhcRn) + -> RnM (FamEqn DocNameI (LHsType DocNameI)) rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = rhs }) @@ -614,27 +615,16 @@ renameTyFamInstEqn eqn ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs ; pats' <- mapM renameLTypeArg pats ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_ext = noExt + ; return (FamEqn { feqn_ext = noExtField , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } - rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn" - -renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) -renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs - , feqn_fixity = fixity, feqn_rhs = rhs })) - = do { tc' <- renameL tc - ; tvs' <- renameLHsQTyVars tvs - ; rhs' <- renameLType rhs - ; return (L loc (FamEqn { feqn_ext = noExt - , feqn_tycon = tc' - , feqn_bndrs = Nothing -- this is always Nothing - , feqn_pats = tvs' - , feqn_fixity = fixity - , feqn_rhs = rhs' })) } -renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn" + rename_ty_fam_eqn (XFamEqn nec) = noExtCon nec + +renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) +renameTyFamDefltD = renameTyFamInstD renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) @@ -642,8 +632,8 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) ; return (DataFamInstDecl { dfid_eqn = eqn' }) } where rename_data_fam_eqn - :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn) - -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI)) + :: FamEqn GhcRn (HsDataDefn GhcRn) + -> RnM (FamEqn DocNameI (HsDataDefn DocNameI)) rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = defn }) @@ -651,13 +641,13 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn - ; return (FamEqn { feqn_ext = noExt + ; return (FamEqn { feqn_ext = noExtField , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } - rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD" + rename_data_fam_eqn (XFamEqn nec) = noExtCon nec renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing @@ -665,8 +655,8 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_ext = noExt }) } -renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit" + , hsib_ext = noExtField }) } +renameImplicit _ (XHsImplicitBndrs nec) = noExtCon nec renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing @@ -674,8 +664,8 @@ renameWc :: (in_thing -> RnM out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_ext = noExt }) } -renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc" + , hswc_ext = noExtField }) } +renameWc _ (XHsWildCardBndrs nec) = noExtCon nec renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n, m) = do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 6fd528af..03cc1b7e 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -76,7 +76,7 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) = - TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) + TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ) @@ -112,7 +112,7 @@ sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | getName name == listTyConName = HsListTy NoExt ltyp + | getName name == listTyConName = HsListTy noExtField ltyp sugarLists typ = typ @@ -123,7 +123,7 @@ sugarTuples typ = aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy _ (L _ typ')) = aux apps typ' aux apps (HsTyVar _ _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps + | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedTuple apps where name' = getName name strName = getOccString name @@ -136,7 +136,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | funTyConName == name' = HsFunTy NoExt la lb + | funTyConName == name' = HsFunTy noExtField la lb where name' = getName name sugarOperators typ = typ @@ -206,7 +206,7 @@ freeVariables = everythingWithState Set.empty Set.union query where query term ctx = case cast term :: Maybe (HsType GhcRn) of - Just (HsForAllTy _ bndrs _) -> + Just (HsForAllTy _ _ bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) @@ -244,8 +244,8 @@ data RenameEnv name = RenameEnv renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) -renameType (HsForAllTy x bndrs lt) = - HsForAllTy x +renameType (HsForAllTy x fvf bndrs lt) = + HsForAllTy x fvf <$> mapM (located renameBinder) bndrs <*> renameLType lt renameType (HsQualTy x lctxt lt) = |