aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs31
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs26
2 files changed, 31 insertions, 26 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index da17ccc7..922fdcf7 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -194,8 +194,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
parseWarning dflags gre w = force $ case w of
- DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)
- WarningTxt msg -> format "Warning: " (concatFS msg)
+ DeprecatedTxt msg -> format "Deprecated: " (concatFS $ map unLoc msg)
+ WarningTxt msg -> format "Warning: " (concatFS $ map unLoc msg)
where
format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
. processDocString dflags gre $ HsDocString xs
@@ -331,11 +331,12 @@ subordinates instMap decl = case decl of
dataSubs dd = constrs ++ fields
where
cons = map unL $ (dd_cons dd)
- constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
- | c <- cons ]
+ constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
+ | c <- cons, cname <- con_names c ]
fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map con_details cons
- , ConDeclField n _ doc <- flds ]
+ , L _ (ConDeclField ns _ doc) <- flds
+ , n <- ns ]
-- | Extract function argument docs from inside types.
typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -381,7 +382,8 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
-- | Extract a map of fixity declarations only
mkFixMap :: HsGroup Name -> FixMap
mkFixMap group_ = M.fromList [ (n,f)
- | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]
+ | L _ (FixitySig ns f) <- hs_fixds group_,
+ L _ n <- ns ]
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
@@ -501,11 +503,11 @@ mkExportItems
Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEVar x) = declWith x
- lookupExport (IEThingAbs t) = declWith t
- lookupExport (IEThingAll t) = declWith t
- lookupExport (IEThingWith t _) = declWith t
- lookupExport (IEModuleContents m) =
+ lookupExport (IEVar (L _ x)) = declWith x
+ lookupExport (IEThingAbs t) = declWith t
+ lookupExport (IEThingAll (L _ t)) = declWith t
+ lookupExport (IEThingWith (L _ t) _) = declWith t
+ lookupExport (IEModuleContents (L _ m)) =
moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
lookupExport (IEGroup lev docStr) = return $
return . ExportGroup lev "" $ processDocString dflags gre docStr
@@ -791,7 +793,8 @@ extractDecl name mdl decl
InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
let matches = [ d | L _ d <- insts
, L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
- , ConDeclField { cd_fld_name = L _ n } <- rec
+ , ConDeclField { cd_fld_names = ns } <- map unLoc rec
+ , L _ n <- ns
, n == name
]
in case matches of
@@ -823,11 +826,11 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case con_details con of
- RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
+ RecCon fields | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))
_ -> extractRecSel nm mdl t tvs rest
where
- matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
+ matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ]
data_ty
| ResTyGADT ty <- con_res con = ty
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index a5717a58..77159472 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -259,7 +259,6 @@ renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-
renameInstHead :: InstHead Name -> RnM (InstHead DocName)
renameInstHead (className, k, types, rest) = do
className' <- rename className
@@ -364,19 +363,22 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
renameCon :: ConDecl Name -> RnM (ConDecl DocName)
-renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
+renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
, con_cxt = lcontext, con_details = details
, con_res = restype, con_doc = mbldoc }) = do
- lname' <- renameL lname
+ lnames' <- mapM renameL lnames
ltyvars' <- renameLTyVarBndrs ltyvars
lcontext' <- renameLContext lcontext
details' <- renameDetails details
restype' <- renameResType restype
mbldoc' <- mapM renameLDocHsSyn mbldoc
- return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
+ return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext'
, con_details = details', con_res = restype', con_doc = mbldoc' })
+
where
- renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields
+ renameDetails (RecCon fields) = do
+ fields' <- mapM renameConDeclFieldField fields
+ return (RecCon fields')
renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
renameDetails (InfixCon a b) = do
a' <- renameLType a
@@ -387,12 +389,12 @@ renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
-renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)
-renameConDeclFieldField (ConDeclField name t doc) = do
- name' <- renameL name
+renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
+renameConDeclFieldField (L l (ConDeclField names t doc)) = do
+ names' <- mapM renameL names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
- return (ConDeclField name' t' doc')
+ return $ L l (ConDeclField names' t' doc')
renameSig :: Sig Name -> RnM (Sig DocName)
@@ -408,9 +410,9 @@ renameSig sig = case sig of
lprov' <- renameLContext lprov
lty' <- renameLType lty
return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
- FixSig (FixitySig lname fixity) -> do
- lname' <- renameL lname
- return $ FixSig (FixitySig lname' fixity)
+ FixSig (FixitySig lnames fixity) -> do
+ lnames' <- mapM renameL lnames
+ return $ FixSig (FixitySig lnames' fixity)
MinimalSig s -> MinimalSig <$> traverse renameL s
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-19 23:59:00 +0000