aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface/Create.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Create.hs')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs118
1 files changed, 59 insertions, 59 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c119f3c3..bc93449f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -125,7 +125,7 @@ createInterface tm flags modMap instIfaceMap = do
$ map getName instances
++ map getName fam_instances
-- Locations of all TH splices
- splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
+ splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
@@ -406,9 +406,9 @@ mkMaps dflags gre instances decls = do
instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
names :: SrcSpan -> HsDecl GhcRn -> [Name]
- names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+ names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
where loc = case d of
- TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
+ TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only for TFs
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
names _ decl = getMainDeclBinder decl
@@ -433,16 +433,16 @@ subordinates :: InstMap
-> HsDecl GhcRn
-> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
- InstD (ClsInstD d) -> do
+ InstD _ (ClsInstD _ d) -> do
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 (DataFamInstDecl (HsIB { hsib_body = d })))
+ InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
-> dataSubs (feqn_rhs d)
- TyClD d | isClassDecl d -> classSubs d
- | isDataDecl d -> dataSubs (tcdDataDefn d)
+ TyClD _ d | isClassDecl d -> classSubs d
+ | isDataDecl d -> dataSubs (tcdDataDefn d)
_ -> []
where
classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
@@ -456,7 +456,7 @@ subordinates instMap decl = case decl of
| c <- cons, cname <- getConNames c ]
fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map getConArgs cons
- , L _ (ConDeclField ns _ doc) <- (unLoc flds)
+ , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
derivs = [ (instName, [unL doc], M.empty)
| HsIB { hsib_body = L l (HsDocTy _ _ doc) }
@@ -481,11 +481,11 @@ conArgDocs con = case getConArgs con of
-- | Extract function argument docs from inside top-level decls.
declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString
-declTypeDocs (SigD (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))
-declTypeDocs (SigD (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (SigD (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
+declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))
+declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
declTypeDocs _ = M.empty
-- | Extract function argument docs from inside types.
@@ -505,10 +505,10 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
where
decls = docs ++ defs ++ sigs ++ ats
- docs = mkDecls tcdDocs DocD class_
- defs = mkDecls (bagToList . tcdMeths) ValD class_
- sigs = mkDecls tcdSigs SigD class_
- ats = mkDecls tcdATs (TyClD . FamDecl) class_
+ 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_
-- | The top-level declarations of a module that we care about,
@@ -526,14 +526,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 group_ ++
- mkDecls hs_derivds DerivD group_ ++
- mkDecls hs_defds DefD group_ ++
- mkDecls hs_fords ForD group_ ++
- mkDecls hs_docs DocD group_ ++
- mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++
- mkDecls (typesigs . hs_valds) SigD group_ ++
- mkDecls (valbinds . hs_valds) ValD 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_
where
typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
typesigs _ = error "expected ValBindsOut"
@@ -564,14 +564,14 @@ sortByLoc = sortBy (comparing getLoc)
filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterDecls = filter (isHandled . unL . fst)
where
- isHandled (ForD (ForeignImport {})) = True
+ isHandled (ForD _ (ForeignImport {})) = True
isHandled (TyClD {}) = True
isHandled (InstD {}) = True
isHandled (DerivD {}) = True
- isHandled (SigD d) = isUserLSig (reL d)
- isHandled (ValD _) = True
+ isHandled (SigD _ d) = isUserLSig (reL d)
+ isHandled (ValD {}) = True
-- we keep doc declarations to be able to get at named docs
- isHandled (DocD _) = True
+ isHandled (DocD {}) = True
isHandled _ = False
@@ -580,8 +580,8 @@ filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
| x@(L loc d, doc) <- decls ]
where
- filterClass (TyClD c) =
- TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
+ filterClass (TyClD x c) =
+ TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
filterClass _ = error "expected TyClD"
@@ -600,10 +600,10 @@ collectDocs = go Nothing []
where
go Nothing _ [] = []
go (Just prev) docs [] = finished prev docs []
- go prev docs (L _ (DocD (DocCommentNext str)) : ds)
+ go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)
| Nothing <- prev = go Nothing (str:docs) ds
| Just decl <- prev = finished decl docs (go Nothing [str] ds)
- go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
+ go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds
go Nothing docs (d:ds) = go (Just d) docs ds
go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
@@ -644,22 +644,22 @@ mkExportItems
decls maps fixMap splices instIfaceMap dflags allExports
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do
+ lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do
doc <- processDocString dflags gre docStr
return [ExportGroup lev "" doc]
- lookupExport (IEDoc docStr, _) = liftErrMsg $ do
+ lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do
doc <- processDocStringParas dflags gre docStr
return [ExportDoc doc]
- lookupExport (IEDocNamed str, _) = liftErrMsg $
+ lookupExport (IEDocNamed _ str, _) = liftErrMsg $
findNamedDoc str [ unL d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags gre docStr
return [ExportDoc doc]
- lookupExport (IEModuleContents (L _ mod_name), _)
+ lookupExport (IEModuleContents _ (L _ mod_name), _)
-- only consider exporting a module if we are sure we
-- are really exporting the whole module and not some
-- subset. We also look through module aliases here.
@@ -696,7 +696,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let t = availName avail
r <- findDecl avail
case r of
- ([L l (ValD _)], (doc, _)) -> do
+ ([L l (ValD _ _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
@@ -721,17 +721,17 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
-- A single signature might refer to many names, but we
-- create an export item for a single name only. So we
-- modify the signature to contain only that single name.
- L loc (SigD sig) ->
+ 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 . fromJust $ filterSigNames (== t) sig
+ let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig
in availExportDecl avail newDecl docs_
- L loc (TyClD cl@ClassDecl{}) -> do
+ L loc (TyClD _ cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef
availExportDecl avail
- (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_
+ (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_
_ -> availExportDecl avail decl docs_
@@ -994,7 +994,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings exportedNames
for (getMainDeclBinder (unLoc decl)) $ \nm -> do
case lookupNameEnv availEnv nm of
Just avail
- | L _ (ValD valDecl) <- decl
+ | L _ (ValD _ valDecl) <- decl
, (name:_) <- collectHsBindBinders valDecl
, Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
-> pure []
@@ -1017,7 +1017,7 @@ extractDecl declMap name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
- TyClD d@ClassDecl {} ->
+ TyClD _ d@ClassDecl {} ->
let
matchesMethod =
[ lsig
@@ -1037,8 +1037,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 sig)
- (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl))
+ in L pos (SigD noExt sig)
+ (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl))
([], [])
| Just (famInstDecl:_) <- M.lookup name declMap
@@ -1047,21 +1047,21 @@ extractDecl declMap name decl
O.$$ O.nest 4 (O.ppr d)
O.$$ O.text "Matches:"
O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))
- TyClD d@DataDecl {} ->
+ TyClD _ d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
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))
- TyClD FamDecl {}
+ then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
+ else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ TyClD _ FamDecl {}
| isValName name
, Just (famInst:_) <- M.lookup name declMap
-> extractDecl declMap name famInst
- InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body =
+ 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 }) ->
+ SigD noExt <$> extractRecSel name n tys (dd_cons defn)
+ InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) ->
let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
<- insts
-- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
@@ -1071,7 +1071,7 @@ extractDecl declMap name decl
, extFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
@@ -1112,12 +1112,12 @@ 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 ->
+ 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)))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
- matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
+ matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds
, L l n <- ns, extFieldOcc n == nm ]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
@@ -1142,8 +1142,8 @@ mkVisibleNames (_, _, _, instMap) exports opts
where subs = map fst (expItemSubDocs e)
patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
- InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
- decl -> getMainDeclBinder decl
+ InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap
+ decl -> getMainDeclBinder decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
exportName _ = []
@@ -1184,7 +1184,7 @@ findNamedDoc name = search
search [] = do
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search (DocD (DocCommentNamed name' doc) : rest)
+ search (DocD _ (DocCommentNamed name' doc) : rest)
| name == name' = return (Just doc)
| otherwise = search rest
search (_other_decl : rest) = search rest
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 07:16:24 +0000