diff options
Diffstat (limited to 'compiler/deSugar/ExtractDocs.hs')
| -rw-r--r-- | compiler/deSugar/ExtractDocs.hs | 30 |
1 files changed, 16 insertions, 14 deletions
diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs index 33bed3b3f5..ec5238ae4b 100644 --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -12,6 +12,7 @@ import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Decls import GHC.Hs.Extension +import GHC.Hs.Pat import GHC.Hs.Types import GHC.Hs.Utils import Name @@ -114,7 +115,8 @@ user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -} -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] +getMainDeclBinder :: XRec pass Pat ~ Located (Pat pass) => + HsDecl pass -> [IdP pass] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -141,13 +143,13 @@ getInstLoc :: InstDecl (GhcPass p) -> SrcSpan getInstLoc = \case ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) DataFamInstD _ (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l 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 = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" @@ -164,7 +166,7 @@ subordinates :: Map SrcSpan Name subordinates instMap decl = case decl of InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = (dL->L l _) + FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn @@ -175,7 +177,7 @@ subordinates instMap decl = case decl of _ -> [] where classSubs dd = [ (name, doc, declTypeDocs d) - | (dL->L _ d, doc) <- classDecls dd + | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn @@ -189,8 +191,8 @@ subordinates instMap decl = case decl of | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) | RecCon flds <- map getConArgs cons - , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) - , (dL->L _ n) <- ns ] + , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) + , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty) | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ concatMap (unLoc . deriv_clause_tys . unLoc) $ @@ -198,15 +200,15 @@ subordinates instMap decl = case decl of , Just instName <- [M.lookup l instMap] ] extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) - extract_deriv_ty ty = - case dL ty of + extract_deriv_ty (L l ty) = + case ty of -- deriving (forall a. C a {- ^ Doc comment -}) - L l (HsForAllTy{ hst_fvf = ForallInvis - , hst_body = dL->L _ (HsDocTy _ _ doc) }) - -> Just (l, doc) + HsForAllTy{ hst_fvf = ForallInvis + , hst_body = L _ (HsDocTy _ _ doc) } + -> Just (l, doc) -- deriving (C a {- ^ Doc comment -}) - L l (HsDocTy _ _ doc) -> Just (l, doc) - _ -> Nothing + HsDocTy _ _ doc -> Just (l, doc) + _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) |