aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc.mk3
-rw-r--r--haddock.cabal12
-rw-r--r--src/Haddock.hs18
-rw-r--r--src/Haddock/Backends/Hoogle.hs19
-rw-r--r--src/Haddock/Backends/LaTeX.hs23
-rw-r--r--src/Haddock/Backends/Xhtml.hs12
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs62
-rw-r--r--src/Haddock/Convert.hs125
-rw-r--r--src/Haddock/GhcUtils.hs10
-rw-r--r--src/Haddock/Interface.hs7
-rw-r--r--src/Haddock/Interface/AttachInstances.hs8
-rw-r--r--src/Haddock/Interface/Create.hs28
-rw-r--r--src/Haddock/Interface/Rename.hs102
-rw-r--r--src/Haddock/InterfaceFile.hs13
-rw-r--r--src/Haddock/Utils.hs18
15 files changed, 266 insertions, 194 deletions
diff --git a/ghc.mk b/ghc.mk
index 3af63818..e2043754 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -3,7 +3,8 @@ utils/haddock_USES_CABAL = YES
utils/haddock_PACKAGE = haddock
utils/haddock_CONFIGURE_OPTS = --flag in-ghc-tree
utils/haddock_dist_SHELL_WRAPPER = YES
-utils/haddock_dist_INSTALL_SHELL_WRAPPER = YES
+utils/haddock_dist_INSTALL = YES
+utils/haddock_dist_INSTALL_INPLACE = YES
utils/haddock_dist_INSTALL_SHELL_WRAPPER_NAME = haddock-ghc-$(ProjectVersion)
utils/haddock_dist_PROG = haddock$(exeext)
diff --git a/haddock.cabal b/haddock.cabal
index 2c102bc0..c4e33ad6 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -62,14 +62,14 @@ executable haddock
default-language: Haskell2010
main-is: Main.hs
hs-source-dirs: driver
-
if flag(dev)
ghc-options: -funbox-strict-fields -Wall -fwarn-tabs
else
ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2
-
+ if !flag(in-ghc-tree)
+ build-tools: alex >= 2.3, happy >= 1.18
build-depends:
- base >= 4.3 && < 4.7
+ base >= 4.3 && < 4.8
if flag(in-ghc-tree)
hs-source-dirs: src
cpp-options: -DIN_GHC_TREE
@@ -81,7 +81,7 @@ executable haddock
array,
xhtml >= 3000.2 && < 3000.3,
Cabal >= 1.10,
- ghc == 7.6.*
+ ghc >= 7.4 && < 7.8
other-modules:
Documentation.Haddock
Haddock
@@ -123,7 +123,7 @@ library
if !flag(in-ghc-tree)
build-tools: alex >= 2.3, happy >= 1.18
build-depends:
- base >= 4.3 && < 4.7,
+ base >= 4.3 && < 4.8,
filepath,
directory,
containers,
@@ -131,7 +131,7 @@ library
array,
xhtml >= 3000.2 && < 3000.3,
Cabal >= 1.10,
- ghc == 7.6.*
+ ghc >= 7.4 && < 7.8
if flag(in-ghc-tree)
cpp-options: -DIN_GHC_TREE
diff --git a/src/Haddock.hs b/src/Haddock.hs
index f79f3470..3b31c756 100644
--- a/src/Haddock.hs
+++ b/src/Haddock.hs
@@ -54,11 +54,11 @@ import qualified GHC.Paths as GhcPaths
import Paths_haddock
#endif
-import GHC hiding (flags, verbosity)
+import GHC hiding (verbosity)
import Config
-import DynFlags hiding (flags, verbosity)
+import DynFlags hiding (verbosity)
import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals)
-import Panic (panic, handleGhcException)
+import Panic (handleGhcException)
import Module
--------------------------------------------------------------------------------
@@ -229,7 +229,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
sourceUrls' = (srcBase, srcModule, srcMap')
libDir <- getHaddockLibDir flags
- prologue <- getPrologue flags
+ prologue <- getPrologue dflags flags
themes <- getThemes libDir flags >>= either bye return
when (Flag_GenIndex `elem` flags) $ do
@@ -299,7 +299,7 @@ withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do
(restFlags, _) <- parseStaticFlags (map noLoc flags)
runGhc (Just libDir) $ do
dynflags <- getSessionDynFlags
- let dynflags' = dopt_set dynflags Opt_Haddock
+ let dynflags' = gopt_set dynflags Opt_Haddock
let dynflags'' = dynflags' {
hscTarget = HscNothing,
ghcMode = CompManager,
@@ -314,7 +314,7 @@ withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do
ghcActs dynflags'''
`finally` restoreStaticFlagGlobals savedFlags
where
- parseGhcFlags :: Monad m => DynFlags -> [Located String]
+ parseGhcFlags :: MonadIO m => DynFlags -> [Located String]
-> [String] -> m DynFlags
parseGhcFlags dynflags flags_ origFlags = do
-- TODO: handle warnings?
@@ -407,13 +407,13 @@ updateHTMLXRefs packages = do
mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
-getPrologue :: [Flag] -> IO (Maybe (Doc RdrName))
-getPrologue flags =
+getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName))
+getPrologue dflags flags =
case [filename | Flag_Prologue filename <- flags ] of
[] -> return Nothing
[filename] -> do
str <- readFile filename
- case parseParas (tokenise (defaultDynFlags (panic "No settings")) str
+ case parseParas (tokenise dflags str
(1,0) {- TODO: real position -}) of
Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename
Just doc -> return (Just doc)
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 28d35aca..64905a37 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -112,9 +112,8 @@ operator x = x
ppExport :: DynFlags -> ExportItem Name -> [String]
ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
where
- f (TyClD d@TyDecl{})
- | isDataDecl d = ppData dflags d subdocs
- | otherwise = ppSynonym dflags d
+ f (TyClD d@DataDecl{}) = ppData dflags d subdocs
+ f (TyClD d@SynDecl{}) = ppSynonym dflags d
f (TyClD d@ClassDecl{}) = ppClass dflags d
f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
@@ -145,8 +144,8 @@ ppClass dflags x = out dflags x{tcdSigs=[]} :
f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)
- context = nlHsTyConApp (unL $ tcdLName x)
- (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x)))
+ context = nlHsTyConApp (tcdName x)
+ (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
ppInstance :: DynFlags -> ClsInst -> [String]
@@ -157,9 +156,9 @@ ppSynonym :: DynFlags -> TyClDecl Name -> [String]
ppSynonym dflags x = [out dflags x]
ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs
- = showData decl{ tcdTyDefn = defn { td_cons=[],td_derivs=Nothing }} :
- concatMap (ppCtor dflags decl subdocs . unL) (td_cons defn)
+ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
+ = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :
+ concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
where
-- GHC gives out "data Bar =", we want to delete the equals
@@ -167,7 +166,7 @@ ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs
showData d = unwords $ map f $ if last xs == "=" then init xs else xs
where
xs = words $ out dflags d
- nam = out dflags $ tcdLName d
+ nam = out dflags $ tyClDeclLName d
f w = if w == nam then operator nam else w
ppData _ _ _ = panic "ppData"
@@ -196,7 +195,7 @@ ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
resType = case con_res con of
ResTyH98 -> apps $ map (reL . HsTyVar) $
- unL (tcdLName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tcdTyVars dat]
+ (tcdName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tyClDeclTyVars dat]
ResTyGADT x -> x
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index bf1e6ac3..5d0fabe9 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,7 @@ import GHC
import OccName
import Name ( nameOccName )
import RdrName ( rdrNameOcc )
-import FastString ( unpackFS, unpackLitString )
+import FastString ( unpackFS, unpackLitString, zString )
import qualified Data.Map as Map
import System.Directory
@@ -168,6 +168,7 @@ string_txt :: TextDetails -> String -> String
string_txt (Chr c) s = c:s
string_txt (Str s1) s2 = s1 ++ s2
string_txt (PStr s1) s2 = unpackFS s1 ++ s2
+string_txt (ZStr s1) s2 = zString s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
@@ -242,7 +243,7 @@ ppDocGroup lev doc = sec lev <> braces doc
declNames :: LHsDecl DocName -> [DocName]
declNames (L _ decl) = case decl of
- TyClD d -> [unLoc $ tcdLName d]
+ TyClD d -> [tcdName d]
SigD (TypeSig lnames _) -> map unLoc lnames
_ -> error "declaration not supported by declNames"
@@ -274,10 +275,10 @@ ppDecl :: LHsDecl DocName
-> LaTeX
ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
- TyClD d@(TyFamily {}) -> ppTyFam False loc doc d unicode
- TyClD d@(TyDecl{ tcdTyDefn = defn })
- | isHsDataDefn defn -> ppDataDecl instances subdocs loc doc d unicode
- | otherwise -> ppTySyn loc (doc, fnArgsDoc) d unicode
+ TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
+ TyClD d@(DataDecl {})
+ -> ppDataDecl instances subdocs loc doc d unicode
+ TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
-- TyClD d@(TySynonym {})
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
@@ -310,8 +311,8 @@ ppFor _ _ _ _ =
-- we skip type patterns for now
ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
-ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
- , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode
+ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdRhs = ltype }) unicode
= ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
where
hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
@@ -548,7 +549,7 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
$$ instancesBit
where
- cons = td_cons (tcdTyDefn dataDecl)
+ cons = dd_cons (tcdDataDefn dataDecl)
resTy = (con_res . unLoc . head) cons
body = catMaybes [constrBit, documentationToLaTeX doc]
@@ -693,8 +694,8 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX
-ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars
- , tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) unicode
+ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
+ , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode
= -- newtype or data
(case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
-- context
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index c68b7cbc..3251477a 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -556,10 +556,10 @@ processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts) =
((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
- (TyFamily{}) -> [ppTyFamHeader True False d unicode qual]
- (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b]
- (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b]
- (ClassDecl {}) -> [keyword "class" <+> b]
+ (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]
+ (DataDecl{}) -> [keyword "data" <+> b]
+ (SynDecl{}) -> [keyword "type" <+> b]
+ (ClassDecl {}) -> [keyword "class" <+> b]
_ -> []
SigD (TypeSig lnames (L _ _)) ->
map (ppNameMini mdl . nameOccName . getName . unLoc) lnames
@@ -578,8 +578,8 @@ ppNameMini mdl nm =
ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
ppTyClBinderWithVarsMini mdl decl =
- let n = unLoc $ tcdLName decl
- ns = tyvarNames $ tcdTyVars decl
+ let n = tcdName decl
+ ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
in ppTypeApp n ns (ppNameMini mdl . nameOccName . getName) ppTyName
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 59be34f7..db39ccca 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,10 +39,9 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
Bool -> Qualification -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
- TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual
- TyClD d@(TyDecl{ tcdTyDefn = defn })
- | isHsDataDefn defn -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
- | otherwise -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
+ TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
@@ -115,8 +114,8 @@ ppFor _ _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
-> Qualification -> Html
-ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
- , tcdTyDefn = TySynonym { td_synRhs = ltype } })
+ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdRhs = ltype })
unicode qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
(full, hdr, spaceHtml +++ equals) unicode qual
@@ -145,10 +144,10 @@ ppTyName name
--------------------------------------------------------------------------------
-ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyFamHeader summary associated decl unicode qual =
-
- (case tcdFlavour decl of
+ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Bool -> Qualification -> Html
+ppTyFamHeader summary associated d@(FamilyDecl { fdFlavour = flav
+ , fdKindSig = mkind }) unicode qual =
+ (case flav of
TypeFamily
| associated -> keyword "type"
| otherwise -> keyword "type family"
@@ -157,22 +156,22 @@ ppTyFamHeader summary associated decl unicode qual =
| otherwise -> keyword "data family"
) <+>
- ppTyClBinderWithVars summary decl <+>
+ ppFamDeclBinderWithVars summary d <+>
- case tcdKindSig decl of
+ case mkind of
Just kind -> dcolon unicode <+> ppLKind unicode qual kind
Nothing -> noHtml
ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
- TyClDecl DocName -> Bool -> Qualification -> Html
+ FamilyDecl DocName -> Bool -> Qualification -> Html
ppTyFam summary associated links loc doc decl unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
| otherwise = header_ +++ docSection qual doc +++ instancesBit
where
- docname = tcdName decl
+ docname = unLoc $ fdLName decl
header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
@@ -187,23 +186,25 @@ ppTyFam summary associated links loc doc decl unicode qual
--------------------------------------------------------------------------------
-ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> Bool
-> Qualification -> Html
ppAssocType summ links doc (L loc decl) unicode qual =
- case decl of
- TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual
- _ -> error "declaration type not supported by ppAssocType"
+ ppTyFam summ True links loc (fst doc) decl unicode qual
--------------------------------------------------------------------------------
-- * TyClDecl helpers
--------------------------------------------------------------------------------
+-- | Print a type family and its variables
+ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html
+ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
+ ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs)
--- | Print a type family / newtype / data / class binder and its variables
-ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html
-ppTyClBinderWithVars summ decl =
- ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
+-- | Print a newtype / data binder and its variables
+ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html
+ppDataBinderWithVars summ decl =
+ ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)
--------------------------------------------------------------------------------
@@ -303,7 +304,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
+++ shortSubDecls
(
[ ppAssocType summary links doc at unicode qual | at <- ats
- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
+ , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
-- ToDo: add associated type defaults
@@ -336,14 +337,14 @@ ppClassDecl summary links instances loc d subdocs
| null lsigs = topDeclElem links loc [nm] (hdr unicode qual)
| otherwise = topDeclElem links loc [nm] (hdr unicode qual <+> keyword "where")
- nm = unLoc $ tcdLName decl
+ nm = tcdName decl
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
-- ToDo: add assocatied typ defaults
atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual
| at <- ats
- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
+ , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]
methodBit = subMethods [ ppFunSig summary links loc doc names typ unicode qual
| L _ (TypeSig lnames (L _ typ)) <- lsigs
@@ -401,7 +402,7 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual
doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
- cons = td_cons (tcdTyDefn dataDecl)
+ cons = dd_cons (tcdDataDefn dataDecl)
resTy = (con_res . unLoc . head) cons
@@ -415,8 +416,8 @@ ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
| otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
where
- docname = unLoc . tcdLName $ dataDecl
- cons = td_cons (tcdTyDefn dataDecl)
+ docname = tcdName dataDecl
+ cons = dd_cons (tcdDataDefn dataDecl)
resTy = (con_res . unLoc . head) cons
header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual
@@ -570,14 +571,15 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } })
+ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd
+ , dd_ctxt = ctxt } })
unicode qual
= -- newtype or data
(case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
-- context
ppLContext ctxt unicode qual <+>
-- T a b c ..., or a :+: b
- ppTyClBinderWithVars summary decl
+ ppDataBinderWithVars summary decl
ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 7c9a2ee5..71c68bf0 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -18,7 +18,7 @@ module Haddock.Convert where
import HsSyn
-import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
+import TcType ( tcSplitSigmaTy )
import TypeRep
import Type(isStrLitTy)
import Kind ( splitKindFunTys, synTyConResKind )
@@ -26,6 +26,7 @@ import Name
import Var
import Class
import TyCon
+import CoAxiom
import DataCon
import BasicTypes ( TupleSort(..) )
import TysPrim ( alphaTyVars )
@@ -53,7 +54,14 @@ tyThingToLHsDecl t = noLoc $ case t of
-- later in the file (also it's used for class associated-types too.)
ATyCon tc
| Just cl <- tyConClass_maybe tc -- classes are just a little tedious
- -> TyClD $ ClassDecl
+ -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a
+ extractFamilyDecl (FamDecl d) = noLoc d
+ extractFamilyDecl _ =
+ error "tyThingToLHsDecl: impossible associated tycon"
+
+ atTyClDecls = [synifyTyCon at_tc | (at_tc, _) <- classATItems cl]
+ atFamDecls = map extractFamilyDecl atTyClDecls in
+ TyClD $ ClassDecl
{ tcdCtxt = synifyCtx (classSCTheta cl)
, tcdLName = synifyName cl
, tcdTyVars = synifyTyVars (classTyVars cl)
@@ -64,7 +72,7 @@ tyThingToLHsDecl t = noLoc $ case t of
(classMethods cl)
, tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
-- class associated-types are a subset of TyCon:
- , tcdATs = [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl]
+ , tcdATs = atFamDecls
, tcdATDefs = [] --ignore associated type defaults
, tcdDocs = [] --we don't have any docs at this point
, tcdFVs = placeHolderNames }
@@ -73,33 +81,40 @@ tyThingToLHsDecl t = noLoc $ case t of
-- 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 { lid_inst = synifyAxiom ax })
+ ACoAxiom ax -> InstD (TyFamInstD { tfid_inst = synifyAxiom ax })
-- a data-constructor alone just gets rendered as a function:
ADataCon dc -> SigD (TypeSig [synifyName dc]
(synifyType ImplicitizeForAll (dataConUserType dc)))
-synifyATDefault :: TyCon -> LFamInstDecl Name
+synifyATDefault :: TyCon -> LTyFamInstDecl Name
synifyATDefault tc = noLoc (synifyAxiom ax)
where Just ax = tyConFamilyCoercion_maybe tc
-synifyAxiom :: CoAxiom -> FamInstDecl Name
-synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs })
- | Just (tc, args) <- tcSplitTyConApp_maybe lhs
- = let name = synifyName tc
- typats = map (synifyType WithinType) args
- hs_rhs_ty = synifyType WithinType rhs
- in FamInstDecl { fid_tycon = name
- , fid_pats = HsWB { hswb_cts = typats, hswb_kvs = [], hswb_tvs = map tyVarName tvs }
- , fid_defn = TySynonym hs_rhs_ty, fid_fvs = placeHolderNames }
- | otherwise
- = error "synifyAxiom"
+synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
+synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
+ = let name = synifyName tc
+ typats = map (synifyType WithinType) args
+ hs_rhs = synifyType WithinType rhs
+ (kvs, tvs) = partition isKindVar tkvs
+ in TyFamInstEqn { tfie_tycon = name
+ , tfie_pats = HsWB { hswb_cts = typats
+ , hswb_kvs = map tyVarName kvs
+ , hswb_tvs = map tyVarName tvs }
+ , tfie_rhs = hs_rhs }
+
+synifyAxiom :: CoAxiom br -> TyFamInstDecl Name
+synifyAxiom (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
+ = let eqns = brListMap (noLoc . synifyAxBranch tc) branches
+ in TyFamInstDecl { tfid_eqns = eqns
+ , tfid_group = (brListLength branches /= 1)
+ , tfid_fvs = placeHolderNames }
synifyTyCon :: TyCon -> TyClDecl Name
synifyTyCon tc
| isFunTyCon tc || isPrimTyCon tc
- = TyDecl { tcdLName = synifyName tc
- , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:
+ = 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)
(synifyKindSig realKind)
@@ -108,40 +123,44 @@ synifyTyCon tc
alphaTyVars --a, b, c... which are unfortunately all kind *
}
- , tcdTyDefn = TyData { td_ND = DataType -- arbitrary lie, they are neither
+ , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither
-- algebraic data nor newtype:
- , td_ctxt = noLoc []
- , td_cType = Nothing
- , td_kindSig = Just (synifyKindSig (tyConKind tc))
+ , dd_ctxt = noLoc []
+ , dd_cType = Nothing
+ , dd_kindSig = Just (synifyKindSig (tyConKind tc))
-- we have their kind accurately:
- , td_cons = [] -- No constructors
- , td_derivs = Nothing }
+ , dd_cons = [] -- No constructors
+ , dd_derivs = Nothing }
, tcdFVs = placeHolderNames }
| isSynFamilyTyCon tc
- = case synTyConRhs tc of
- SynFamilyTyCon ->
- TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
- (Just (synifyKindSig (synTyConResKind tc)))
+ = case synTyConRhs_maybe tc of
+ Just (SynFamilyTyCon {}) ->
+ FamDecl (FamilyDecl TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
+ (Just (synifyKindSig (synTyConResKind tc))))
_ -> error "synifyTyCon: impossible open type synonym?"
| isDataFamilyTyCon tc
= --(why no "isOpenAlgTyCon"?)
case algTyConRhs tc of
DataFamilyTyCon ->
- TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
- Nothing --always kind '*'
- -- placeHolderKind
+ FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
+ Nothing) --always kind '*'
_ -> error "synifyTyCon: impossible open data type?"
+ | isSynTyCon tc
+ = case synTyConRhs_maybe tc of
+ Just (SynonymTyCon ty) ->
+ SynDecl { tcdLName = synifyName tc
+ , tcdTyVars = synifyTyVars (tyConTyVars tc)
+ , tcdRhs = synifyType WithinType ty
+ , tcdFVs = placeHolderNames }
+ _ -> error "synifyTyCon: impossible synTyCon"
| otherwise =
- -- (closed) type, newtype, and data
+ -- (closed) newtype and data
let
- -- alg_ only applies to newtype/data
- -- syn_ only applies to type
- -- others apply to both
alg_nd = if isNewTyCon tc then NewType else DataType
alg_ctx = synifyCtx (tyConStupidTheta tc)
name = synifyName tc
tyvars = synifyTyVars (tyConTyVars tc)
- alg_kindSig = Just (tyConKind tc)
+ kindSig = Just (tyConKind tc)
-- The data constructors.
--
-- Any data-constructors not exported from the module that *defines* the
@@ -158,19 +177,18 @@ synifyTyCon tc
-- That seems like an acceptable compromise (they'll just be documented
-- in prefix position), since, otherwise, the logic (at best) gets much more
-- complicated. (would use dataConIsInfix.)
- alg_use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
- alg_cons = map (synifyDataCon alg_use_gadt_syntax) (tyConDataCons tc)
+ use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
+ cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
-- "deriving" doesn't affect the signature, no need to specify any.
alg_deriv = Nothing
- syn_type = synifyType WithinType (synTyConType tc)
- defn | isSynTyCon tc = TySynonym syn_type
- | otherwise = TyData { td_ND = alg_nd, td_ctxt = alg_ctx
- , td_cType = Nothing
- , td_kindSig = fmap synifyKindSig alg_kindSig
- , td_cons = alg_cons
- , td_derivs = alg_deriv }
- in TyDecl { tcdLName = name, tcdTyVars = tyvars, tcdTyDefn = defn
- , tcdFVs = placeHolderNames }
+ defn = HsDataDefn { dd_ND = alg_nd
+ , dd_ctxt = alg_ctx
+ , dd_cType = Nothing
+ , dd_kindSig = fmap synifyKindSig kindSig
+ , dd_cons = cons
+ , dd_derivs = alg_deriv }
+ in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn
+ , tcdFVs = placeHolderNames }
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
-- for any constructor that would be misrepresented by omitting its
@@ -197,11 +215,14 @@ synifyDataCon use_gadt_syntax dc = noLoc $
linear_tys = zipWith (\ty bang ->
let tySyn = synifyType WithinType ty
- in case bang of
- HsUnpackFailed -> noLoc $ HsBangTy HsStrict tySyn
- HsNoBang -> tySyn
- -- HsNoBang never appears, it's implied instead.
- _ -> noLoc $ HsBangTy bang tySyn
+ src_bang = case bang of
+ HsUnpack {} -> HsUserBang (Just True) True
+ HsStrict -> HsUserBang (Just False) True
+ _ -> bang
+ in case src_bang of
+ HsNoBang -> tySyn
+ _ -> noLoc $ HsBangTy bang tySyn
+ -- HsNoBang never appears, it's implied instead.
)
arg_tys (dataConStrictMarks dc)
field_tys = zipWith (\field synTy -> ConDeclField
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index a841e567..82ccb590 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -147,7 +147,7 @@ isValD _ = False
declATs :: HsDecl a -> [a]
-declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d
+declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
declATs _ = []
@@ -215,9 +215,9 @@ instance Parent (ConDecl Name) where
instance Parent (TyClDecl Name) where
children d
- | isDataDecl d = map (unL . con_name . unL) . td_cons . tcdTyDefn $ d
+ | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d
| isClassDecl d =
- map (tcdName . unL) (tcdATs d) ++
+ map (unL . fdLName . unL) (tcdATs d) ++
[ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
| otherwise = []
@@ -231,8 +231,8 @@ family = getName &&& children
-- child to its grand-children, recursively.
families :: TyClDecl Name -> [(Name, [Name])]
families d
- | isDataDecl d = family d : map (family . unL) (td_cons (tcdTyDefn d))
- | isClassDecl d = family d : concatMap (families . unL) (tcdATs d)
+ | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d))
+ | isClassDecl d = [family d]
| otherwise = []
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 5a8e8485..ea1f42e5 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -50,9 +50,9 @@ import System.FilePath
import Text.Printf
import Digraph
-import DynFlags hiding (verbosity, flags)
+import DynFlags hiding (verbosity)
import Exception
-import GHC hiding (verbosity, flags)
+import GHC hiding (verbosity)
import HscTypes
@@ -138,7 +138,8 @@ createIfaces0 verbosity modules flags instIfaceMap =
enableCompilation :: ModuleGraph -> Ghc ModuleGraph
enableCompilation modGraph = do
- let enableComp d = d { hscTarget = defaultObjectTarget }
+ let enableComp d = let platform = targetPlatform d
+ in d { hscTarget = defaultObjectTarget platform }
modifySessionDynFlags enableComp
-- We need to update the DynFlags of the ModSummaries as well.
let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 4b5f159d..04c4e5e1 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -58,15 +58,19 @@ attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> Exp
attachToExportItem expInfo iface ifaceMap instIfaceMap export =
case export of
ExportDecl { expItemDecl = L _ (TyClD d) } -> do
- mb_info <- getAllInfo (unLoc (tcdLName d))
+ mb_info <- getAllInfo (tcdName d)
let export' =
export {
expItemInstances =
case mb_info of
Just (_, _, instances) ->
+ let insts = map (first synifyInstHead) $ sortImage (first instHead)
+ [ (instanceSig i, getName i) | i <- instances ]
+{- FIXME
let insts = map (first synifyInstHead) $ sortImage (first instHead) $
filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys)
[ (instanceHead' i, getName i) | i <- instances ]
+-}
in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap)
| (inst, name) <- insts ]
Nothing -> []
@@ -96,11 +100,13 @@ lookupInstDoc name iface ifaceMap instIfaceMap =
-- | Like GHC's 'instanceHead' but drops "silent" arguments.
+{- FIXME
instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys)
where
dfun = is_dfun ispec
(tvs, theta, cls, tys) = instanceHead ispec
+-}
-- | Drop "silent" arguments. See GHC Note [Silent superclass
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 6c121ad4..40016a0b 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -35,7 +35,7 @@ import qualified Data.Traversable as T
import qualified Packages
import qualified Module
import qualified SrcLoc
-import GHC hiding (flags)
+import GHC
import HscTypes
import Name
import Bag
@@ -192,7 +192,6 @@ moduleWarning dflags gre ws =
WarnSome _ -> return Nothing
WarnAll w -> Just <$> parseWarning dflags gre w
-
parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
parseWarning dflags gre w = do
r <- case w of
@@ -280,7 +279,7 @@ mkMaps dflags gre instances decls = do
instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
names :: HsDecl Name -> [Name]
- names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap) -- See note [2].
+ names (InstD (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ }))) = maybeToList (M.lookup l instanceMap) -- See note [2].
names decl = getMainDeclBinder decl
-- Note [2]:
@@ -308,7 +307,7 @@ subordinates (TyClD decl)
]
dataSubs = constrs ++ fields
where
- cons = map unL $ (td_cons (tcdTyDefn decl))
+ cons = map unL $ (dd_cons (tcdDataDefn 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)
@@ -324,7 +323,7 @@ typeDocs d =
case d of
SigD (TypeSig _ ty) -> docs (unLoc ty)
ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
- TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty)
+ TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
_ -> M.empty
where
go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)
@@ -343,7 +342,7 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
docs = mkDecls tcdDocs DocD class_
defs = mkDecls (bagToList . tcdMeths) ValD class_
sigs = mkDecls tcdSigs SigD class_
- ats = mkDecls tcdATs TyClD class_
+ ats = mkDecls tcdATs (TyClD . FamDecl) class_
-- | The top-level declarations of a module that we care about,
@@ -386,7 +385,11 @@ warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM ()
warnAboutFilteredDecls dflags mdl decls = do
let modStr = moduleString mdl
let typeInstances =
- nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ]
+ nub (concat [[ unLoc (tfie_tycon eqn)
+ | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqns = eqns }))) <- decls
+ , L _ eqn <- eqns ],
+ [ unLoc (dfid_tycon d)
+ | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ]])
unless (null typeInstances) $
tell [
@@ -395,8 +398,11 @@ warnAboutFilteredDecls dflags mdl decls = do
++ "will be filtered out:\n " ++ (intercalate ", "
$ map (occNameString . nameOccName) typeInstances) ]
- let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls
- , not (null ats) ]
+ let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD (ClsInstDecl
+ { cid_poly_ty = i
+ , cid_tyfam_insts = ats
+ , cid_datafam_insts = adts }))) <- decls
+ , not (null ats) || not (null adts) ]
unless (null instances) $
tell [
@@ -747,11 +753,11 @@ 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 (td_cons (tcdTyDefn d))
+ L pos sig = extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
in L pos (SigD sig)
_ -> error "internal: extractDecl"
where
- name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d))
+ name_and_tyvars d = (tcdName d, hsLTyVarLocNames (tyClDeclTyVars d))
toTypeNoLoc :: Located Name -> LHsType Name
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 9f3a4155..a2499726 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -330,10 +330,8 @@ renameDecl decl = case decl of
return (InstD d')
_ -> error "renameDecl"
-
-renameLTyClD :: LTyClDecl Name -> RnM (LTyClDecl DocName)
-renameLTyClD (L loc d) = return . L loc =<< renameTyClD d
-
+renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))
+renameLThing fn (L loc x) = return . L loc =<< fn x
renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)
renameTyClD d = case d of
@@ -342,19 +340,21 @@ renameTyClD d = case d of
return (ForeignType lname' b)
-- TyFamily flav lname ltyvars kind tckind -> do
- TyFamily flav lname ltyvars tckind -> do
- lname' <- renameL lname
- ltyvars' <- renameLTyVarBndrs ltyvars
--- kind' <- renameMaybeLKind kind
- tckind' <- renameMaybeLKind tckind
--- return (TyFamily flav lname' ltyvars' kind' tckind)
- return (TyFamily flav lname' ltyvars' tckind')
+ FamDecl { tcdFam = decl } -> do
+ decl' <- renameFamilyDecl decl
+ return (FamDecl { tcdFam = decl' })
+
+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do
+ lname' <- renameL lname
+ tyvars' <- renameLTyVarBndrs tyvars
+ rhs' <- renameLType rhs
+ return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs })
- TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do
+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do
lname' <- renameL lname
tyvars' <- renameLTyVarBndrs tyvars
- defn' <- renameTyDefn defn
- return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs })
+ defn' <- renameDataDefn defn
+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs })
ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
@@ -363,8 +363,8 @@ renameTyClD d = case d of
ltyvars' <- renameLTyVarBndrs ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
lsigs' <- mapM renameLSig lsigs
- ats' <- mapM renameLTyClD ats
- at_defs' <- mapM (mapM renameFamInstD) at_defs
+ ats' <- mapM (renameLThing renameFamilyDecl) ats
+ at_defs' <- mapM (mapM renameTyFamInstD) at_defs
-- we don't need the default methods or the already collected doc entities
return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
, tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
@@ -378,19 +378,24 @@ renameTyClD d = case d of
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
+renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
+renameFamilyDecl (FamilyDecl { fdFlavour = flav, fdLName = lname
+ , fdTyVars = ltyvars, fdKindSig = tckind }) = do
+ lname' <- renameL lname
+ ltyvars' <- renameLTyVarBndrs ltyvars
+ tckind' <- renameMaybeLKind tckind
+ return (FamilyDecl { fdFlavour = flav, fdLName = lname'
+ , fdTyVars = ltyvars', fdKindSig = tckind' })
+
+renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
+renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
+ , dd_kindSig = k, dd_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' })
+ return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
+ , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
renameCon :: ConDecl Name -> RnM (ConDecl DocName)
renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
@@ -446,24 +451,47 @@ renameForD (ForeignExport lname ltype co x) = do
renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
-renameInstD (ClsInstD { cid_poly_ty =ltype, cid_fam_insts = lATs }) = do
+renameInstD (ClsInstD { cid_inst = d }) = do
+ d' <- renameClsInstD d
+ return (ClsInstD { cid_inst = d' })
+renameInstD (TyFamInstD { tfid_inst = d }) = do
+ d' <- renameTyFamInstD d
+ return (TyFamInstD { tfid_inst = d' })
+renameInstD (DataFamInstD { dfid_inst = d }) = do
+ d' <- renameDataFamInstD d
+ return (DataFamInstD { dfid_inst = d' })
+
+renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
+renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do
ltype' <- renameLType ltype
- lATs' <- mapM (mapM renameFamInstD) lATs
- return (ClsInstD { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
- , cid_fam_insts = lATs' })
+ lATs' <- mapM (mapM renameTyFamInstD) lATs
+ lADTs' <- mapM (mapM renameDataFamInstD) lADTs
+ return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
+ , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
-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 })
+renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)
+renameTyFamInstD (TyFamInstDecl { tfid_eqns = eqns , tfid_group = eqn_group })
+ = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns
+ ; return (TyFamInstDecl { tfid_eqns = eqns'
+ , tfid_group = eqn_group
+ , tfid_fvs = placeHolderNames }) }
+
+renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)
+renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs })
= 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 }) }
+ ; rhs' <- renameLType rhs
+ ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' }
+ , tfie_rhs = rhs' }) }
+renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; defn' <- renameDataDefn defn
+ ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' }
+ , dfid_defn = defn', dfid_fvs = placeHolderNames }) }
renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
renameExportItem item = case item of
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index a25b734a..ec7272e7 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -61,7 +61,6 @@ binaryInterfaceMagic :: Word32
binaryInterfaceMagic = 0xD0Cface
-#if __GLASGOW_HASKELL__ == 706
-- IMPORTANT: Since datatypes in the GHC API might change between major
-- versions, and because we store GHC datatypes in our interface files, we need
-- to make sure we version our interface files accordingly.
@@ -75,11 +74,21 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
+#if __GLASGOW_HASKELL__ == 702
+binaryInterfaceVersion = 20
+#elif __GLASGOW_HASKELL__ == 703
+binaryInterfaceVersion = 20
+#elif __GLASGOW_HASKELL__ == 704
+binaryInterfaceVersion = 20
+#elif __GLASGOW_HASKELL__ == 705
+binaryInterfaceVersion = 20
+#elif __GLASGOW_HASKELL__ == 706
+binaryInterfaceVersion = 20
+#elif __GLASGOW_HASKELL__ == 707
binaryInterfaceVersion = 22
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [21, 22]
-
#else
#error Unsupported GHC version
#endif
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 4424ad73..e0b86350 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -127,22 +127,20 @@ toInstalledDescription = hmi_description . instInfo
restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name
restrictTo names (L loc decl) = L loc $ case decl of
TyClD d | isDataDecl d ->
- TyClD (d { tcdTyDefn = restrictTyDefn names (tcdTyDefn d) })
+ TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
TyClD d | isClassDecl d ->
TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),
tcdATs = restrictATs names (tcdATs d) })
_ -> decl
-restrictTyDefn :: [Name] -> HsTyDefn Name -> HsTyDefn Name
-restrictTyDefn _ defn@(TySynonym {})
- = defn
-restrictTyDefn names defn@(TyData { td_ND = new_or_data, td_cons = cons })
+restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name
+restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
| DataType <- new_or_data
- = defn { td_cons = restrictCons names cons }
+ = defn { dd_cons = restrictCons names cons }
| otherwise -- Newtype
= case restrictCons names cons of
- [] -> defn { td_ND = DataType, td_cons = [] }
- [con] -> defn { td_cons = [con] }
+ [] -> defn { dd_ND = DataType, dd_cons = [] }
+ [con] -> defn { dd_cons = [con] }
_ -> error "Should not happen"
restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
@@ -170,8 +168,8 @@ restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
-restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]
-restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ]
+restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]
+restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
emptyHsQTvs :: LHsTyVarBndrs Name
-- This function is here, rather than in HsTypes, because it *renamed*, but
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 04:56:36 +0000