From 815d2deb9c0222c916becccf8464b740c26255fd Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 22 Aug 2017 23:02:51 -0400 Subject: Update for #14131 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 10 ++-- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 9 +-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 5 +- haddock-api/src/Haddock/Convert.hs | 18 +++--- haddock-api/src/Haddock/GhcUtils.hs | 5 +- haddock-api/src/Haddock/Interface/Create.hs | 28 +++++---- haddock-api/src/Haddock/Interface/Rename.hs | 69 +++++++++++++--------- 7 files changed, 83 insertions(+), 61 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 56f8176c..8e4e801e 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -184,11 +184,11 @@ ppClass dflags decl subdocs = tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn tyFamEqnToSyn tfe = SynDecl - { tcdLName = tfe_tycon tfe - , tcdTyVars = tfe_pats tfe - , tcdFixity = tfe_fixity tfe - , tcdRhs = tfe_rhs tfe - , tcdFVs = emptyNameSet + { tcdLName = feqn_tycon tfe + , tcdTyVars = feqn_pats tfe + , tcdFixity = feqn_fixity tfe + , tcdRhs = feqn_rhs tfe + , tcdFVs = emptyNameSet } diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 759a31d4..57ff72ff 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -159,10 +159,11 @@ decls (group, _, _, _) = concatMap ($ group) ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of - (Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GhcRn)) - -> pure . tyref $ GHC.dfid_tycon inst - (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> - pure . tyref $ GHC.tfe_tycon eqn + (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn)) + :: GHC.InstDecl GHC.GhcRn)) + -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn + (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) -> + pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn _ -> empty fld term = case cast term of Just (field :: GHC.ConDeclField GHC.GhcRn) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 59ad41e4..3b53b1eb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -318,8 +318,9 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = ppInstances links (OriginFamily docname) instances splice unicode qual -- Individual equation of a closed type family - ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs - , tfe_pats = HsIB { hsib_body = ts }} + ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl + ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs + , feqn_pats = ts } }) = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 36efb3e4..67aa88e1 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -113,20 +113,20 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs - in TyFamEqn { tfe_tycon = name - , tfe_pats = HsIB { hsib_body = typats - , hsib_vars = map tyVarName tkvs - , hsib_closed = True } - , tfe_fixity = Prefix - , tfe_rhs = hs_rhs } + in HsIB { hsib_vars = map tyVarName tkvs + , hsib_closed = True + , hsib_body = FamEqn { feqn_tycon = name + , feqn_pats = typats + , feqn_fixity = Prefix + , feqn_rhs = hs_rhs } } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax - = return $ InstD (TyFamInstD - (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch - , tfid_fvs = placeHolderNamesTc })) + = return $ InstD + $ TyFamInstD + $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 561c126f..a1009c1f 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -59,12 +59,13 @@ getMainDeclBinder _ = [] -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l +getInstLoc (DataFamInstD (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l getInstLoc (TyFamInstD (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. - { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 292680a7..62bdbcbe 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -406,11 +406,13 @@ subordinates :: InstMap -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do - DataFamInstDecl { dfid_tycon = L l _ - , dfid_defn = defn } <- unLoc <$> cid_datafam_insts d + DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - InstD (DataFamInstD d) -> dataSubs (dfid_defn d) + InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d }))) + -> dataSubs (feqn_rhs d) TyClD d | isClassDecl d -> classSubs d | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] @@ -1004,17 +1006,19 @@ extractDecl name decl in if isDataConName name then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) - InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsIB { hsib_body = tys } - , dfid_defn = defn }) -> + InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = + FamEqn { feqn_tycon = L _ n + , feqn_pats = tys + , feqn_rhs = defn }}))) -> SigD <$> extractRecSel name n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> - let matches = [ d | L _ d <- insts - -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) - , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) - , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) - , L _ n <- ns - , selectorFieldOcc n == name + let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) + <- insts + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) + , L _ n <- ns + , selectorFieldOcc n == name ] in case matches of [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 2e9a311a..70962d9c 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -415,7 +415,7 @@ renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns + = do { eqns' <- mapM (mapM (mapM renameTyFamInstEqn)) eqns ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI) @@ -542,39 +542,54 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) - = do { eqn' <- renameLTyFamInstEqn eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' - , tfid_fvs = placeHolderNames }) } - -renameLTyFamInstEqn :: LTyFamInstEqn GhcRn -> RnM (LTyFamInstEqn DocNameI) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; pats' <- renameImplicit (mapM renameLType) pats - ; rhs' <- renameLType rhs - ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = pats' - , tfe_fixity = fixity - , tfe_rhs = rhs' })) } + = do { eqn' <- renameTyFamInstEqn eqn + ; return (TyFamInstDecl { tfid_eqn = eqn' }) } + +renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI) +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)) + rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats + , feqn_fixity = fixity, feqn_rhs = rhs }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType pats + ; rhs' <- renameLType rhs + ; return (FamEqn { feqn_tycon = tc' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) } renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) -renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs })) +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 (TyFamEqn { tfe_tycon = tc' - , tfe_pats = tvs' - , tfe_fixity = fixity - , tfe_rhs = rhs' })) } + ; return (L loc (FamEqn { feqn_tycon = tc' + , feqn_pats = tvs' + , feqn_fixity = fixity + , feqn_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn }) - = do { tc' <- renameL tc - ; pats' <- renameImplicit (mapM renameLType) pats - ; defn' <- renameDataDefn defn - ; return (DataFamInstDecl { dfid_tycon = tc' - , dfid_pats = pats' - , dfid_fixity = fixity - , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) + = do { eqn' <- renameImplicit rename_data_fam_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)) + rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats + , feqn_fixity = fixity, feqn_rhs = defn }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType pats + ; defn' <- renameDataDefn defn + ; return (FamEqn { feqn_tycon = tc' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = defn' }) } renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing -- cgit v1.2.3