diff options
Diffstat (limited to 'src/Haddock/Interface')
| -rw-r--r-- | src/Haddock/Interface/AttachInstances.hs | 7 | ||||
| -rw-r--r-- | src/Haddock/Interface/Create.hs | 58 | ||||
| -rw-r--r-- | src/Haddock/Interface/LexParseRn.hs | 26 | ||||
| -rw-r--r-- | src/Haddock/Interface/Rename.hs | 130 |
4 files changed, 127 insertions, 94 deletions
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index d9f4350f..50451666 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -91,7 +91,7 @@ lookupInstDoc name iface ifaceMap instIfaceMap = -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. -getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) +getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst])) getAllInfo name = withSession $ \hsc_env -> do (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name return r @@ -106,7 +106,9 @@ getAllInfo name = withSession $ \hsc_env -> do -- in Haddock output) and unifying special tycons with normal ones. -- For the benefit of the user (looks nice and predictable) and the -- tests (which prefer output to be deterministic). -data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord) +data SimpleType = SimpleType Name [SimpleType] + | SimpleTyLit TyLit + deriving (Eq,Ord) instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) @@ -126,6 +128,7 @@ instHead (_, _, cls, args) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) + simplify (LitTy l) = SimpleTyLit l -- sortImage f = sortBy (\x y -> compare (f x) (f y)) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 32d187a5..64995a5f 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -86,7 +86,7 @@ createInterface tm flags modMap instIfaceMap = do | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - liftErrMsg $ warnAboutFilteredDecls mdl decls + liftErrMsg $ warnAboutFilteredDecls dflags mdl decls let warningMap = mkWarningMap warnings gre exportedNames exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports @@ -224,13 +224,12 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) - -- | Create 'Maps' by looping through the declarations. For each declaration, -- find its names, its subordinates, and its doc strings. Process doc strings -- into 'Doc's. mkMaps :: DynFlags -> GlobalRdrEnv - -> [Instance] + -> [ClsInst] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps mkMaps dflags gre instances decls = do @@ -261,16 +260,15 @@ mkMaps dflags gre instances decls = do instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] names :: HsDecl Name -> [Name] - names (InstD (InstDecl (L l _) _ _ _)) = maybeToList (M.lookup l instanceMap) -- See note [2]. + names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap) -- See note [2]. names decl = getMainDeclBinder decl - -- Note [2]: ------------ --- We relate Instances to InstDecls using the SrcSpans buried inside them. +-- 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 Instances) to comments (associated +-- This lets us relate Names (from ClsInsts) to comments (associated -- with InstDecls). @@ -290,7 +288,7 @@ subordinates (TyClD decl) ] dataSubs = constrs ++ fields where - cons = map unL $ tcdCons decl + cons = map unL $ (td_cons (tcdTyDefn decl)) constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) @@ -306,7 +304,7 @@ typeDocs d = case d of SigD (TypeSig _ ty) -> docs (unLoc ty) ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) - TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty) + TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty) _ -> M.empty where go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) @@ -364,11 +362,11 @@ sortByLoc :: [Located a] -> [Located a] sortByLoc = sortBy (comparing getLoc) -warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM () -warnAboutFilteredDecls mdl decls = do +warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM () +warnAboutFilteredDecls dflags mdl decls = do let modStr = moduleString mdl let typeInstances = - nub [ tcdName d | L _ (TyClD d) <- decls, isFamInstDecl d ] + nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ] unless (null typeInstances) $ tell [ @@ -377,7 +375,7 @@ warnAboutFilteredDecls mdl decls = do ++ "will be filtered out:\n " ++ (intercalate ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls + let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls , not (null ats) ] unless (null instances) $ @@ -457,7 +455,7 @@ mkExportItems -> [LHsDecl Name] -> Maps -> Maybe [IE Name] - -> [Instance] + -> [ClsInst] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name] @@ -501,7 +499,7 @@ mkExportItems case findDecl t of ([L _ (ValD _)], (doc, _)) -> do -- Top-level binding without type signature - export <- hiValExportItem t doc + export <- hiValExportItem dflags t doc return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) @@ -518,8 +516,8 @@ mkExportItems Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ - pretty (nameOccName t) ++ " is exported separately but " ++ - "will be documented under " ++ pretty (nameOccName p) ++ + pretty dflags (nameOccName t) ++ " is exported separately but " ++ + "will be documented under " ++ pretty dflags (nameOccName p) ++ ". Consider exporting it together with its parent(s)" ++ " for code clarity." ] return [] @@ -539,7 +537,7 @@ mkExportItems -- Declaration from another package ([], _) -> do - mayDecl <- hiDecl t + mayDecl <- hiDecl dflags t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] Just decl -> @@ -548,7 +546,7 @@ mkExportItems case M.lookup (nameModule t) instIfaceMap of Nothing -> do liftErrMsg $ tell - ["Warning: Couldn't find .haddock for export " ++ pretty t] + ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> @@ -580,19 +578,19 @@ mkExportItems m = nameModule n -hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) -hiDecl t = do +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of Nothing -> do - liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty t] + liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] return Nothing Just x -> return (Just (tyThingToLHsDecl x)) -hiValExportItem :: Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name) -hiValExportItem name doc = do - mayDecl <- hiDecl name +hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name doc = do + mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) Just decl -> return (ExportDecl decl doc [] []) @@ -648,8 +646,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do liftErrMsg $ - tell ["Warning: " ++ pretty thisMod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty expMod] + tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod] return [] where m = mkModule packageId expMod @@ -701,7 +699,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem name doc) + fmap Just (hiValExportItem dflags name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = @@ -729,7 +727,7 @@ extractDecl name mdl decl _ -> error "internal: extractDecl" TyClD d | isDataDecl d -> let (n, tyvar_names) = name_and_tyvars d - L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d) + L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d)) in L pos (SigD sig) _ -> error "internal: extractDecl" where @@ -744,7 +742,7 @@ extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of L _ (HsForAllTy expl tvs (L _ preds) ty) -> L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) - _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) + _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) where lctxt = noLoc . ctxt ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index de006386..a5eb1143 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -61,7 +61,7 @@ process parse dflags gre (HsDocString fs) = do Nothing -> do tell [ "doc comment parse failed: " ++ str ] return Nothing - Just doc -> return (Just (rename gre doc)) + Just doc -> return (Just (rename dflags gre doc)) processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString @@ -69,6 +69,7 @@ processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsD processModuleHeader dflags gre safety mayStr = do (hmi, doc) <- case mayStr of + Nothing -> return failure Just (L _ (HsDocString fs)) -> do let str = unpackFS fs @@ -77,16 +78,16 @@ processModuleHeader dflags gre safety mayStr = do tell ["haddock module header parse failed: " ++ msg] return failure Right (hmi, doc) -> do - let hmi' = hmi { hmi_description = rename gre <$> hmi_description hmi } - doc' = rename gre doc + let hmi' = hmi { hmi_description = rename dflags gre <$> hmi_description hmi } + doc' = rename dflags gre doc return (hmi', Just doc') - return (hmi { hmi_safety = Just $ showPpr safety }, doc) + return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc) where failure = (emptyHaddockModInfo, Nothing) -rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name -rename gre = rn +rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename dflags gre = rn where rn d = case d of DocAppend a b -> DocAppend (rn a) (rn b) @@ -97,9 +98,10 @@ rename gre = rn case names of [] -> case choices of - [] -> DocMonospaced (DocString (showSDoc $ ppr x)) - [a] -> outOfScope a - a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b + [] -> DocMonospaced (DocString (showPpr dflags x)) + [a] -> outOfScope dflags a + a:b:_ | isRdrTc a -> outOfScope dflags a + | otherwise -> outOfScope dflags b [a] -> DocIdentifier a a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b -- If an id can refer to multiple things, we give precedence to type @@ -121,12 +123,12 @@ rename gre = rn DocString str -> DocString str -outOfScope :: RdrName -> Doc a -outOfScope x = +outOfScope :: DynFlags -> RdrName -> Doc a +outOfScope dflags x = case x of Unqual occ -> monospaced occ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) Orig _ occ -> monospaced occ Exact name -> monospaced name -- Shouldn't happen since x is out of scope where - monospaced a = DocMonospaced (DocString (showSDoc $ ppr a)) + monospaced a = DocMonospaced (DocString (showPpr dflags a)) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 18e5f1d2..0f702683 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -16,7 +16,6 @@ import Haddock.GhcUtils import Haddock.Types import Bag (emptyBag) -import BasicTypes ( IPName(..), ipNameName ) import GHC hiding (NoLink) import Name @@ -28,8 +27,8 @@ import Data.Traversable (mapM) import Prelude hiding (mapM) -renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface renamingEnv warnings iface = +renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface +renameInterface dflags renamingEnv warnings iface = -- first create the local env, where every name exported by this module -- is mapped to itself, and everything else comes from the global renaming @@ -58,7 +57,7 @@ renameInterface renamingEnv warnings iface = -- representation. TODO: use the Name constants from the GHC API. -- strings = filter (`notElem` ["()", "[]", "(->)"]) -- (map pretty missingNames) - strings = map pretty . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames + strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames in do -- report things that we couldn't link to. Only do this for non-hidden @@ -216,14 +215,17 @@ renameLType = mapM renameType renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) +renameMaybeLKind :: Maybe (LHsKind Name) + -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind Nothing = return Nothing -renameMaybeLKind (Just ki) = Just <$> renameLKind ki +renameMaybeLKind (Just ki) + = do { ki' <- renameLKind ki + ; return (Just ki') } renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy expl tyvars lcontext ltype -> do - tyvars' <- mapM renameLTyVarBndr tyvars + tyvars' <- renameLTyVarBndrs tyvars lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsForAllTy expl tyvars' lcontext' ltype') @@ -243,7 +245,7 @@ renameType t = case t of HsListTy ty -> return . HsListTy =<< renameLType ty HsPArrTy ty -> return . HsPArrTy =<< renameLType ty - HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty) + HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts @@ -266,15 +268,25 @@ renameType t = case t of doc' <- renameLDocHsSyn doc return (HsDocTy ty' doc') + HsTyLit x -> return (HsTyLit x) + _ -> error "renameType" -renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc tv) = do - name' <- rename (hsTyVarName tv) - tyvar' <- replaceTyVarName tv name' renameLKind - return $ L loc tyvar' +renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) +renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) + = do { tvs' <- mapM renameLTyVarBndr tvs + ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + -- This is rather bogus, but I'm not sure what else to do +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 k)) + = do { n' <- rename n + ; k' <- renameLKind k + ; return (L loc (KindedTyVar n' k')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do @@ -324,54 +336,67 @@ renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do TyFamily flav lname ltyvars tckind -> do lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars + ltyvars' <- renameLTyVarBndrs ltyvars -- kind' <- renameMaybeLKind kind tckind' <- renameMaybeLKind tckind -- return (TyFamily flav lname' ltyvars' kind' tckind) return (TyFamily flav lname' ltyvars' tckind') - TyData x lcontext lname ltyvars typats k cons _ -> do - lcontext' <- renameLContext lcontext + TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars - typats' <- mapM (mapM renameLType) typats - k' <- renameMaybeLKind k - cons' <- mapM renameLCon cons - -- I don't think we need the derivings, so we return Nothing - return (TyData x lcontext' lname' ltyvars' typats' k' cons' Nothing) - - TySynonym lname ltyvars typats ltype -> do - lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars - ltype' <- renameLType ltype - typats' <- mapM (mapM renameLType) typats - return (TySynonym lname' ltyvars' typats' ltype') + tyvars' <- renameLTyVarBndrs tyvars + defn' <- renameTyDefn defn + return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs }) - ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do + ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars + ltyvars' <- renameLTyVarBndrs ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM renameLTyClD ats - at_defs' <- mapM renameLTyClD at_defs + at_defs' <- mapM (mapM renameFamInstD) at_defs -- we don't need the default methods or the already collected doc entities - return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' []) + return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' + , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) where - renameLCon (L loc con) = return . L loc =<< renameCon con - renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do + renameLFunDep (L loc (xs, ys)) = do + xs' <- mapM rename xs + ys' <- mapM rename ys + return (L loc (xs', ys')) + + renameLSig (L loc sig) = return . L loc =<< renameSig sig + +renameTyDefn :: HsTyDefn Name -> RnM (HsTyDefn DocName) +renameTyDefn (TyData { td_ND = nd, td_ctxt = lcontext, td_cType = cType + , td_kindSig = k, td_cons = cons }) = do + lcontext' <- renameLContext lcontext + k' <- renameMaybeLKind k + cons' <- mapM (mapM renameCon) cons + -- I don't think we need the derivings, so we return Nothing + return (TyData { td_ND = nd, td_ctxt = lcontext', td_cType = cType + , td_kindSig = k', td_cons = cons', td_derivs = Nothing }) + +renameTyDefn (TySynonym { td_synRhs = ltype }) = do + ltype' <- renameLType ltype + return (TySynonym { td_synRhs = ltype' }) + +renameCon :: ConDecl Name -> RnM (ConDecl DocName) +renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_res = restype, con_doc = mbldoc }) = do lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars + 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' , con_details = details', con_res = restype', con_doc = mbldoc' }) - + where renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do @@ -388,14 +413,6 @@ renameTyClD d = case d of renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) - - renameLSig (L loc sig) = return . L loc =<< renameSig sig - - renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do @@ -418,10 +435,23 @@ renameForD (ForeignExport lname ltype co x) = do renameInstD :: InstDecl Name -> RnM (InstDecl DocName) -renameInstD (InstDecl ltype _ _ lATs) = do +renameInstD (ClsInstD { cid_poly_ty =ltype, cid_fam_insts = lATs }) = do ltype' <- renameLType ltype - lATs' <- mapM renameLTyClD lATs - return (InstDecl ltype' emptyBag [] lATs') + lATs' <- mapM (mapM renameFamInstD) lATs + return (ClsInstD { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = [] + , cid_fam_insts = lATs' }) + +renameInstD (FamInstD { lid_inst = d }) = do + d' <- renameFamInstD d + return (FamInstD { lid_inst = d' }) + +renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName) +renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = pats_w_bndrs, fid_defn = defn }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; defn' <- renameTyDefn defn + ; return (FamInstDecl { fid_tycon = tc', fid_pats = pats_w_bndrs { hswb_cts = pats' } + , fid_defn = defn', fid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) |