From 1c308b7c0dc44a431c7e2a894162f346d4f9ff85 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 20 Apr 2012 18:37:46 +0100 Subject: Track changes in HsSyn --- src/Haddock/Backends/LaTeX.hs | 3 ++- src/Haddock/Backends/Xhtml/Decl.hs | 6 ++++-- src/Haddock/Convert.hs | 33 +++++++++++++++++---------------- src/Haddock/Interface/Create.hs | 6 +++--- src/Haddock/Interface/Rename.hs | 19 ++++++++++++------- 5 files changed, 38 insertions(+), 29 deletions(-) (limited to 'src') diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 21c76942..a02079c6 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -464,7 +464,8 @@ ppClassDecl :: [DocInstance DocName] -> SrcSpan -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> LaTeX ppClassDecl instances loc mbDoc subdocs - (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode + (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds + , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ instancesBit where diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 9e051914..18506e8f 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -296,7 +296,8 @@ ppFds fds unicode qual = ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html -ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) loc +ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs + , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs unicode qual = if null sigs && null ats then (if summary then id else topDeclElem links loc [nm]) hdr @@ -327,7 +328,8 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> Qualification -> Html ppClassDecl summary links instances loc mbDoc subdocs - decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual | summary = ppShortClassDecl summary links decl loc subdocs unicode qual | otherwise = classheader +++ maybeDocSection qual mbDoc +++ atBit +++ methodBit +++ instancesBit diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index e7409990..58f6a872 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -51,25 +51,26 @@ tyThingToLHsDecl t = noLoc $ case t of ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious -> TyClD $ ClassDecl - (synifyCtx (classSCTheta cl)) - (synifyName cl) - (synifyTyVars (classTyVars cl)) - (map (\ (l,r) -> noLoc - (map getName l, map getName r) ) $ - snd $ classTvsFds cl) - (map (noLoc . synifyIdSig DeleteTopLevelQuantification) - (classMethods cl)) - emptyBag --ignore default method definitions, they don't affect signature + { tcdCtxt = synifyCtx (classSCTheta cl) + , tcdLName = synifyName cl + , tcdTyVars = synifyTyVars (classTyVars cl) + , tcdFDs = map (\ (l,r) -> noLoc + (map getName l, map getName r) ) $ + snd $ classTvsFds cl + , tcdSigs = map (noLoc . synifyIdSig DeleteTopLevelQuantification) + (classMethods cl) + , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon: - [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl] - [] --ignore associated type defaults - [] --we don't have any docs at this point + , tcdATs = [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl] + , tcdATDefs = [] --ignore associated type defaults + , tcdDocs = [] --we don't have any docs at this point + , tcdFVs = placeHolderNames } | otherwise -> TyClD (synifyTyCon tc) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) - ACoAxiom ax -> InstD (FamInstD (synifyAxiom ax)) + ACoAxiom ax -> InstD (FamInstD { lid_inst = synifyAxiom ax }) -- a data-constructor alone just gets rendered as a function: ADataCon dc -> SigD (TypeSig [synifyName dc] @@ -86,8 +87,8 @@ synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) typats = map (synifyType WithinType) args hs_rhs_ty = synifyType WithinType rhs in FamInstDecl { fid_tycon = name - , fid_pats = HsBSig typats (map tyVarName tvs) - , fid_defn = TySynonym hs_rhs_ty } + , fid_pats = HsBSig typats ([], map tyVarName tvs) + , fid_defn = TySynonym hs_rhs_ty, fid_fvs = placeHolderNames } | otherwise = error "synifyAxiom" @@ -311,7 +312,7 @@ synifyTyLit (NumTyLit n) = HsNumTy n synifyTyLit (StrTyLit s) = HsStrTy s synifyKindSig :: Kind -> HsBndrSig (LHsKind Name) -synifyKindSig k = HsBSig (synifyType (error "synifyKind") k) placeHolderBndrs +synifyKindSig k = mkHsBSig (synifyType (error "synifyKind") k) synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> ([HsType Name], Name, [HsType Name]) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 608928b2..f5b1e8d4 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -189,7 +189,7 @@ mkMaps dflags gre instances exports decls = do let subNames = map fst subDocs let names = case d of - InstD (ClsInstD (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) -- See note [2]. + InstD (ClsInstD { cid_poly_ty = L l _ }) -> maybeToList (M.lookup l instanceMap) -- See note [2]. _ -> filter (`elem` exports) (getMainDeclBinder d) let docMap' = M.fromList (mapMaybe (\(n,doc) -> fmap (n,) doc) ([ (n, mayDoc) | n <- names ] ++ subDocs)) @@ -296,7 +296,7 @@ warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM () warnAboutFilteredDecls mdl decls = do let modStr = moduleString mdl let typeInstances = - nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD d)) <- decls ] + nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ] unless (null typeInstances) $ tell [ @@ -305,7 +305,7 @@ warnAboutFilteredDecls mdl decls = do ++ "will be filtered out:\n " ++ concat (intersperse ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | L _ (InstD (ClsInstD i _ _ ats)) <- decls + let instances = nub [ pretty i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls , not (null ats) ] unless (null instances) $ diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 1c54216b..a766be18 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -333,7 +333,8 @@ renameTyClD d = case d of 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 @@ -342,7 +343,9 @@ renameTyClD d = case d of ats' <- mapM renameLTyClD ats 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 renameLFunDep (L loc (xs, ys)) = do @@ -417,21 +420,23 @@ renameForD (ForeignExport lname ltype co x) = do renameInstD :: InstDecl Name -> RnM (InstDecl DocName) -renameInstD (ClsInstD ltype _ _ lATs) = do +renameInstD (ClsInstD { cid_poly_ty =ltype, cid_fam_insts = lATs }) = do ltype' <- renameLType ltype lATs' <- mapM (mapM renameFamInstD) lATs - return (ClsInstD ltype' emptyBag [] lATs') + return (ClsInstD { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = [] + , cid_fam_insts = lATs' }) -renameInstD (FamInstD d) = do +renameInstD (FamInstD { lid_inst = d }) = do d' <- renameFamInstD d - return (FamInstD d') + return (FamInstD { lid_inst = d' }) renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName) renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = HsBSig pats fvs, fid_defn = defn }) = do { tc' <- renameL tc ; pats' <- mapM renameLType pats ; defn' <- renameTyDefn defn - ; return (FamInstDecl { fid_tycon = tc', fid_pats = HsBSig pats' fvs, fid_defn = defn' }) } + ; return (FamInstDecl { fid_tycon = tc', fid_pats = HsBSig pats' fvs + , fid_defn = defn', fid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) -- cgit v1.2.3