aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Hoogle.hs135
-rw-r--r--src/Haddock/Backends/LaTeX.hs84
-rw-r--r--src/Haddock/Backends/Xhtml.hs8
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs112
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs5
-rw-r--r--src/Haddock/Convert.hs142
-rw-r--r--src/Haddock/GhcUtils.hs15
-rw-r--r--src/Haddock/Interface.hs4
-rw-r--r--src/Haddock/Interface/AttachInstances.hs7
-rw-r--r--src/Haddock/Interface/Create.hs58
-rw-r--r--src/Haddock/Interface/LexParseRn.hs26
-rw-r--r--src/Haddock/Interface/Rename.hs130
-rw-r--r--src/Haddock/Types.hs2
-rw-r--r--src/Haddock/Utils.hs28
-rw-r--r--src/Main.hs64
15 files changed, 421 insertions, 399 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index d27ca80f..55f6ac1d 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -34,24 +34,25 @@ prefix = ["-- Hoogle documentation, generated by Haddock"
,""]
-ppHoogle :: String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
-ppHoogle package version synopsis prologue ifaces odir = do
+ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
+ppHoogle dflags package version synopsis prologue ifaces odir = do
let filename = package ++ ".txt"
contents = prefix ++
- docWith (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
+ docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
["@package " ++ package] ++
["@version " ++ version | version /= ""] ++
- concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]
h <- openFile (odir </> filename) WriteMode
hSetEncoding h utf8
hPutStr h (unlines contents)
hClose h
-ppModule :: Interface -> [String]
-ppModule iface = "" : ppDocumentation (ifaceDoc iface) ++
- ["module " ++ moduleString (ifaceMod iface)] ++
- concatMap ppExport (ifaceExportItems iface) ++
- concatMap ppInstance (ifaceInstances iface)
+ppModule :: DynFlags -> Interface -> [String]
+ppModule dflags iface =
+ "" : ppDocumentation dflags (ifaceDoc iface) ++
+ ["module " ++ moduleString (ifaceMod iface)] ++
+ concatMap (ppExport dflags) (ifaceExportItems iface) ++
+ concatMap (ppInstance dflags) (ifaceInstances iface)
---------------------------------------------------------------------
@@ -74,8 +75,8 @@ dropHsDocTy = f
f (HsDocTy a _) = f $ unL a
f x = x
-outHsType :: OutputableBndr a => HsType a -> String
-outHsType = out . dropHsDocTy
+outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
+outHsType dflags = out dflags . dropHsDocTy
makeExplicit :: HsType a -> HsType a
@@ -92,8 +93,8 @@ dropComment (x:xs) = x : dropComment xs
dropComment [] = []
-out :: Outputable a => a -> String
-out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr
+out :: Outputable a => DynFlags -> a -> String
+out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr
where
f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
f (x:xs) = x : f xs
@@ -108,108 +109,114 @@ operator x = x
---------------------------------------------------------------------
-- How to print each export
-ppExport :: ExportItem Name -> [String]
-ppExport (ExportDecl decl dc subdocs _) = ppDocumentation (fst dc) ++ f (unL decl)
+ppExport :: DynFlags -> ExportItem Name -> [String]
+ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
where
- f (TyClD d@TyData{}) = ppData d subdocs
- f (TyClD d@ClassDecl{}) = ppClass d
- f (TyClD d@TySynonym{}) = ppSynonym d
- f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ
- f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ
- f (SigD sig) = ppSig sig
+ f (TyClD d@TyDecl{})
+ | isDataDecl d = ppData dflags d subdocs
+ | otherwise = 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
+ f (SigD sig) = ppSig dflags sig
f _ = []
-ppExport _ = []
+ppExport _ _ = []
-ppSig :: Sig Name -> [String]
-ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ]
+ppSig :: DynFlags -> Sig Name -> [String]
+ppSig dflags (TypeSig names sig)
+ = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
where
- prettyNames = intercalate ", " $ map out names
+ prettyNames = intercalate ", " $ map (out dflags) names
typ = case unL sig of
HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
x -> x
-ppSig _ = []
-
-
-ppSynonym :: TyClDecl Name -> [String]
-ppSynonym x = [out x]
+ppSig _ _ = []
-- note: does not yet output documentation for class methods
-ppClass :: TyClDecl Name -> [String]
-ppClass x = out x{tcdSigs=[]} :
- concatMap (ppSig . addContext . unL) (tcdSigs x)
+ppClass :: DynFlags -> TyClDecl Name -> [String]
+ppClass dflags x = out dflags x{tcdSigs=[]} :
+ concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
where
addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
addContext _ = error "expected TypeSig"
f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
- f t = HsForAllTy Implicit [] (reL [context]) (reL t)
+ f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)
context = nlHsTyConApp (unL $ tcdLName x)
- (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x))
+ (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x)))
+
+ppInstance :: DynFlags -> ClsInst -> [String]
+ppInstance dflags x = [dropComment $ out dflags x]
-ppInstance :: Instance -> [String]
-ppInstance x = [dropComment $ out x]
+ppSynonym :: DynFlags -> TyClDecl Name -> [String]
+ppSynonym dflags x = [out dflags x]
-ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} :
- concatMap (ppCtor x subdocs . unL) (tcdCons 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)
where
+
-- GHC gives out "data Bar =", we want to delete the equals
-- also writes data : a b, when we want data (:) a b
showData d = unwords $ map f $ if last xs == "=" then init xs else xs
where
- xs = words $ out d
- nam = out $ tcdLName d
+ xs = words $ out dflags d
+ nam = out dflags $ tcdLName d
f w = if w == nam then operator nam else w
+ppData _ _ _ = panic "ppData"
-- | for constructors, and named-fields...
-lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> [String]
-lookupCon subdocs (L _ name) = case lookup name subdocs of
- Just (d, _) -> ppDocumentation d
+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]
+lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
+ Just (d, _) -> ppDocumentation dflags d
_ -> []
-ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
-ppCtor dat subdocs con = lookupCon subdocs (con_name con)
+ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
+ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
++ f (con_details 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 recs) ++ concat
- [lookupCon subdocs (cd_fld_name r) ++
- [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
+ [lookupCon dflags subdocs (cd_fld_name r) ++
+ [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
| r <- recs]
funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
apps = foldl1 (\x y -> reL $ HsAppTy x y)
- typeSig nm flds = operator nm ++ " :: " ++ outHsType (makeExplicit $ unL $ funs flds)
- name = out $ unL $ con_name con
+ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
+ name = out dflags $ unL $ con_name con
resType = case con_res con of
- ResTyH98 -> apps $ map (reL . HsTyVar) $ unL (tcdLName dat) : [hsTyVarName v | v@UserTyVar {} <- map unL $ tcdTyVars dat]
+ ResTyH98 -> apps $ map (reL . HsTyVar) $
+ unL (tcdLName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tcdTyVars dat]
ResTyGADT x -> x
---------------------------------------------------------------------
-- DOCUMENTATION
-ppDocumentation :: Outputable o => Documentation o -> [String]
-ppDocumentation (Documentation d w) = doc d ++ doc w
+ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String]
+ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w
-doc :: Outputable o => Maybe (Doc o) -> [String]
-doc = docWith ""
+doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String]
+doc dflags = docWith dflags ""
-docWith :: Outputable o => String -> Maybe (Doc o) -> [String]
-docWith [] Nothing = []
-docWith header d = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $
+docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String]
+docWith _ [] Nothing = []
+docWith dflags header d
+ = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $
[header | header /= ""] ++ ["" | header /= "" && isJust d] ++
- maybe [] (showTags . markup markupTag) d
+ maybe [] (showTags . markup (markupTag dflags)) d
data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
@@ -230,14 +237,14 @@ str a = [Str a]
-- or inlne for others (a,i,tt)
-- entities (&,>,<) should always be appropriately escaped
-markupTag :: Outputable o => DocMarkup o [Tag]
-markupTag = Markup {
+markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag]
+markupTag dflags = Markup {
markupParagraph = box TagP,
markupEmpty = str "",
markupString = str,
markupAppend = (++),
- markupIdentifier = box (TagInline "a") . str . out,
- markupIdentifierUnchecked = box (TagInline "a") . str . out . snd,
+ markupIdentifier = box (TagInline "a") . str . out dflags,
+ markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd,
markupModule = box (TagInline "a") . str,
markupWarning = box (TagInline "i"),
markupEmphasis = box (TagInline "i"),
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 31ba3b0b..c187f104 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,6 @@ import GHC
import OccName
import Name ( nameOccName )
import RdrName ( rdrNameOcc )
-import BasicTypes ( ipNameName )
import FastString ( unpackFS, unpackLitString )
import qualified Data.Map as Map
@@ -276,12 +275,13 @@ ppDecl :: LHsDecl DocName
ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
TyClD d@(TyFamily {}) -> ppTyFam False loc doc d unicode
- TyClD d@(TyData {})
- | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc doc d unicode
- | Just _ <- tcdTyPats d -> ppDataInst loc doc d
- TyClD d@(TySynonym {})
- | Nothing <- tcdTyPats d -> ppTySyn loc (doc, fnArgsDoc) d unicode
- | Just _ <- tcdTyPats d -> ppTyInst 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
+-- Family instances happen via FamInst now
+-- TyClD d@(TySynonym {})
+-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
+-- Family instances happen via FamInst now
TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
@@ -297,17 +297,6 @@ ppTyFam _ _ _ _ _ =
error "type family declarations are currently not supported by --latex"
-ppDataInst :: a
-ppDataInst =
- error "data instance declarations are currently not supported by --latex"
-
-
-ppTyInst :: Bool -> SrcSpan -> Documentation DocName ->
- TyClDecl DocName -> Bool -> LaTeX
-ppTyInst _ _ _ _ _ =
- error "type instance declarations are currently not supported by --latex"
-
-
ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
ppFor _ _ _ _ =
error "foreign declarations are currently not supported by --latex"
@@ -321,7 +310,8 @@ ppFor _ _ _ _ =
-- we skip type patterns for now
ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
-ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode
+ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode
= ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
where
hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
@@ -394,12 +384,12 @@ ppTypeSig nms ty unicode =
<+> ppType unicode ty
-ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]
+ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]
ppTyVars tvs = map ppSymName (tyvarNames tvs)
-tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
-tyvarNames = map (getName . hsTyVarName . unLoc)
+tyvarNames :: LHsTyVarBndrs DocName -> [Name]
+tyvarNames = map getName . hsLTyVarNames
declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -448,7 +438,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
@@ -470,7 +460,8 @@ ppClassDecl :: [DocInstance DocName] -> SrcSpan
-> Documentation DocName -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> LaTeX
ppClassDecl instances loc doc 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
@@ -557,7 +548,7 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
$$ instancesBit
where
- cons = tcdCons dataDecl
+ cons = td_cons (tcdTyDefn dataDecl)
resTy = (con_res . unLoc . head) cons
body = catMaybes [constrBit, documentationToLaTeX doc]
@@ -702,27 +693,15 @@ 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 decl unicode
- | not (isDataDecl decl) = error "ppDataHeader: illegal argument"
- | otherwise =
- -- newtype or data
- (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
+ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars
+ , tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) unicode
+ = -- newtype or data
+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
-- context
- ppLContext (tcdCtxt decl) unicode <+>
+ ppLContext ctxt unicode <+>
-- T a b c ..., or a :+: b
- ppTyClBinderWithVars False decl
-
-
---------------------------------------------------------------------------------
--- * TyClDecl helpers
---------------------------------------------------------------------------------
-
-
--- | Print a type family / newtype / data / class binder and its variables
-ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> LaTeX
-ppTyClBinderWithVars summ decl =
- ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
-
+ ppAppDocNameNames False name (tyvarNames tyvars)
+ppDataHeader _ _ = error "ppDataHeader: illegal argument"
--------------------------------------------------------------------------------
-- * Type applications
@@ -842,13 +821,13 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]
+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
-> Located (HsContext DocName) -> Bool -> LaTeX
ppForAll expl tvs cxt unicode
| show_forall = forall_part <+> ppLContext cxt unicode
| otherwise = ppLContext cxt unicode
where
- show_forall = not (null tvs) && is_explicit
+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
is_explicit = case expl of {Explicit -> True; Implicit -> False}
forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
@@ -869,7 +848,7 @@ ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) t
ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
@@ -900,6 +879,15 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode
ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
= ppr_mono_lty ctxt_prec ty unicode
+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)
+ -- XXX: Ok in verbatim, but not otherwise
+ -- XXX: Do something with Unicode parameter?
+
ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX
ppr_fun_ty ctxt_prec ty1 ty2 unicode
@@ -930,6 +918,8 @@ ppSymName name
ppVerbOccName :: OccName -> LaTeX
ppVerbOccName = text . latexFilter . occNameString
+ppIPName :: HsIPName -> LaTeX
+ppIPName ip = text $ unpackFS $ hsIPNameFS ip
ppOccName :: OccName -> LaTeX
ppOccName = text . occNameString
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 5a3cbac0..c68b7cbc 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -557,12 +557,8 @@ 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]
- (TyData{tcdTyPats = ps})
- | Nothing <- ps -> [keyword "data" <+> b]
- | Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b]
- (TySynonym{tcdTyPats = ps})
- | Nothing <- ps -> [keyword "type" <+> b]
- | Just _ <- ps -> [keyword "type" <+> keyword "instance" <+> b]
+ (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b]
+ (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b]
(ClassDecl {}) -> [keyword "class" <+> b]
_ -> []
SigD (TypeSig lnames (L _ _)) ->
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 21a33ea8..59be34f7 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -33,7 +33,6 @@ import Text.XHtml hiding ( name, title, p, quote )
import GHC
import Name
-import BasicTypes ( ipNameName )
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
@@ -41,12 +40,9 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl 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@(TyData {})
- | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
- | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d
- TyClD d@(TySynonym {})
- | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
- | Just _ <- tcdTyPats d -> ppTyInst 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 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
@@ -101,12 +97,12 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
= [(leader <+> ppType unicode qual t, argDoc n, [])]
-ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
+ppTyVars :: LHsTyVarBndrs DocName -> [Html]
ppTyVars tvs = map ppTyName (tyvarNames tvs)
-tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
-tyvarNames = map (getName . hsTyVarName . unLoc)
+tyvarNames :: LHsTyVarBndrs DocName -> [Name]
+tyvarNames = map getName . hsLTyVarNames
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
@@ -119,7 +115,9 @@ 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 (TySynonym (L _ name) ltyvars _ ltype) unicode qual
+ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdTyDefn = TySynonym { td_synRhs = ltype } })
+ unicode qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
(full, hdr, spaceHtml +++ equals) unicode qual
where
@@ -161,9 +159,9 @@ ppTyFamHeader summary associated decl unicode qual =
ppTyClBinderWithVars summary decl <+>
- case tcdKind decl of
+ case tcdKindSig decl of
Just kind -> dcolon unicode <+> ppLKind unicode qual kind
- Nothing -> noHtml
+ Nothing -> noHtml
ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
@@ -185,50 +183,6 @@ ppTyFam summary associated links loc doc decl unicode qual
--------------------------------------------------------------------------------
--- * Indexed data types
---------------------------------------------------------------------------------
-
-
-ppDataInst :: a
-ppDataInst = undefined
-
-
---------------------------------------------------------------------------------
--- * Indexed newtypes
---------------------------------------------------------------------------------
-
--- TODO
--- ppNewTyInst = undefined
-
-
---------------------------------------------------------------------------------
--- * Indexed types
---------------------------------------------------------------------------------
-
-
-ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
- TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyInst summary associated links loc doc decl unicode qual
-
- | summary = ppTyInstHeader True associated decl unicode qual
- | otherwise = header_ +++ docSection qual doc
-
- where
- docname = tcdName decl
-
- header_ = topDeclElem links loc [docname]
- (ppTyInstHeader summary associated decl unicode qual)
-
-
-ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyInstHeader _ _ decl unicode qual =
- keyword "type instance" <+>
- ppAppNameTypes (tcdName decl) typeArgs unicode qual
- where
- typeArgs = map unLoc . fromJust . tcdTyPats $ decl
-
-
---------------------------------------------------------------------------------
-- * Associated Types
--------------------------------------------------------------------------------
@@ -238,7 +192,6 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> B
ppAssocType summ links doc (L loc decl) unicode qual =
case decl of
TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual
- TySynonym {} -> ppTySyn summ links loc doc decl unicode qual
_ -> error "declaration type not supported by ppAssocType"
@@ -320,7 +273,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
-> Bool -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
@@ -341,7 +294,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
@@ -351,6 +305,8 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) lo
[ ppAssocType summary links doc at unicode qual | at <- ats
, let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
+ -- ToDo: add associated type defaults
+
[ ppFunSig summary links loc doc names typ unicode qual
| L _ (TypeSig lnames (L _ typ)) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
@@ -370,7 +326,8 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
-> Documentation DocName -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> Qualification -> Html
ppClassDecl summary links instances loc d 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 +++ docSection qual d
+++ atBit +++ methodBit +++ instancesBit
@@ -383,6 +340,7 @@ ppClassDecl summary links instances loc d subdocs
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 ]
@@ -443,7 +401,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 = tcdCons dataDecl
+ cons = td_cons (tcdTyDefn dataDecl)
resTy = (con_res . unLoc . head) cons
@@ -458,7 +416,7 @@ ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
where
docname = unLoc . tcdLName $ dataDecl
- cons = tcdCons dataDecl
+ cons = td_cons (tcdTyDefn dataDecl)
resTy = (con_res . unLoc . head) cons
header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual
@@ -612,15 +570,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 unicode qual
- | not (isDataDecl decl) = error "ppDataHeader: illegal argument"
- | otherwise =
- -- newtype or data
- (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
+ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } })
+ unicode qual
+ = -- newtype or data
+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
-- context
- ppLContext (tcdCtxt decl) unicode qual <+>
+ ppLContext ctxt unicode qual <+>
-- T a b c ..., or a :+: b
ppTyClBinderWithVars summary decl
+ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
--------------------------------------------------------------------------------
@@ -682,13 +640,13 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]
+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
-> Located (HsContext DocName) -> Bool -> Qualification -> Html
ppForAll expl tvs cxt unicode qual
| show_forall = forall_part <+> ppLContext cxt unicode qual
| otherwise = ppLContext cxt unicode qual
where
- show_forall = not (null tvs) && is_explicit
+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
is_explicit = case expl of {Explicit -> True; Implicit -> False}
forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
@@ -710,7 +668,7 @@ ppr_mono_ty _ (HsKindSig ty kind) u q =
parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
@@ -731,8 +689,8 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
= maybeParen ctxt_prec pREC_FUN $
ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
where
- ppr_op = if not (isSymOcc occName) then quote (ppLDocName qual op) else ppLDocName qual op
- occName = nameOccName . getName . unLoc $ op
+ ppr_op = if not (isSymOcc occ) then quote (ppLDocName qual op) else ppLDocName qual op
+ occ = nameOccName . getName . unLoc $ op
ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
-- = parens (ppr_mono_lty pREC_TOP ty)
@@ -741,6 +699,12 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
= ppr_mono_lty ctxt_prec ty unicode qual
+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_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html
ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 48d0f7f1..2f2b82ed 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -14,6 +14,7 @@ module Haddock.Backends.Xhtml.Names (
ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
ppBinder, ppBinder',
ppModule, ppModuleRef,
+ ppIPName,
linkId
) where
@@ -30,6 +31,7 @@ import qualified Data.List as List
import GHC
import Name
import RdrName
+import FastString (unpackFS)
ppOccName :: OccName -> Html
@@ -39,6 +41,9 @@ ppOccName = toHtml . occNameString
ppRdrName :: RdrName -> Html
ppRdrName = ppOccName . rdrNameOcc
+ppIPName :: HsIPName -> Html
+ppIPName = toHtml . unpackFS . hsIPNameFS
+
ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 82b57f0c..7c9a2ee5 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,6 +20,7 @@ module Haddock.Convert where
import HsSyn
import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
import TypeRep
+import Type(isStrLitTy)
import Kind ( splitKindFunTys, synTyConResKind )
import Name
import Var
@@ -29,8 +30,10 @@ import DataCon
import BasicTypes ( TupleSort(..) )
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, eqTyCon )
+import PrelNames (ipClassName)
import Bag ( emptyBag )
import SrcLoc ( Located, noLoc, unLoc )
+import Data.List( partition )
-- the main function here! yay!
@@ -51,77 +54,78 @@ 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 -> TyClD (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]
(synifyType ImplicitizeForAll (dataConUserType dc)))
-synifyATDefault :: TyCon -> LTyClDecl Name
+synifyATDefault :: TyCon -> LFamInstDecl Name
synifyATDefault tc = noLoc (synifyAxiom ax)
where Just ax = tyConFamilyCoercion_maybe tc
-synifyAxiom :: CoAxiom -> TyClDecl Name
+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
- tyvars = synifyTyVars tvs
typats = map (synifyType WithinType) args
hs_rhs_ty = synifyType WithinType rhs
- in TySynonym name tyvars (Just typats) hs_rhs_ty
+ 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"
synifyTyCon :: TyCon -> TyClDecl Name
synifyTyCon tc
- | isFunTyCon tc || isPrimTyCon tc =
- TyData
- -- arbitrary lie, they are neither algebraic data nor newtype:
- DataType
- -- no built-in type has any stupidTheta:
- (noLoc [])
- (synifyName tc)
- -- tyConTyVars doesn't work on fun/prim, but we can make them up:
- (zipWith
- (\fakeTyVar realKind -> noLoc $
- KindedTyVar (getName fakeTyVar) (synifyKind realKind) placeHolderKind)
- alphaTyVars --a, b, c... which are unfortunately all kind *
- (fst . splitKindFunTys $ tyConKind tc)
- )
- -- assume primitive types aren't members of data/newtype families:
- Nothing
- -- we have their kind accurately:
- (Just (synifyKind (tyConKind tc)))
- -- no algebraic constructors:
- []
- -- "deriving" needn't be specified:
- Nothing
- | isSynFamilyTyCon tc =
- case synTyConRhs tc of
+ | isFunTyCon tc || isPrimTyCon tc
+ = TyDecl { 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)
+ in HsQTvs { hsq_kvs = [] -- No kind polymorhism
+ , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
+ alphaTyVars --a, b, c... which are unfortunately all kind *
+ }
+
+ , tcdTyDefn = TyData { td_ND = DataType -- arbitrary lie, they are neither
+ -- algebraic data nor newtype:
+ , td_ctxt = noLoc []
+ , td_cType = Nothing
+ , td_kindSig = Just (synifyKindSig (tyConKind tc))
+ -- we have their kind accurately:
+ , td_cons = [] -- No constructors
+ , td_derivs = Nothing }
+ , tcdFVs = placeHolderNames }
+ | isSynFamilyTyCon tc
+ = case synTyConRhs tc of
SynFamilyTyCon ->
TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
- (Just (synifyKind (synTyConResKind tc))) -- placeHolderKind
+ (Just (synifyKindSig (synTyConResKind tc)))
_ -> error "synifyTyCon: impossible open type synonym?"
- | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?)
- case algTyConRhs tc of
+ | isDataFamilyTyCon tc
+ = --(why no "isOpenAlgTyCon"?)
+ case algTyConRhs tc of
DataFamilyTyCon ->
TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
Nothing --always kind '*'
@@ -137,9 +141,6 @@ synifyTyCon tc
alg_ctx = synifyCtx (tyConStupidTheta tc)
name = synifyName tc
tyvars = synifyTyVars (tyConTyVars tc)
- typats = case tyConFamInst_maybe tc of
- Nothing -> Nothing
- Just (_, indexes) -> Just (map (synifyType WithinType) indexes)
alg_kindSig = Just (tyConKind tc)
-- The data constructors.
--
@@ -162,10 +163,14 @@ synifyTyCon tc
-- "deriving" doesn't affect the signature, no need to specify any.
alg_deriv = Nothing
syn_type = synifyType WithinType (synTyConType tc)
- in if isSynTyCon tc
- then TySynonym name tyvars typats syn_type
- else TyData alg_nd alg_ctx name tyvars typats (fmap synifyKind alg_kindSig) alg_cons alg_deriv
-
+ 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 }
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
-- for any constructor that would be misrepresented by omitting its
@@ -230,16 +235,17 @@ synifyCtx :: [PredType] -> LHsContext Name
synifyCtx = noLoc . map (synifyType WithinType)
-synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
-synifyTyVars = map synifyTyVar
+synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
+synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
+ , hsq_tvs = map synifyTyVar tvs }
where
- synifyTyVar tv = noLoc $ let
- kind = tyVarKind tv
- name = getName tv
- in if isLiftedTypeKind kind
- then UserTyVar name placeHolderKind
- else KindedTyVar name (synifyKind kind) placeHolderKind
-
+ (kvs, tvs) = partition isKindVar ktvs
+ synifyTyVar tv
+ | isLiftedTypeKind kind = noLoc (UserTyVar name)
+ | otherwise = noLoc (KindedTyVar name (synifyKindSig kind))
+ where
+ kind = tyVarKind tv
+ name = getName tv
--states of what to do with foralls:
data SynifyTypeState
@@ -271,9 +277,10 @@ synifyType _ (TyConApp tc tys)
| getName tc == listTyConName, [ty] <- tys =
noLoc $ HsListTy (synifyType WithinType ty)
-- ditto for implicit parameter tycons
- | Just ip <- tyConIP_maybe tc
- , [ty] <- tys
- = noLoc $ HsIParamTy ip (synifyType WithinType ty)
+ | tyConName tc == ipClassName
+ , [name, ty] <- tys
+ , Just x <- isStrLitTy name
+ = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
-- and equalities
| tc == eqTyCon
, [ty1, ty2] <- tys
@@ -305,9 +312,14 @@ synifyType s forallty@(ForAllTy _tv _ty) =
sTau = synifyType WithinType tau
in noLoc $
HsForAllTy forallPlicitness sTvs sCtx sTau
+synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
+
+synifyTyLit :: TyLit -> HsTyLit
+synifyTyLit (NumTyLit n) = HsNumTy n
+synifyTyLit (StrTyLit s) = HsStrTy s
-synifyKind :: Kind -> LHsKind Name
-synifyKind = synifyType (error "synifyKind")
+synifyKindSig :: Kind -> LHsKind Name
+synifyKindSig k = synifyType (error "synifyKind") k
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
([HsType Name], Name, [HsType Name])
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index fc04351b..a841e567 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -78,7 +78,7 @@ isVarSym = isLexVarSym . occNameFS
getMainDeclBinder :: HsDecl name -> [name]
-getMainDeclBinder (TyClD d) | not (isFamInstDecl d) = [tcdName d]
+getMainDeclBinder (TyClD d) = [tcdName d]
getMainDeclBinder (ValD d) =
case collectHsBindBinders d of
[] -> []
@@ -138,7 +138,6 @@ isDocD _ = False
isInstD :: HsDecl a -> Bool
isInstD (InstD _) = True
-isInstD (TyClD d) = isFamInstDecl d
isInstD _ = False
@@ -152,12 +151,12 @@ declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d
declATs _ = []
-pretty :: Outputable a => a -> String
-pretty x = showSDoc (ppr x)
+pretty :: Outputable a => DynFlags -> a -> String
+pretty = showPpr
-trace_ppr :: Outputable a => a -> b -> b
-trace_ppr x y = trace (pretty x) y
+trace_ppr :: Outputable a => DynFlags -> a -> b -> b
+trace_ppr dflags x y = trace (pretty dflags x) y
-------------------------------------------------------------------------------
@@ -216,7 +215,7 @@ instance Parent (ConDecl Name) where
instance Parent (TyClDecl Name) where
children d
- | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d
+ | isDataDecl d = map (unL . con_name . unL) . td_cons . tcdTyDefn $ d
| isClassDecl d =
map (tcdName . unL) (tcdATs d) ++
[ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
@@ -232,7 +231,7 @@ family = getName &&& children
-- child to its grand-children, recursively.
families :: TyClDecl Name -> [(Name, [Name])]
families d
- | isDataDecl d = family d : map (family . unL) (tcdCons d)
+ | isDataDecl d = family d : map (family . unL) (td_cons (tcdTyDefn d))
| isClassDecl d = family d : concatMap (families . unL) (tcdATs d)
| otherwise = []
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 09f01883..dcd794af 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -49,6 +49,7 @@ import System.FilePath
import Text.Printf
import Digraph
+import DynFlags hiding (verbosity, flags)
import Exception
import GHC hiding (verbosity, flags)
import HscTypes
@@ -83,8 +84,9 @@ processModules verbosity modules flags extIfaces = do
out verbosity verbose "Renaming interfaces..."
let warnings = Flag_NoWarnings `notElem` flags
+ dflags <- getDynFlags
let (interfaces'', msgs) =
- runWriter $ mapM (renameInterface links warnings) interfaces'
+ runWriter $ mapM (renameInterface dflags links warnings) interfaces'
liftIO $ mapM_ putStrLn msgs
return (interfaces'', homeLinks)
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index c012f2e0..a4d4764e 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 50f468db..4bb46cba 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
@@ -700,7 +698,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) =
@@ -728,7 +726,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
@@ -743,7 +741,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 56ed1b42..d68f78f8 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 b703da0f..6109c341 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)
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 048a7ff7..3cadf33a 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -108,7 +108,7 @@ data Interface = Interface
, ifaceModuleAliases :: AliasMap
-- | Instances exported by the module.
- , ifaceInstances :: ![Instance]
+ , ifaceInstances :: ![ClsInst]
-- | The number of haddockable and haddocked items in the module, as a
-- tuple. Haddockable items are the exports and the module itself.
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 3a2f1d28..53e8bba8 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -13,7 +13,7 @@
module Haddock.Utils (
-- * Misc utilities
- restrictTo,
+ restrictTo, emptyHsQTvs,
toDescription, toInstalledDescription,
-- * Filename utilities
@@ -125,18 +125,24 @@ toInstalledDescription = hmi_description . instInfo
restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name
restrictTo names (L loc decl) = L loc $ case decl of
- TyClD d | isDataDecl d && tcdND d == DataType ->
- TyClD (d { tcdCons = restrictCons names (tcdCons d) })
- TyClD d | isDataDecl d && tcdND d == NewType ->
- case restrictCons names (tcdCons d) of
- [] -> TyClD (d { tcdND = DataType, tcdCons = [] })
- [con] -> TyClD (d { tcdCons = [con] })
- _ -> error "Should not happen"
+ TyClD d | isDataDecl d ->
+ TyClD (d { tcdTyDefn = restrictTyDefn names (tcdTyDefn 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 })
+ | DataType <- new_or_data
+ = defn { td_cons = restrictCons names cons }
+ | otherwise -- Newtype
+ = case restrictCons names cons of
+ [] -> defn { td_ND = DataType, td_cons = [] }
+ [con] -> defn { td_cons = [con] }
+ _ -> error "Should not happen"
restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
@@ -166,6 +172,12 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]
restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ]
+emptyHsQTvs :: LHsTyVarBndrs Name
+-- This function is here, rather than in HsTypes, because it *renamed*, but
+-- does not necessarily have all the rigt kind variables. It is used
+-- in Haddock just for printing, so it doesn't matter
+emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] }
+
--------------------------------------------------------------------------------
-- * Filename mangling functions stolen from s main/DriverUtil.lhs.
diff --git a/src/Main.hs b/src/Main.hs
index 8c15661d..beb01b86 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -135,31 +135,6 @@ main = handleTopExceptions $ do
shortcutFlags flags
qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
- if not (null files) then do
- (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
-
- -- Dump an "interface file" (.haddock file), if requested.
- case optDumpInterfaceFile flags of
- Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
- Nothing -> return ()
-
- -- Render the interfaces.
- renderStep flags qual packages ifaces
-
- else do
- when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
- throwE "No input file(s)."
-
- -- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags)
-
- -- Render even though there are no input files (usually contents/index).
- renderStep flags qual packages []
-
-
-readPackagesAndProcessModules :: [Flag] -> [String]
- -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
-readPackagesAndProcessModules flags files = do
libDir <- fmap snd (getGhcDirs flags)
-- Catches all GHC source errors, then prints and re-throws them.
@@ -170,6 +145,33 @@ readPackagesAndProcessModules flags files = do
-- Initialize GHC.
withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
+ dflags <- getDynFlags
+
+ if not (null files) then do
+ (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
+
+ -- Dump an "interface file" (.haddock file), if requested.
+ case optDumpInterfaceFile flags of
+ Just f -> liftIO $ dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
+ Nothing -> return ()
+
+ -- Render the interfaces.
+ liftIO $ renderStep dflags flags qual packages ifaces
+
+ else do
+ when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
+ throwE "No input file(s)."
+
+ -- Get packages supplied with --read-interface.
+ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+
+ -- Render even though there are no input files (usually contents/index).
+ liftIO $ renderStep dflags flags qual packages []
+
+
+readPackagesAndProcessModules :: [Flag] -> [String]
+ -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
+readPackagesAndProcessModules flags files = do
-- Get packages supplied with --read-interface.
packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
@@ -180,19 +182,19 @@ readPackagesAndProcessModules flags files = do
return (packages, ifaces, homeLinks)
-renderStep :: [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep flags qual pkgs interfaces = do
+renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep dflags flags qual pkgs interfaces = do
updateHTMLXRefs pkgs
let
ifaceFiles = map snd pkgs
installedIfaces = concatMap ifInstalledIfaces ifaceFiles
srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]
- render flags qual interfaces installedIfaces srcMap
+ render dflags flags qual interfaces installedIfaces srcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
-render flags qual ifaces installedIfaces srcMap = do
+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
+render dflags flags qual ifaces installedIfaces srcMap = do
let
title = fromMaybe "" (optTitle flags)
@@ -246,7 +248,7 @@ render flags qual ifaces installedIfaces srcMap = do
when (Flag_Hoogle `elem` flags) $ do
let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
- ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir
+ ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir
when (Flag_LaTeX `elem` flags) $ do
ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 11:07:47 +0000