diff options
Diffstat (limited to 'src/Haddock/Backends')
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 135 | ||||
| -rw-r--r-- | src/Haddock/Backends/LaTeX.hs | 84 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 8 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 112 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Names.hs | 5 |
5 files changed, 153 insertions, 191 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 |