From 1c308b7c0dc44a431c7e2a894162f346d4f9ff85 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
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(-)
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