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/AttachInstances.hs13
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs204
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs61
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs21
5 files changed, 211 insertions, 91 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index f00da3ea..d5d74819 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -169,15 +169,15 @@ instHead (_, _, cls, args)
= (map argCount args, className cls, map simplify args)
argCount :: Type -> Int
-argCount (AppTy t _) = argCount t + 1
+argCount (AppTy t _) = argCount t + 1
argCount (TyConApp _ ts) = length ts
-argCount (ForAllTy (Anon _) _ ) = 2
-argCount (ForAllTy _ t) = argCount t
-argCount (CastTy t _) = argCount t
+argCount (FunTy _ _ ) = 2
+argCount (ForAllTy _ t) = argCount t
+argCount (CastTy t _) = argCount t
argCount _ = 0
simplify :: Type -> SimpleType
-simplify (ForAllTy (Anon 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
@@ -239,8 +239,9 @@ isTypeHidden expInfo = typeHidden
case t of
TyVarTy {} -> False
AppTy 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 (binderType bndr) || typeHidden ty
+ ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty
LitTy _ -> False
CastTy ty _ -> typeHidden ty
CoercionTy {} -> False
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index cb855693..e594feae 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -11,6 +11,10 @@
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
+--
+-- This module provides a single function 'createInterface',
+-- which creates a Haddock 'Interface' from the typechecking
+-- results 'TypecheckedModule' from GHC.
-----------------------------------------------------------------------------
module Haddock.Interface.Create (createInterface) where
@@ -47,14 +51,18 @@ import Bag
import RdrName
import TcRnTypes
import FastString (concatFS)
-import BasicTypes ( StringLiteral(..) )
+import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
import HsDecls ( getConDetails )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
+createInterface :: TypecheckedModule
+ -> [Flag] -- Boolean flags
+ -> IfaceMap -- Locally processed modules
+ -> InstIfaceMap -- External, already installed interfaces
+ -> ErrMsgGhc Interface
createInterface tm flags modMap instIfaceMap = do
let ms = pm_mod_summary . tm_parsed_module $ tm
@@ -62,6 +70,8 @@ createInterface tm flags modMap instIfaceMap = do
L _ hsm = parsedSource tm
!safety = modInfoSafe mi
mdl = ms_mod ms
+ sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm))
+ is_sig = ms_hsc_src ms == HsigFile
dflags = ms_hspp_opts ms
!instances = modInfoInstances mi
!fam_instances = md_fam_insts md
@@ -83,13 +93,15 @@ createInterface tm flags modMap instIfaceMap = do
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
+ -- Process the top-level module header documentation.
(!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
- localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
- ++ map getName fam_instances
+ localInsts = filter (nameIsLocalOrFrom sem_mdl)
+ $ map getName instances
+ ++ map getName fam_instances
-- Locations of all TH splices
splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
@@ -104,7 +116,9 @@ createInterface tm flags modMap instIfaceMap = do
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
- exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
+ -- The MAIN functionality: compute the export items which will
+ -- each be the actual documentation of this module.
+ exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls
maps fixMap splices exports instIfaceMap dflags
let !visibleNames = mkVisibleNames maps exportItems opts
@@ -130,6 +144,7 @@ createInterface tm flags modMap instIfaceMap = do
return $! Interface {
ifaceMod = mdl
+ , ifaceIsSig = is_sig
, ifaceOrigFilename = msHsFilePath ms
, ifaceInfo = info
, ifaceDoc = Documentation mbDoc modWarn
@@ -156,6 +171,10 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceTokenizedSrc = tokenizedSrc
}
+-- | Given all of the @import M as N@ declarations in a package,
+-- create a mapping from the module identity of M, to an alias N
+-- (if there are multiple aliases, we pick the last one.) This
+-- will go in 'ifaceModuleAliases'.
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
mkAliasMap dflags mRenamedSource =
case mRenamedSource of
@@ -163,16 +182,31 @@ mkAliasMap dflags mRenamedSource =
Just (_,impDecls,_,_) ->
M.fromList $
mapMaybe (\(SrcLoc.L _ impDecl) -> do
- alias <- ideclAs impDecl
+ SrcLoc.L _ alias <- ideclAs impDecl
return $
(lookupModuleDyn dflags
+ -- TODO: This is supremely dodgy, because in general the
+ -- UnitId isn't going to look anything like the package
+ -- qualifier (even with old versions of GHC, the
+ -- IPID would be p-0.1, but a package qualifier never
+ -- has a version number it. (Is it possible that in
+ -- Haddock-land, the UnitIds never have version numbers?
+ -- I, ezyang, have not quite understand Haddock's package
+ -- identifier model.)
+ --
+ -- Additionally, this is simulating some logic GHC already
+ -- has for deciding how to qualify names when it outputs
+ -- them to the user. We should reuse that information;
+ -- or at least reuse the renamed imports, which know what
+ -- they import!
(fmap Module.fsToUnitId $
fmap sl_fs $ ideclPkgQual impDecl)
(case ideclName impDecl of SrcLoc.L _ name -> name),
alias))
impDecls
--- similar to GHC.lookupModule
+-- Similar to GHC.lookupModule
+-- ezyang: Not really...
lookupModuleDyn ::
DynFlags -> Maybe UnitId -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
@@ -305,16 +339,16 @@ mkMaps dflags gre instances decls =
where loc = case d of
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
-- Note [2]:
------------
--- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.
--- That should work for normal user-written instances (from looking at GHC
--- sources). We can assume that commented instances are user-written.
--- This lets us relate Names (from ClsInsts) to comments (associated
--- with InstDecls).
-
+-- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
+-- inside them. That should work for normal user-written instances (from
+-- looking at GHC sources). We can assume that commented instances are
+-- user-written. This lets us relate Names (from ClsInsts) to comments
+-- (associated with InstDecls and DerivDecls).
--------------------------------------------------------------------------------
-- Declarations
@@ -322,6 +356,8 @@ mkMaps dflags gre instances decls =
-- | Get all subordinate declarations inside a declaration, and their docs.
+-- A subordinate declaration is something like the associate type or data
+-- family of a type class.
subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
InstD (ClsInstD d) -> do
@@ -338,7 +374,7 @@ subordinates instMap decl = case decl of
, name <- getMainDeclBinder d, not (isValD d)
]
dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]
- dataSubs dd = constrs ++ fields
+ dataSubs dd = constrs ++ fields ++ derivs
where
cons = map unL $ (dd_cons dd)
constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
@@ -347,6 +383,11 @@ subordinates instMap decl = case decl of
| RecCon flds <- map getConDetails cons
, 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
+ , Just instName <- [M.lookup l instMap] ]
-- | Extract function argument docs from inside types.
typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -394,12 +435,12 @@ mkFixMap group_ = M.fromList [ (n,f)
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup Name -> [LHsDecl Name]
ungroup group_ =
- mkDecls (tyClGroupConcat . hs_tyclds) TyClD 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 hs_instds InstD group_ ++
+ mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++
mkDecls (typesigs . hs_valds) SigD group_ ++
mkDecls (valbinds . hs_valds) ValD group_
where
@@ -433,8 +474,9 @@ filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterDecls = filter (isHandled . unL . fst)
where
isHandled (ForD (ForeignImport {})) = True
- isHandled (TyClD {}) = True
- isHandled (InstD {}) = True
+ isHandled (TyClD {}) = True
+ isHandled (InstD {}) = True
+ isHandled (DerivD {}) = True
isHandled (SigD d) = isUserLSig (reL d)
isHandled (ValD _) = True
-- we keep doc declarations to be able to get at named docs
@@ -484,12 +526,14 @@ collectDocs = go Nothing []
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: IfaceMap
+ :: Bool -- is it a signature
+ -> IfaceMap
-> Module -- this module
+ -> Module -- semantic module
-> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
- -> [LHsDecl Name]
+ -> [LHsDecl Name] -- renamed source declarations
-> Maps
-> FixMap
-> [SrcSpan] -- splice locations
@@ -498,17 +542,22 @@ mkExportItems
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
- modMap thisMod warnings gre exportedNames decls
+ is_sig modMap thisMod semMod warnings gre exportedNames decls
maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
case optExports of
Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEVar (L _ x)) = declWith x
- lookupExport (IEThingAbs (L _ t)) = declWith t
- lookupExport (IEThingAll (L _ t)) = declWith t
- lookupExport (IEThingWith (L _ t) _ _ _) = declWith t
+ lookupExport (IEVar (L _ x)) = declWith $ ieWrappedName x
+ lookupExport (IEThingAbs (L _ t)) = declWith $ ieWrappedName t
+ lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t
+ lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t
lookupExport (IEModuleContents (L _ m)) =
+ -- TODO: We could get more accurate reporting here if IEModuleContents
+ -- also recorded the actual names that are exported here. We CAN
+ -- compute this info using @gre@ but 'moduleExports does not seem to
+ -- do so.
+ -- NB: Pass in identity module, so we can look it up in index correctly
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
@@ -522,8 +571,9 @@ mkExportItems
Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
- declWith t =
- case findDecl t of
+ declWith t = do
+ r <- findDecl t
+ case r of
([L l (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
@@ -562,7 +612,7 @@ mkExportItems
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
return [ mkExportDecl t
(L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
@@ -576,6 +626,8 @@ mkExportItems
Just decl ->
-- We try to get the subs and docs
-- from the installed .haddock file for that package.
+ -- TODO: This needs to be more sophisticated to deal
+ -- with signature inheritance
case M.lookup (nameModule t) instIfaceMap of
Nothing -> do
liftErrMsg $ tell
@@ -591,8 +643,7 @@ mkExportItems
mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
mkExportDecl name decl (doc, subs) = decl'
where
- decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
- mdl = nameModule name
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False
subs' = filter (isExported . fst) subs
sub_names = map fst subs'
fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
@@ -601,16 +652,41 @@ mkExportItems
isExported = (`elem` exportedNames)
- findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl n
- | m == thisMod, Just ds <- M.lookup n declMap =
- (ds, lookupDocs n warnings docMap argMap subMap)
- | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
- (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
- | otherwise = ([], (noDocForDecl, []))
+ | m == semMod =
+ case M.lookup n declMap of
+ Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap)
+ Nothing
+ | is_sig -> do
+ -- OK, so it wasn't in the local declaration map. It could
+ -- have been inherited from a signature. Reconstitute it
+ -- from the type.
+ mb_r <- hiDecl dflags n
+ case mb_r of
+ Nothing -> return ([], (noDocForDecl, []))
+ -- TODO: If we try harder, we might be able to find
+ -- a Haddock! Look in the Haddocks for each thing in
+ -- requirementContext (pkgState)
+ Just decl -> return ([decl], (noDocForDecl, []))
+ | otherwise ->
+ return ([], (noDocForDecl, []))
+ | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+ , Just ds <- M.lookup n (ifaceDeclMap iface) =
+ return (ds, lookupDocs n warnings
+ (ifaceDocMap iface)
+ (ifaceArgMap iface)
+ (ifaceSubMap iface))
+ | otherwise = return ([], (noDocForDecl, []))
where
m = nameModule n
+-- | Given a 'Module' from a 'Name', convert it into a 'Module' that
+-- we can actually find in the 'IfaceMap'.
+semToIdMod :: UnitId -> Module -> Module
+semToIdMod this_uid m
+ | Module.isHoleModule m = mkModule this_uid (moduleName m)
+ | otherwise = m
hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
hiDecl dflags t = do
@@ -673,13 +749,13 @@ lookupDocs n warnings docMap argMap subMap =
-- only return those that are.
-- 3) B is visible and all its exports are in scope, in which case we return
-- a single 'ExportModule' item.
-moduleExports :: Module -- ^ Module A
+moduleExports :: Module -- ^ Module A (identity, NOT semantic)
-> ModuleName -- ^ The real name of B, the exported module
-> DynFlags -- ^ The flags used when typechecking A
-> WarningMap
-> GlobalRdrEnv -- ^ The renaming environment used for A
-> [Name] -- ^ All the exports of A
- -> [LHsDecl Name] -- ^ All the declarations in A
+ -> [LHsDecl Name] -- ^ All the renamed declarations in A
-> IfaceMap -- ^ Already created interfaces
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
@@ -687,8 +763,11 @@ moduleExports :: Module -- ^ Module A
-> [SrcSpan] -- ^ Locations of all TH splices
-> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
- | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
+ | expMod == moduleName thisMod
+ = fullModuleContents dflags warnings gre maps fixMap splices decls
| otherwise =
+ -- NB: we constructed the identity module when looking up in
+ -- the IfaceMap.
case M.lookup m ifaceMap of
Just iface
| OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
@@ -704,7 +783,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
"documentation for exported module: " ++ pretty dflags expMod]
return []
where
- m = mkModule unitId expMod
+ m = mkModule unitId expMod -- Identity module!
unitId = moduleUnitId thisMod
@@ -725,8 +804,17 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
-- (For more information, see Trac #69)
-fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
- -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+-- | Simplified variant of 'mkExportItems', where we can assume that
+-- every locally defined declaration is exported; thus, we just
+-- zip through the renamed declarations.
+fullModuleContents :: DynFlags
+ -> WarningMap
+ -> GlobalRdrEnv -- ^ The renaming environment
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- ^ Locations of all TH splices
+ -> [LHsDecl Name] -- ^ All the renamed declarations
+ -> ErrMsgGhc [ExportItem Name]
fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
@@ -756,11 +844,13 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
| otherwise = return Nothing
mkExportItem decl@(L l (InstD d))
| Just name <- M.lookup (getInstLoc d) instMap =
- let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ expInst decl l name
+ mkExportItem decl@(L l (DerivD {}))
+ | Just name <- M.lookup l instMap =
+ expInst decl l name
mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
mdef <- liftGhcToErrMsgGhc $ minimalDef name
- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
mkExportItem decl@(L l d)
| name:_ <- getMainDeclBinder d = expDecl decl l name
@@ -772,13 +862,17 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
where (doc, subs) = lookupDocs name warnings docMap argMap subMap
+ expInst decl l name =
+ let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
+ return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
-extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
-extractDecl name mdl decl
+extractDecl :: Name -> LHsDecl Name -> LHsDecl Name
+extractDecl name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
@@ -800,11 +894,11 @@ extractDecl name mdl decl
O.$$ O.nest 4 (O.ppr matches))
TyClD d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
- in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))
+ in 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 }) ->
- SigD <$> extractRecSel name mdl n tys (dd_cons 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)
@@ -814,19 +908,19 @@ extractDecl name mdl decl
, selectorFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
-extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
+extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
-> LSig Name
-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
-extractRecSel nm mdl t tvs (L _ con : rest) =
+extractRecSel nm t tvs (L _ con : rest) =
case getConDetails con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
- _ -> extractRecSel nm mdl t tvs rest
+ _ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
@@ -834,7 +928,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = hsib_body $ con_type con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 4f6b2c09..608344ad 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -31,6 +31,7 @@ import Haddock.Types
import Name
import Outputable ( showPpr )
import RdrName
+import EnumSet
import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
@@ -67,7 +68,7 @@ processModuleHeader dflags gre safety mayStr = do
let flags :: [LangExt.Extension]
-- We remove the flags implied by the language setting and we display the language instead
- flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
+ flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)
return (hmi { hmi_safety = Just $ showPpr dflags safety
, hmi_language = language dflags
, hmi_extensions = flags
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 3054e2f9..b43860fb 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -179,7 +179,7 @@ renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName)
renameLSigType = renameImplicit renameLType
renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)
-renameLSigWcType = renameImplicit (renameWc renameLType)
+renameLSigWcType = renameWc (renameImplicit renameLType)
renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
renameLKind = renameLType
@@ -219,7 +219,7 @@ renameType t = case t of
ltype' <- renameLType ltype
return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n
+ HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n
HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
HsAppTy a b -> do
@@ -238,6 +238,7 @@ renameType t = case t of
HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+ HsSumTy ts -> HsSumTy <$> mapM renameLType ts
HsOpTy a (L loc op) b -> do
op' <- rename op
@@ -261,7 +262,7 @@ renameType t = case t of
HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
HsCoreTy a -> pure (HsCoreTy a)
- HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b
+ HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
@@ -328,6 +329,9 @@ renameDecl decl = case decl of
InstD d -> do
d' <- renameInstD d
return (InstD d')
+ DerivD d -> do
+ d' <- renameDerivD d
+ return (DerivD d')
_ -> error "renameDecl"
renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))
@@ -340,19 +344,19 @@ renameTyClD d = case d of
decl' <- renameFamilyDecl decl
return (FamDecl { tcdFam = decl' })
- SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do
+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
rhs' <- renameLType rhs
- return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames })
+ return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames })
- DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do
+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })
+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })
- ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
+ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
lcontext' <- renameLContext lcontext
lname' <- renameL lname
@@ -363,6 +367,7 @@ renameTyClD d = case d of
at_defs' <- mapM renameLTyFamDefltEqn 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 = [], tcdFVs = placeHolderNames })
@@ -376,7 +381,9 @@ renameTyClD d = case d of
renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
- , fdTyVars = ltyvars, fdResultSig = result
+ , fdTyVars = ltyvars
+ , fdFixity = fixity
+ , fdResultSig = result
, fdInjectivityAnn = injectivity }) = do
info' <- renameFamilyInfo info
lname' <- renameL lname
@@ -384,7 +391,9 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
return (FamilyDecl { fdInfo = info', fdLName = lname'
- , fdTyVars = ltyvars', fdResultSig = result'
+ , fdTyVars = ltyvars'
+ , fdFixity = fixity
+ , fdResultSig = result'
, fdInjectivityAnn = injectivity' })
@@ -412,7 +421,8 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
cons' <- mapM (mapM renameCon) cons
-- I don't think we need the derivings, so we return Nothing
return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
- , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
+ , dd_kindSig = k', dd_cons = cons'
+ , dd_derivs = noLoc [] })
renameCon :: ConDecl Name -> RnM (ConDecl DocName)
renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars
@@ -467,10 +477,10 @@ renameSig sig = case sig of
lnames' <- mapM renameL lnames
ltype' <- renameLSigType sig_ty
return (ClassOpSig is_default lnames' ltype')
- PatSynSig lname sig_ty -> do
- lname' <- renameL lname
+ PatSynSig lnames sig_ty -> do
+ lnames' <- mapM renameL lnames
sig_ty' <- renameLSigType sig_ty
- return $ PatSynSig lname' sig_ty'
+ return $ PatSynSig lnames' sig_ty'
FixSig (FixitySig lnames fixity) -> do
lnames' <- mapM renameL lnames
return $ FixSig (FixitySig lnames' fixity)
@@ -503,6 +513,15 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do
d' <- renameDataFamInstD d
return (DataFamInstD { dfid_inst = d' })
+renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName)
+renameDerivD (DerivDecl { deriv_type = ty
+ , deriv_strategy = strat
+ , deriv_overlap_mode = omode }) = do
+ ty' <- renameLSigType ty
+ return (DerivDecl { deriv_type = ty'
+ , deriv_strategy = strat
+ , deriv_overlap_mode = omode })
+
renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
, cid_poly_ty =ltype, cid_tyfam_insts = lATs
@@ -523,30 +542,33 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
, tfid_fvs = placeHolderNames }) }
renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)
-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs }))
+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' })) }
renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
-renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))
+renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_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' })) }
renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn })
+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 }) }
renameImplicit :: (in_thing -> RnM out_thing)
@@ -555,7 +577,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_vars = PlaceHolder }) }
+ , hsib_vars = PlaceHolder
+ , hsib_closed = PlaceHolder }) }
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs Name in_thing
@@ -563,7 +586,7 @@ renameWc :: (in_thing -> RnM out_thing)
renameWc rn_thing (HsWC { hswc_body = thing })
= do { thing' <- rn_thing thing
; return (HsWC { hswc_body = thing'
- , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }
+ , hswc_wcs = PlaceHolder }) }
renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName)
renameDocInstance (inst, idoc, L l n) = do
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index ab719fe8..28bbf305 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name)
specialize name details =
everywhere $ mkT step
where
- step (HsTyVar (L _ name')) | name == name' = details
+ step (HsTyVar _ (L _ name')) | name == name' = details
step typ = typ
@@ -81,10 +81,10 @@ specializeSig :: forall name . (Eq name, DataId name, SetName name)
-> Sig name
-> Sig name
specializeSig bndrs typs (TypeSig lnames typ) =
- TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}})
+ TypeSig lnames (typ { hswc_body = (hswc_body typ) { hsib_body = noLoc typ'}})
where
true_type :: HsType name
- true_type = unLoc (hswc_body (hsib_body typ))
+ true_type = unLoc (hsSigWcType typ)
typ' :: HsType name
typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type
fv = foldr Set.union Set.empty . map freeVariables $ typs
@@ -123,7 +123,7 @@ sugar =
sugarLists :: NamedThing name => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)
+sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
| isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
where
name' = getName name
@@ -137,7 +137,7 @@ sugarTuples typ =
where
aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
aux apps (HsParTy (L _ typ')) = aux apps typ'
- aux apps (HsTyVar (L _ name))
+ aux apps (HsTyVar _ (L _ name))
| isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
where
name' = getName name
@@ -149,7 +149,7 @@ sugarTuples typ =
sugarOperators :: NamedThing name => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb)
+sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
| isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
where
@@ -224,7 +224,7 @@ freeVariables =
query term ctx = case cast term :: Maybe (HsType name) of
Just (HsForAllTy bndrs _) ->
(Set.empty, Set.union ctx (bndrsNames bndrs))
- Just (HsTyVar (L _ name))
+ Just (HsTyVar _ (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
| otherwise -> (Set.singleton $ getNameRep name, ctx)
_ -> (Set.empty, ctx)
@@ -267,12 +267,13 @@ renameType (HsQualTy lctxt lt) =
HsQualTy
<$> located renameContext lctxt
<*> renameLType lt
-renameType (HsTyVar name) = HsTyVar <$> located renameName name
+renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name
renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
renameType (HsListTy lt) = HsListTy <$> renameLType lt
renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
+renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt
renameType (HsOpTy la lop lb) =
HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
renameType (HsParTy lt) = HsParTy <$> renameLType lt
@@ -284,8 +285,8 @@ renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
renameType t@(HsRecTy _) = pure t
renameType t@(HsCoreTy _) = pure t
-renameType (HsExplicitListTy ph ltys) =
- HsExplicitListTy ph <$> renameLTypes ltys
+renameType (HsExplicitListTy ip ph ltys) =
+ HsExplicitListTy ip ph <$> renameLTypes ltys
renameType (HsExplicitTupleTy phs ltys) =
HsExplicitTupleTy phs <$> renameLTypes ltys
renameType t@(HsTyLit _) = pure t
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-15 01:04:39 +0000