aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs22
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs26
-rw-r--r--haddock-api/src/Haddock/Convert.hs22
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs14
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs18
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs18
-rw-r--r--haddock-api/src/Haddock/Utils.hs4
8 files changed, 61 insertions, 69 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index dd10bb0a..fe656a4b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -145,7 +145,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} :
concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
where
addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
- addContext (MinimalSig sig) = MinimalSig sig
+ addContext (MinimalSig src sig) = MinimalSig src sig
addContext _ = error "expected TypeSig"
f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d
@@ -189,7 +189,7 @@ ppCtor dflags dat subdocs con
where
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
- f (RecCon recs) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
+ f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
[(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++
[out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
@@ -203,7 +203,7 @@ ppCtor dflags dat subdocs con
resType = case con_res con of
ResTyH98 -> apps $ map (reL . HsTyVar) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
- ResTyGADT x -> x
+ ResTyGADT _ x -> x
---------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index ee5bc861..125e1b3a 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -477,7 +477,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
+ -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
@@ -486,13 +486,13 @@ ppClassHdr summ lctxt n tvs fds unicode =
<+> ppFds fds unicode
-ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX
+ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX
ppFds fds unicode =
if null fds then empty else
char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
where
- fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
- hsep (map ppDocName vars2)
+ fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>
+ hsep (map (ppDocName . unLoc) vars2)
ppClassDecl :: [DocInstance DocName] -> SrcSpan
@@ -598,8 +598,8 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
(whereBit, leaders)
| null cons = (empty,[])
| otherwise = case resTy of
- ResTyGADT _ -> (decltt (keyword "where"), repeat empty)
- _ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
+ ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty)
+ _ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
constrBit
| null cons = Nothing
@@ -636,7 +636,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
map (ppLParendType unicode) args))
<-> rDoc mbDoc <+> nl
- RecCon fields ->
+ RecCon (L _ fields) ->
(decltt (header_ unicode <+> ppOcc)
<-> rDoc mbDoc <+> nl)
$$
@@ -648,11 +648,11 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
ppLParendType unicode arg2 ])
<-> rDoc mbDoc <+> nl
- ResTyGADT resTy -> case con_details con of
+ ResTyGADT _ resTy -> case con_details con of
-- prefix & infix could also use hsConDeclArgTys if it seemed to
-- simplify the code.
PrefixCon args -> doGADTCon args resTy
- cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
+ cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
doRecordFields fields
InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
@@ -948,8 +948,8 @@ ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
ppr_tylit :: HsTyLit -> Bool -> LaTeX
-ppr_tylit (HsNumTy n) _ = integer n
-ppr_tylit (HsStrTy s) _ = text (show s)
+ppr_tylit (HsNumTy _ n) _ = integer n
+ppr_tylit (HsStrTy _ s) _ = text (show s)
-- XXX: Ok in verbatim, but not otherwise
-- XXX: Do something with Unicode parameter?
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d24a3f04..405a13f8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -145,7 +145,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html
ppForAll tvs unicode qual =
- case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs tvs] of
+ case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of
[] -> noHtml
ts -> forallSymbol unicode <+> hsep ts +++ dot
where ppKTv n k = parens $
@@ -380,7 +380,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
+ -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]
-> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
@@ -389,13 +389,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual =
<+> ppFds fds unicode qual
-ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html
+ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html
ppFds fds unicode qual =
if null fds then noHtml else
char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
where
fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
- ppVars = hsep . map (ppDocName qual Prefix True)
+ ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
-> [(DocName, DocForDecl DocName)]
@@ -469,7 +469,7 @@ ppClassDecl summary links instances fixities loc d subdocs
-- there are different subdocs for different names in a single
-- type signature?
- minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of
+ minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of
-- Miminal complete definition = every shown method
And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns]
@@ -572,7 +572,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
whereBit
| null cons = noHtml
| otherwise = case resTy of
- ResTyGADT _ -> keyword "where"
+ ResTyGADT _ _ -> keyword "where"
_ -> noHtml
constrBit = subConstructors qual
@@ -600,7 +600,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
PrefixCon args ->
(header_ unicode qual +++ hsep (ppOcc
: map (ppLParendType unicode qual) args), noHtml, noHtml)
- RecCon fields ->
+ RecCon (L _ fields) ->
(header_ unicode qual +++ ppOcc <+> char '{',
doRecordFields fields,
char '}')
@@ -609,7 +609,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
ppOccInfix, ppLParendType unicode qual arg2],
noHtml, noHtml)
- ResTyGADT resTy -> case con_details con of
+ ResTyGADT _ resTy -> case con_details con of
-- prefix & infix could use hsConDeclArgTys if it seemed to
-- simplify the code.
PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)
@@ -617,7 +617,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
-- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
-- (except each field gets its own line in docs, to match
-- non-GADT records)
- RecCon fields -> (ppOcc <+> dcolon unicode <+>
+ RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+>
ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{',
doRecordFields fields,
char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
@@ -682,7 +682,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
ppLParendType unicode qual arg2]
<+> fixity
- ResTyGADT resTy -> case con_details con of
+ ResTyGADT _ resTy -> case con_details con of
-- prefix & infix could also use hsConDeclArgTys if it seemed to
-- simplify the code.
PrefixCon args -> doGADTCon args resTy
@@ -690,7 +690,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
fieldPart = case con_details con of
- RecCon fields -> [doRecordFields fields]
+ RecCon (L _ fields) -> [doRecordFields fields]
_ -> []
doRecordFields fields = subFields qual
@@ -907,8 +907,8 @@ ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name
ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
-ppr_tylit (HsNumTy n) = toHtml (show n)
-ppr_tylit (HsStrTy s) = toHtml (show s)
+ppr_tylit (HsNumTy _ n) = toHtml (show n)
+ppr_tylit (HsStrTy _ s) = toHtml (show s)
ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index ac7f8bd8..5cbf5f97 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -31,7 +31,7 @@ import Kind ( splitKindFunTys, synTyConResKind, isKind )
import Name
import PatSyn
import PrelNames (ipClassName)
-import SrcLoc ( Located, noLoc, unLoc )
+import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
import TcType ( tcSplitSigmaTy )
import TyCon
import Type (isStrLitTy, mkFunTys)
@@ -74,9 +74,9 @@ tyThingToLHsDecl t = case t of
, tcdLName = synifyName cl
, tcdTyVars = synifyTyVars (classTyVars cl)
, tcdFDs = map (\ (l,r) -> noLoc
- (map getName l, map getName r) ) $
+ (map (noLoc . getName) l, map (noLoc . getName) r) ) $
snd $ classTvsFds cl
- , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) :
+ , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) :
map (noLoc . synifyIdSig DeleteTopLevelQuantification)
(classMethods cl)
, tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
@@ -145,7 +145,7 @@ synifyTyCon coax tc
DataDecl { tcdLName = synifyName tc
, tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:
let mk_hs_tv realKind fakeTyVar
- = noLoc $ KindedTyVar (getName fakeTyVar)
+ = noLoc $ KindedTyVar (noLoc (getName fakeTyVar))
(synifyKindSig realKind)
in HsQTvs { hsq_kvs = [] -- No kind polymorphism
, hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
@@ -264,8 +264,8 @@ synifyDataCon use_gadt_syntax dc =
linear_tys = zipWith (\ty bang ->
let tySyn = synifyType WithinType ty
src_bang = case bang of
- HsUnpack {} -> HsSrcBang (Just True) True
- HsStrict -> HsSrcBang (Just False) True
+ HsUnpack {} -> HsSrcBang Nothing (Just True) True
+ HsStrict -> HsSrcBang Nothing (Just False) True
_ -> bang
in case src_bang of
HsNoBang -> tySyn
@@ -278,13 +278,13 @@ synifyDataCon use_gadt_syntax dc =
(dataConFieldLabels dc) linear_tys
hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
- (True,False) -> return $ RecCon field_tys
+ (True,False) -> return $ RecCon (noLoc field_tys)
(False,False) -> return $ PrefixCon linear_tys
(False,True) -> case linear_tys of
[a,b] -> return $ InfixCon a b
_ -> Left "synifyDataCon: infix with non-2 args?"
hs_res_ty = if use_gadt_syntax
- then ResTyGADT (synifyType WithinType res_ty)
+ then ResTyGADT noSrcSpan (synifyType WithinType res_ty)
else ResTyH98
-- finally we get synifyDataCon's result!
in hs_arg_tys >>=
@@ -312,7 +312,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
(kvs, tvs) = partition isKindVar ktvs
synifyTyVar tv
| isLiftedTypeKind kind = noLoc (UserTyVar name)
- | otherwise = noLoc (KindedTyVar name (synifyKindSig kind))
+ | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
where
kind = tyVarKind tv
name = getName tv
@@ -383,8 +383,8 @@ synifyType s forallty@(ForAllTy _tv _ty) =
synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
synifyTyLit :: TyLit -> HsTyLit
-synifyTyLit (NumTyLit n) = HsNumTy n
-synifyTyLit (StrTyLit s) = HsStrTy s
+synifyTyLit (NumTyLit n) = HsNumTy mempty n
+synifyTyLit (StrTyLit s) = HsStrTy mempty s
synifyKindSig :: Kind -> LHsKind Name
synifyKindSig k = synifyType WithinType k
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 416f5d71..5caefa77 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -91,8 +91,8 @@ filterSigNames p (FixSig (FixitySig ns ty)) =
case filter (p . unLoc) ns of
[] -> Nothing
filtered -> Just (FixSig (FixitySig filtered ty))
-filterSigNames _ orig@(MinimalSig _) = Just orig
-filterSigNames p (TypeSig ns ty nwcs) =
+filterSigNames _ orig@(MinimalSig _ _) = Just orig
+filterSigNames p (TypeSig ns ty nwcs) =
case filter (p . unLoc) ns of
[] -> Nothing
filtered -> Just (TypeSig filtered ty nwcs)
@@ -169,14 +169,6 @@ before :: Located a -> Located a -> Bool
before = (<) `on` getLoc
-instance Foldable (GenLocated l) where
- foldMap f (L _ x) = f x
-
-
-instance Traversable (GenLocated l) where
- mapM f (L l x) = (return . L l) =<< f x
- traverse f (L l x) = L l <$> f x
-
-------------------------------------------------------------------------------
-- * NamedThing instances
-------------------------------------------------------------------------------
@@ -197,7 +189,7 @@ class Parent a where
instance Parent (ConDecl Name) where
children con =
case con_details con of
- RecCon fields -> map unL $ concatMap (cd_fld_names . unL) fields
+ RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields)
_ -> []
instance Parent (TyClDecl Name) where
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 98a715a9..9ef3d1b1 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 $ map unLoc msg)
- WarningTxt msg -> format "Warning: " (concatFS $ map unLoc 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
@@ -335,7 +335,7 @@ subordinates instMap decl = case decl of
| c <- cons, cname <- con_names c ]
fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map con_details cons
- , L _ (ConDeclField ns _ doc) <- flds
+ , L _ (ConDeclField ns _ doc) <- (unLoc flds)
, n <- ns ]
-- | Extract function argument docs from inside types.
@@ -496,7 +496,7 @@ mkExportItems
Just exports -> liftM concat $ mapM lookupExport exports
where
lookupExport (IEVar (L _ x)) = declWith x
- lookupExport (IEThingAbs t) = declWith t
+ lookupExport (IEThingAbs (L _ t)) = declWith t
lookupExport (IEThingAll (L _ t)) = declWith t
lookupExport (IEThingWith (L _ t) _) = declWith t
lookupExport (IEModuleContents (L _ m)) =
@@ -553,7 +553,7 @@ mkExportItems
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef
return [ mkExportDecl t
(L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
@@ -745,7 +745,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
mdef <- liftGhcToErrMsgGhc $ minimalDef name
- let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . 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
@@ -785,7 +785,7 @@ 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_names = ns } <- map unLoc rec
+ , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
, L _ n <- ns
, n == name
]
@@ -818,13 +818,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case con_details con of
- RecCon fields | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
+ RecCon (L _ 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 = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ]
data_ty
- | ResTyGADT ty <- con_res con = 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 7f69b91e..ee9f8fc4 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -250,10 +250,10 @@ renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
renameLTyVarBndr (L loc (UserTyVar n))
= do { n' <- rename n
; return (L loc (UserTyVar n')) }
-renameLTyVarBndr (L loc (KindedTyVar n kind))
+renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))
= do { n' <- rename n
; kind' <- renameLKind kind
- ; return (L loc (KindedTyVar n' kind')) }
+ ; return (L loc (KindedTyVar (L lv n') kind')) }
renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
renameLContext (L loc context) = do
@@ -330,9 +330,9 @@ renameTyClD d = case d of
where
renameLFunDep (L loc (xs, ys)) = do
- xs' <- mapM rename xs
- ys' <- mapM rename ys
- return (L loc (xs', ys'))
+ xs' <- mapM rename (map unLoc xs)
+ ys' <- mapM rename (map unLoc ys)
+ return (L loc (map noLoc xs', map noLoc ys'))
renameLSig (L loc sig) = return . L loc =<< renameSig sig
@@ -377,9 +377,9 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
, con_details = details', con_res = restype', con_doc = mbldoc' })
where
- renameDetails (RecCon fields) = do
+ renameDetails (RecCon (L l fields)) = do
fields' <- mapM renameConDeclFieldField fields
- return (RecCon fields')
+ return (RecCon (L l fields'))
renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
renameDetails (InfixCon a b) = do
a' <- renameLType a
@@ -387,7 +387,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
return (InfixCon a' b')
renameResType (ResTyH98) = return ResTyH98
- renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+ renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t
renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
@@ -414,7 +414,7 @@ renameSig sig = case sig of
FixSig (FixitySig lnames fixity) -> do
lnames' <- mapM renameL lnames
return $ FixSig (FixitySig lnames' fixity)
- MinimalSig s -> MinimalSig <$> traverse renameL s
+ MinimalSig src s -> MinimalSig src <$> traverse renameL s
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 9a821b2e..4fed3a1e 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -154,8 +154,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
case con_details d of
PrefixCon _ -> Just d
RecCon fields
- | all field_avail fields -> Just d
- | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL fields)) })
+ | all field_avail (unL fields) -> Just d
+ | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) })
-- if we have *all* the field names available, then
-- keep the record declaration. Otherwise degrade to
-- a constructor declaration. This isn't quite right, but
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 12:33:10 +0000