diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2014-09-09 01:03:27 -0500 |
---|---|---|
committer | Austin Seipp <aseipp@pobox.com> | 2015-01-23 07:17:19 -0600 |
commit | 89fc5605c865d0e0ce5ed7e396102e678426533b (patch) | |
tree | 873726ccbc276f413a793e537c015e8445951e5b | |
parent | df0239b587e2a25531962f5b46f715ebb9b09685 (diff) |
Follow API changes in D538
Signed-off-by: Austin Seipp <aseipp@pobox.com>
(cherry picked from commit d61bbc75890e4eb0ad508b9c2a27b91f691213e6)
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 6 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 22 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 26 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 22 | ||||
-rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 14 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 18 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 18 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Utils.hs | 4 |
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 |