diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html index bfecfb3..dc06e3b 100644 --- a/html-test/ref/Operators.html +++ b/html-test/ref/Operators.html @@ -1,457 +1,457 @@ Operators

 

Safe HaskellSafe-Inferred

Operators

Description

Test operators with or without fixity declarations

Synopsis

Documentation

(+-) :: a -> a -> a

Operator with no fixity

(*/) :: a -> a -> a infixr 7

Operator with infixr 7

foo :: a -> a -> a infixl 3

Named function with infixl 3

data Foo

Data type with operator constructors

Constructors

Foo `Bar` Foo infixl 3

Has infixl 3

Foo :- Foo infixr 5

Has infixr 5

pattern (:+) t t :: [t] :: t -> t -> [t] infixr 3

Pattern synonym, infixr 3

data a <-> b where infixl 6

Type name, infixl 6 and GADT constructor

Constructors

(:<->) :: a -> b -> a <-> b infixr 6 

type family a ++ b infix 3

Type family with fixity

data family a ** b infix 9

Data family with fixity

class a ><> b where infixr 1

Class with fixity, including associated types

Associated Types

type a <>< b :: * infixl 2

data a ><< b infixl 3

Methods

(>><), (<<>) :: a -> b -> () infixl 5 <<>infixr 4 >><

(**>), (**<), (>**), (<**) :: a -> a -> () infixr 8 **>, >**infixl 8 **<, <**

Multiple fixities

type (>-<) a b = a <-> b infixl 6

Type synonym with fixity

diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index f1bd7f6..f5842d7 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -1,241 +1,241 @@ PatternSyns

 

Safe HaskellSafe-Inferred

PatternSyns

Description

Testing some pattern synonyms

Synopsis

Documentation

data FooType x

FooType doc

Constructors

FooCtor x 

pattern pattern Foo t :: :: t -> FooType t

Pattern synonym for Foo x

pattern pattern Bar t :: :: t -> FooType (FooType t)

Pattern synonym for Bar x

pattern t :<-> t :: (pattern (:<->) :: t -> t -> (FooType t, FooType (FooType t))

Pattern synonym for (:<->)

data a >< b

Doc for (><)

Constructors

Empty 

pattern pattern E :: :: (><) k t t

Pattern for Empty

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 06a24b4..d307443 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -1,1224 +1,1220 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.LaTeX -- Copyright : (c) Simon Marlow 2010, -- Mateusz Kowalczyk 2013 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Backends.LaTeX ( ppLaTeX ) where import Haddock.Types import Haddock.Utils import Haddock.GhcUtils import Pretty hiding (Doc, quote) import qualified Pretty import GHC import OccName import Name ( nameOccName ) import RdrName ( rdrNameOcc ) import FastString ( unpackFS, unpackLitString, zString ) import qualified Data.Map as Map import System.Directory import System.FilePath import Data.Char import Control.Monad import Data.Maybe import Data.List import Haddock.Doc (combineDocumentation) -- import Debug.Trace {- SAMPLE OUTPUT \haddockmoduleheading{\texttt{Data.List}} \hrulefill {\haddockverb\begin{verbatim} module Data.List ( (++), head, last, tail, init, null, length, map, reverse, ) where\end{verbatim}} \hrulefill \section{Basic functions} \begin{haddockdesc} \item[\begin{tabular}{@{}l} head\ ::\ {\char 91}a{\char 93}\ ->\ a \end{tabular}]\haddockbegindoc Extract the first element of a list, which must be non-empty. \par \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} last\ ::\ {\char 91}a{\char 93}\ ->\ a \end{tabular}]\haddockbegindoc Extract the last element of a list, which must be finite and non-empty. \par \end{haddockdesc} -} {- TODO * don't forget fixity!! -} ppLaTeX :: String -- Title -> Maybe String -- Package name -> [Interface] -> FilePath -- destination directory -> Maybe (Doc GHC.RdrName) -- prologue text, maybe -> Maybe String -- style file -> FilePath -> IO () ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir = do createDirectoryIfMissing True odir when (isNothing maybe_style) $ copyFile (libdir "latex" haddockSty) (odir haddockSty) ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces mapM_ (ppLaTeXModule title odir) visible_ifaces haddockSty :: FilePath haddockSty = "haddock.sty" type LaTeX = Pretty.Doc ppLaTeXTop :: String -> Maybe String -> FilePath -> Maybe (Doc GHC.RdrName) -> Maybe String -> [Interface] -> IO () ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do let tex = vcat [ text "\\documentclass{book}", text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style), text "\\begin{document}", text "\\begin{titlepage}", text "\\begin{haddocktitle}", text doctitle, text "\\end{haddocktitle}", case prologue of Nothing -> empty Just d -> vcat [text "\\begin{haddockprologue}", rdrDocToLaTeX d, text "\\end{haddockprologue}"], text "\\end{titlepage}", text "\\tableofcontents", vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ], text "\\end{document}" ] mods = sort (map (moduleBasename.ifaceMod) ifaces) filename = odir (fromMaybe "haddock" packageStr <.> "tex") writeFile filename (show tex) ppLaTeXModule :: String -> FilePath -> Interface -> IO () ppLaTeXModule _title odir iface = do createDirectoryIfMissing True odir let mdl = ifaceMod iface mdl_str = moduleString mdl exports = ifaceRnExportItems iface tex = vcat [ text "\\haddockmoduleheading" <> braces (text mdl_str), text "\\label{module:" <> text mdl_str <> char '}', text "\\haddockbeginheader", verb $ vcat [ text "module" <+> text mdl_str <+> lparen, text " " <> fsep (punctuate (text ", ") $ map exportListItem $ filter forSummary exports), text " ) where" ], text "\\haddockendheader" $$ text "", description, body ] description = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface body = processExports exports -- writeFile (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) string_txt :: TextDetails -> String -> String string_txt (Chr c) s = c:s string_txt (Str s1) s2 = s1 ++ s2 string_txt (PStr s1) s2 = unpackFS s1 ++ s2 string_txt (ZStr s1) s2 = zString s1 ++ s2 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 exportListItem :: ExportItem DocName -> LaTeX exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } = sep (punctuate comma . map ppDocBinder $ declNames decl) <> case subdocs of [] -> empty _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) exportListItem (ExportNoDecl y []) = ppDocBinder y exportListItem (ExportNoDecl y subs) = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs))) exportListItem (ExportModule mdl) = text "module" <+> text (moduleString mdl) exportListItem _ = error "exportListItem" -- Deal with a group of undocumented exports together, to avoid lots -- of blank vertical space between them. processExports :: [ExportItem DocName] -> LaTeX processExports [] = empty processExports (decl : es) | Just sig <- isSimpleSig decl = multiDecl [ ppTypeSig (map getName names) typ False | (names,typ) <- sig:sigs ] $$ processExports es' where (sigs, es') = spanWith isSimpleSig es processExports (ExportModule mdl : es) = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$ processExports es' where (mdls, es') = spanWith isExportModule es processExports (e : es) = processExport e $$ processExports es isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t))) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing isExportModule :: ExportItem DocName -> Maybe Module isExportModule (ExportModule m) = Just m isExportModule _ = Nothing processExport :: ExportItem DocName -> LaTeX processExport (ExportGroup lev _id0 doc) = ppDocGroup lev (docToLaTeX doc) processExport (ExportDecl decl doc subdocs insts fixities _splice) = ppDecl decl doc insts subdocs fixities processExport (ExportNoDecl y []) = ppDocName y processExport (ExportNoDecl y subs) = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs))) processExport (ExportModule mdl) = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing processExport (ExportDoc doc) = docToLaTeX doc ppDocGroup :: Int -> LaTeX -> LaTeX ppDocGroup lev doc = sec lev <> braces doc where sec 1 = text "\\section" sec 2 = text "\\subsection" sec 3 = text "\\subsubsection" sec _ = text "\\paragraph" declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] SigD (TypeSig lnames _) -> map unLoc lnames SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames" forSummary :: (ExportItem DocName) -> Bool forSummary (ExportGroup _ _ _) = False forSummary (ExportDoc _) = False forSummary _ = True moduleLaTeXFile :: Module -> FilePath moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex" moduleBasename :: Module -> FilePath moduleBasename mdl = map (\c -> if c == '.' then '-' else c) (moduleNameString (moduleName mdl)) ------------------------------------------------------------------------------- -- * Decls ------------------------------------------------------------------------------- ppDecl :: LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> LaTeX ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode TyClD d@(DataDecl {}) -> ppDataDecl instances subdocs loc (Just doc) d unicode TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now -- TyClD d@(TySynonym {}) -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- 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 - SigD (PatSynSig lname args ty prov req) -> - ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode + SigD (PatSynSig lname qtvs prov req ty) -> + ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" where unicode = False ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> LaTeX ppTyFam _ _ _ _ _ = error "type family declarations are currently not supported by --latex" ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = ppFunSig loc doc [name] typ unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" ------------------------------------------------------------------------------- -- * Type Synonyms ------------------------------------------------------------------------------- -- we skip type patterns for now ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) full = hdr <+> char '=' <+> ppLType unicode ltype ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -- * Function signatures ------------------------------------------------------------------------------- ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName -> Bool -> LaTeX ppFunSig loc doc docnames typ unicode = ppTypeOrFunSig loc docnames typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names , dcolon unicode) unicode where names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> HsPatSynDetails (LHsType DocName) -> LHsType DocName + -> (HsExplicitFlag, LHsTyVarBndrs DocName) -> LHsContext DocName -> LHsContext DocName + -> LHsType DocName -> Bool -> LaTeX -ppLPatSig loc doc docname args typ prov req unicode = - ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode - -ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName - -> HsPatSynDetails (HsType DocName) -> HsType DocName - -> HsContext DocName -> HsContext DocName - -> Bool -> LaTeX -ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc) +ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode + = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" - , pp_ctx prov - , pp_head + , ppDocBinder name , dcolon unicode - , pp_ctx req - , ppType unicode typ + , ppLTyVarBndrs expl qtvs unicode + , ctx + , ppType unicode ty ] - pp_head = case args of - PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs - InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right] + ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of + (Nothing, Nothing) -> empty + (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr + (Just prov, Nothing) -> prov <+> darr + (Just prov, Just req) -> prov <+> darr <+> req <+> darr - pp_type = ppParendType unicode - pp_ctx ctx = ppContext ctx unicode + darr = darrow unicode ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) unicode | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc) | otherwise = declWithDoc pref2 $ Just $ text "\\haddockbeginargs" $$ do_args 0 sep0 typ $$ text "\\end{tabulary}\\par" $$ fromMaybe empty (documentationToLaTeX doc) where do_largs n leader (L _ t) = do_args n leader t arg_doc n = rDoc (Map.lookup n argDocs) do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX do_args n leader (HsForAllTy Explicit tvs lctxt ltype) = decltt leader <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> ppLContextNoArrow lctxt unicode) <+> nl $$ do_largs n (darrow unicode) ltype do_args n leader (HsForAllTy Qualified a lctxt ltype) = do_args n leader (HsForAllTy Implicit a lctxt ltype) do_args n leader (HsForAllTy Implicit _ lctxt ltype) | not (null (unLoc lctxt)) = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ do_largs n (darrow unicode) ltype -- if we're not showing any 'forall' or class constraints or -- anything, skip having an empty line for the context. | otherwise = do_largs n leader ltype do_args n leader (HsFunTy lt r) = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ do_largs (n+1) (arrow unicode) r do_args n leader t = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) <+> dcolon unicode <+> ppType unicode ty ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] ppTyVars tvs = map ppSymName (tyvarNames tvs) tyvarNames :: LHsTyVarBndrs DocName -> [Name] tyvarNames = map getName . hsLTyVarNames declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX declWithDoc decl doc = text "\\begin{haddockdesc}" $$ text "\\item[\\begin{tabular}{@{}l}" $$ text (latexMonoFilter (show decl)) $$ text "\\end{tabular}]" <> (if isNothing doc then empty else text "\\haddockbegindoc") $$ maybe empty id doc $$ text "\\end{haddockdesc}" -- in a group of decls, we don't put them all in the same tabular, -- because that would prevent the group being broken over a page -- boundary (breaks Foreign.C.Error for example). multiDecl :: [LaTeX] -> LaTeX multiDecl decls = text "\\begin{haddockdesc}" $$ vcat [ text "\\item[" $$ text (latexMonoFilter (show decl)) $$ text "]" | decl <- decls ] $$ text "\\end{haddockdesc}" ------------------------------------------------------------------------------- -- * Rendering Doc ------------------------------------------------------------------------------- maybeDoc :: Maybe (Doc DocName) -> LaTeX maybeDoc = maybe empty docToLaTeX -- for table cells, we strip paragraphs out to avoid extra vertical space -- and don't add a quote environment. rDoc :: Maybe (Doc DocName) -> LaTeX rDoc = maybeDoc . fmap latexStripTrailingWhitespace ------------------------------------------------------------------------------- -- * Class declarations ------------------------------------------------------------------------------- ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) <+> ppAppDocNameNames summ n (tyvarNames $ tvs) <+> ppFds fds unicode ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX ppFds fds unicode = if null fds then empty else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> hsep (map ppDocName vars2) ppClassDecl :: [DocInstance DocName] -> SrcSpan -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> LaTeX ppClassDecl instances loc doc subdocs (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 classheader | null lsigs = hdr unicode | otherwise = hdr unicode <+> keyword "where" hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds body = catMaybes [documentationToLaTeX doc, body_] body_ | null lsigs, null ats, null at_defs = Nothing | null ats, null at_defs = Just methodTable --- | otherwise = atTable $$ methodTable | otherwise = error "LaTeX.ppClassDecl" methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ vcat [ ppFunSig loc doc names typ unicode | L _ (TypeSig lnames (L _ typ)) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that -- there are different subdocs for different names in a single -- type signature? instancesBit = ppDocInstances unicode instances ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX ppDocInstances _unicode [] = empty ppDocInstances unicode (i : rest) | Just ihead <- isUndocdInstance i = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$ ppDocInstances unicode rest' | otherwise = ppDocInstance unicode i $$ ppDocInstances unicode rest where (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) isUndocdInstance (i,Nothing) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX ppDocInstance unicode (instHead, doc) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc) ppInstDecl :: Bool -> InstHead DocName -> LaTeX ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead ppInstHead :: Bool -> InstHead DocName -> LaTeX ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type" <+> ppAppNameTypes n ks ts unicode <+> maybe empty (\t -> equals <+> ppType unicode t) rhs ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) = error "data instances not supported by --latex yet" lookupAnySubdoc :: (Eq name1) => name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 lookupAnySubdoc n subdocs = case lookup n subdocs of Nothing -> noDocForDecl Just docs -> docs ------------------------------------------------------------------------------- -- * Data & newtype declarations ------------------------------------------------------------------------------- ppDataDecl :: [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> LaTeX ppDataDecl instances subdocs _loc doc dataDecl unicode = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) (if null body then Nothing else Just (vcat body)) $$ instancesBit where cons = dd_cons (tcdDataDefn dataDecl) resTy = (con_res . unLoc . head) cons body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of ResTyGADT _ -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit | null cons = Nothing | otherwise = Just $ text "\\haddockbeginconstrs" $$ vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ text "\\end{tabulary}\\par" instancesBit = ppDocInstances unicode instances -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") where ppForall = case forall of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " Qualified -> empty Implicit -> empty ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocName -> LaTeX ppSideBySideConstr subdocs unicode leader (L _ con) = leader <-> case con_res con of ResTyH98 -> case con_details con of PrefixCon args -> decltt (hsep ((header_ unicode <+> ppBinder occ) : map (ppLParendType unicode) args)) <-> rDoc mbDoc <+> nl RecCon fields -> (decltt (header_ unicode <+> ppBinder occ) <-> rDoc mbDoc <+> nl) $$ doRecordFields fields InfixCon arg1 arg2 -> decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, ppBinder occ, ppLParendType unicode arg2 ]) <-> rDoc mbDoc <+> nl ResTyGADT resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> doGADTCon args resTy cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ doRecordFields fields InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy where doRecordFields fields = vcat (map (ppSideBySideField subdocs unicode) fields) doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [ ppForAll forall ltvs (con_cxt con) unicode, ppLType unicode (foldr mkFunTy resTy args) ] ) <-> rDoc mbDoc header_ = ppConstrHdr forall tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = decltt (ppBinder (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above mbDoc = lookup name subdocs >>= combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX -- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = -- declWithDoc False doc ( -- hsep ((ppHsConstrHdr tvs ctxt +++ -- ppHsBinder False nm) : map ppHsBangType typeList) -- ) -- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = -- td << vanillaTable << ( -- case doc of -- Nothing -> aboves [hdr, fields_html] -- Just _ -> aboves [hdr, constr_doc, fields_html] -- ) -- -- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) -- -- constr_doc -- | isJust doc = docBox (docToLaTeX (fromJust doc)) -- | otherwise = LaTeX.emptyTable -- -- fields_html = -- td << -- table ! [width "100%", cellpadding 0, cellspacing 8] << ( -- aboves (map ppFullField (concat (map expandField fields))) -- ) -- -} -- -- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX -- ppShortField summary unicode (ConDeclField (L _ name) ltype _) -- = tda [theclass "recfield"] << ( -- ppBinder summary (docNameOcc name) -- <+> dcolon unicode <+> ppLType unicode ltype -- ) -- -- {- -- ppFullField :: HsFieldDecl -> LaTeX -- ppFullField (HsFieldDecl [n] ty doc) -- = declWithDoc False doc ( -- ppHsBinder False n <+> dcolon <+> ppHsBangType ty -- ) -- ppFullField _ = error "ppFullField" -- -- expandField :: HsFieldDecl -> [HsFieldDecl] -- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] -- -} -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode = -- newtype or data (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context ppLContext ctxt unicode <+> -- T a b c ..., or a :+: b ppAppDocNameNames False name (tyvarNames tyvars) ppDataHeader _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- -- | Print an application of a DocName and two lists of HsTypes (kinds, types) ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode) -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX ppAppDocNameNames _summ n ns = ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName -- | General printing of type applications ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX ppTypeApp n [] (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN n <+> ppT t2 ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts) ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX +ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc + +ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX +ppContextNoLocsMaybe [] _ = Nothing +ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX -ppContextNoArrow [] _ = empty -ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode +ppContextNoArrow cxt unicode = fromMaybe empty $ + ppContextNoLocsMaybe (map unLoc cxt) unicode ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX -ppContextNoLocs [] _ = empty -ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode +ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode ppContext :: HsContext DocName -> Bool -> LaTeX ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode pp_hs_context :: [HsType DocName] -> Bool -> LaTeX pp_hs_context [] _ = empty pp_hs_context [p] unicode = ppType unicode p pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ------------------------------------------------------------------------------- -- * Types and contexts ------------------------------------------------------------------------------- ppBang :: HsBang -> LaTeX ppBang HsNoBang = empty ppBang _ = char '!' -- Unpacked args is an implementation detail, tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX tupleParens HsUnboxedTuple = ubxParenList tupleParens _ = parenList ------------------------------------------------------------------------------- -- * Rendering of HsType -- -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC -- Used for LH arg of (->) pREC_OP = (2 :: Int) -- Used for arg of any infix operator -- (we don't keep their fixities around) pREC_CON = (3 :: Int) -- Used for arg of type applicn: -- always parenthesise unless atomic maybeParen :: Int -- Precedence of context -> Int -- Precedence of top-level operator -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op) maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p | otherwise = p ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode ppLKind :: Bool -> LHsKind DocName -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) ppKind :: Bool -> HsKind DocName -> LaTeX 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 -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Bool -> LaTeX -ppForAll expl tvs cxt unicode - | show_forall = forall_part <+> ppLContext cxt unicode - | otherwise = ppLContext cxt unicode +ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode + +ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Bool -> LaTeX +ppLTyVarBndrs expl tvs unicode + | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot + | otherwise = empty where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot - ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty _ (HsTyVar name) _ = ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) 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 (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" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op occName = nameOccName . getName . unLoc $ op ppr_mono_ty ctxt_prec (HsParTy ty) unicode -- = parens (ppr_mono_lty pREC_TOP ty) = ppr_mono_lty ctxt_prec 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 = let p1 = ppr_mono_lty pREC_FUN ty1 unicode p2 = ppr_mono_lty pREC_TOP ty2 unicode in maybeParen ctxt_prec pREC_FUN $ sep [p1, arrow unicode <+> p2] ------------------------------------------------------------------------------- -- * Names ------------------------------------------------------------------------------- ppBinder :: OccName -> LaTeX ppBinder n | isInfixName n = parens $ ppOccName n | otherwise = ppOccName n -ppBinderInfix :: OccName -> LaTeX -ppBinderInfix n - | isInfixName n = ppOccName n - | otherwise = quotes $ ppOccName n - isInfixName :: OccName -> Bool isInfixName n = isVarSym n || isConSym n ppSymName :: Name -> LaTeX ppSymName name | isNameSym name = parens $ ppName name | otherwise = ppName name ppVerbOccName :: OccName -> LaTeX ppVerbOccName = text . latexFilter . occNameString ppIPName :: HsIPName -> LaTeX ppIPName ip = text $ unpackFS $ hsIPNameFS ip ppOccName :: OccName -> LaTeX ppOccName = text . occNameString ppVerbDocName :: DocName -> LaTeX ppVerbDocName = ppVerbOccName . nameOccName . getName ppVerbRdrName :: RdrName -> LaTeX ppVerbRdrName = ppVerbOccName . rdrNameOcc ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName ppLDocName :: Located DocName -> LaTeX ppLDocName (L _ d) = ppDocName d ppDocBinder :: DocName -> LaTeX ppDocBinder = ppBinder . nameOccName . getName -ppDocBinderInfix :: DocName -> LaTeX -ppDocBinderInfix = ppBinderInfix . nameOccName . getName - ppName :: Name -> LaTeX ppName = ppOccName . nameOccName latexFilter :: String -> String latexFilter = foldr latexMunge "" latexMonoFilter :: String -> String latexMonoFilter = foldr latexMonoMunge "" latexMunge :: Char -> String -> String latexMunge '#' s = "{\\char '43}" ++ s latexMunge '$' s = "{\\char '44}" ++ s latexMunge '%' s = "{\\char '45}" ++ s latexMunge '&' s = "{\\char '46}" ++ s latexMunge '~' s = "{\\char '176}" ++ s latexMunge '_' s = "{\\char '137}" ++ s latexMunge '^' s = "{\\char '136}" ++ s latexMunge '\\' s = "{\\char '134}" ++ s latexMunge '{' s = "{\\char '173}" ++ s latexMunge '}' s = "{\\char '175}" ++ s latexMunge '[' s = "{\\char 91}" ++ s latexMunge ']' s = "{\\char 93}" ++ s latexMunge c s = c : s latexMonoMunge :: Char -> String -> String latexMonoMunge ' ' s = '\\' : ' ' : s latexMonoMunge '\n' s = '\\' : '\\' : s latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- -- * Doc Markup ------------------------------------------------------------------------------- parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) parLatexMarkup ppId = Markup { markupParagraph = \p v -> p v <> text "\\par" $$ text "", markupEmpty = \_ -> empty, markupString = \s v -> text (fixString v s), markupAppend = \l r v -> l v <> r v, markupIdentifier = markupId ppId, markupIdentifierUnchecked = markupId (ppVerbOccName . snd), markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), markupWarning = \p v -> emph (p v), markupEmphasis = \p v -> emph (p v), markupBold = \p v -> bold (p v), markupMonospaced = \p _ -> tt (p Mono), markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", markupPic = \p _ -> markupPic p, markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", markupHyperlink = \l _ -> markupLink l, markupAName = \_ _ -> empty, markupProperty = \p _ -> quote $ verb $ text p, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, markupHeader = \(Header l h) p -> header l (h p) } where header 1 d = text "\\section*" <> braces d header 2 d = text "\\subsection*" <> braces d header l d | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d header l _ = error $ "impossible header level in LaTeX generation: " ++ show l fixString Plain s = latexFilter s fixString Verb s = s fixString Mono s = latexMonoFilter s markupLink (Hyperlink url mLabel) = case mLabel of Just label -> text "\\href" <> braces (text url) <> braces (text label) Nothing -> text "\\url" <> braces (text url) -- Is there a better way of doing this? Just a space is an aribtrary choice. markupPic (Picture uri title) = parens (imageText title) where imageText Nothing = beg imageText (Just t) = beg <> text " " <> text t beg = text "image: " <> text uri markupId ppId_ id v = case v of Verb -> theid Mono -> theid Plain -> text "\\haddockid" <> braces theid where theid = ppId_ id latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) latexMarkup = parLatexMarkup ppVerbDocName rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) rdrLatexMarkup = parLatexMarkup ppVerbRdrName docToLaTeX :: Doc DocName -> LaTeX docToLaTeX doc = markup latexMarkup doc Plain documentationToLaTeX :: Documentation DocName -> Maybe LaTeX documentationToLaTeX = fmap docToLaTeX . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain data StringContext = Plain | Verb | Mono latexStripTrailingWhitespace :: Doc a -> Doc a latexStripTrailingWhitespace (DocString s) | null s' = DocEmpty | otherwise = DocString s where s' = reverse (dropWhile isSpace (reverse s)) latexStripTrailingWhitespace (DocAppend l r) | DocEmpty <- r' = latexStripTrailingWhitespace l | otherwise = DocAppend l r' where r' = latexStripTrailingWhitespace r latexStripTrailingWhitespace (DocParagraph p) = latexStripTrailingWhitespace p latexStripTrailingWhitespace other = other ------------------------------------------------------------------------------- -- * LaTeX utils ------------------------------------------------------------------------------- itemizedList :: [LaTeX] -> LaTeX itemizedList items = text "\\begin{itemize}" $$ vcat (map (text "\\item" $$) items) $$ text "\\end{itemize}" enumeratedList :: [LaTeX] -> LaTeX enumeratedList items = text "\\begin{enumerate}" $$ vcat (map (text "\\item " $$) items) $$ text "\\end{enumerate}" descriptionList :: [(LaTeX,LaTeX)] -> LaTeX descriptionList items = text "\\begin{description}" $$ vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ text "\\end{description}" tt :: LaTeX -> LaTeX tt ltx = text "\\haddocktt" <> braces ltx decltt :: LaTeX -> LaTeX decltt ltx = text "\\haddockdecltt" <> braces ltx emph :: LaTeX -> LaTeX emph ltx = text "\\emph" <> braces ltx bold :: LaTeX -> LaTeX bold ltx = text "\\textbf" <> braces ltx verb :: LaTeX -> LaTeX verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" -- NB. swallow a trailing \n in the verbatim text by appending the -- \end{verbatim} directly, otherwise we get spurious blank lines at the -- end of code blocks. quote :: LaTeX -> LaTeX quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow unicode = text (if unicode then "→" else "->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall") dot :: LaTeX dot = char '.' parenList :: [LaTeX] -> LaTeX parenList = parens . hsep . punctuate comma ubxParenList :: [LaTeX] -> LaTeX ubxParenList = ubxparens . hsep . punctuate comma ubxparens :: LaTeX -> LaTeX ubxparens h = text "(#" <> h <> text "#)" pabrackets :: LaTeX -> LaTeX pabrackets h = text "[:" <> h <> text ":]" nl :: LaTeX nl = text "\\\\" keyword :: String -> LaTeX keyword = text infixr 4 <-> -- combining table cells (<->) :: LaTeX -> LaTeX -> LaTeX a <-> b = a <+> char '&' <+> b diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index d4869ab..97f3fb0 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -1,888 +1,893 @@ {-# LANGUAGE TransformListComp #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl -- Copyright : (c) Simon Marlow 2003-2006, -- David Waern 2006-2009, -- Mark Lentczner 2010 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Decl ( ppDecl, ppTyName, ppTyFamHeader, ppTypeApp, tyvarNames ) where import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe -import Data.Monoid ( mempty ) import Text.XHtml hiding ( name, title, p, quote ) import GHC import GHC.Exts import Name import BooleanFormula ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual - SigD (PatSynSig lname args ty prov req) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual + SigD (PatSynSig lname qtvs prov req ty) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual = ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) splice unicode qual where pp_typ = ppType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Located DocName -> - HsPatSynDetails (LHsType DocName) -> LHsType DocName -> - LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] -> + (HsExplicitFlag, LHsTyVarBndrs DocName) -> + LHsContext DocName -> LHsContext DocName -> + LHsType DocName -> + [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual = - ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) - (unLoc prov) (unLoc req) fixities splice unicode qual - -ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - DocName -> - HsPatSynDetails (HsType DocName) -> HsType DocName -> - HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities - splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual | summary = pref1 - | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual) + | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc where pref1 = hsep [ toHtml "pattern" - , pp_cxt prov - , pp_head + , ppBinder summary occname , dcolon unicode - , pp_cxt req - , ppType unicode qual typ + , ppLTyVarBndrs expl qtvs unicode qual + , cxt + , ppLType unicode qual typ ] - pp_head = case args of - PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs - InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right] - pp_cxt cxt = ppContext cxt unicode qual - pp_type = ppParendType unicode qual + cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of + (Nothing, Nothing) -> noHtml + (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr + (Just prov, Nothing) -> prov <+> darr + (Just prov, Just req) -> prov <+> darr <+> req <+> darr - occname = nameOccName . getName $ docname + darr = darrow unicode + occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> Splice -> Unicode -> Qualification -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode qual = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) splice unicode qual where occnames = map (nameOccName . getName) docnames addFixities html | summary = html | otherwise = html <+> ppFixities fixities qual ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (Html, Html, Html) -> Splice -> Unicode -> Qualification -> Html ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual | summary = pref1 | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc where curName = getName <$> listToMaybe docnames argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocName -> [SubDecl] do_args n leader (HsForAllTy Explicit tvs lctxt ltype) = (leader <+> hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) : do_largs n (darrow unicode) ltype do_args n leader (HsForAllTy Implicit _ lctxt ltype) | not (null (unLoc lctxt)) = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) : do_largs n (darrow unicode) ltype -- if we're not showing any 'forall' or class constraints or -- anything, skip having an empty line for the context. | otherwise = do_largs n leader ltype do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t = [(leader <+> ppType unicode qual t, argDoc n, [])] ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge where ppFix (ns, p, d) = thespan ! [theclass "fixity"] << (toHtml d <+> toHtml (show p) <+> ppNames ns) ppDir InfixR = "infixr" ppDir InfixL = "infixl" ppDir InfixN = "infix" ppNames = case fs of _:[] -> const noHtml -- Don't display names for fixities on single names _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False) uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs , let d' = ppDir d , then group by Down (p,d') using groupWith ] rightEdge = thespan ! [theclass "rightedge"] << noHtml ppTyVars :: LHsTyVarBndrs DocName -> [Html] ppTyVars tvs = map ppTyName (tyvarNames tvs) tyvarNames :: LHsTyVarBndrs DocName -> [Name] tyvarNames = map getName . hsLTyVarNames ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities splice unicode qual = ppFunSig summary links loc doc [name] typ fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Splice -> Unicode -> Qualification -> Html ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) splice unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs | summary = noHtml | otherwise = ppFixities fixities qual ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html ppTypeSig summary nms pp_ty unicode = concatHtml htmlNames <+> dcolon unicode <+> pp_ty where htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms ppTyName :: Name -> Html ppTyName = ppName Prefix -------------------------------------------------------------------------------- -- * Type families -------------------------------------------------------------------------------- ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info , fdKindSig = mkind }) unicode qual = (case info of OpenTypeFamily | associated -> keyword "type" | otherwise -> keyword "type family" DataFamily | associated -> keyword "data" | otherwise -> keyword "data family" ClosedTypeFamily _ -> keyword "type family" ) <+> ppFamDeclBinderWithVars summary d <+> (case mkind of Just kind -> dcolon unicode <+> ppLKind unicode qual kind Nothing -> noHtml ) ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html ppTyFam summary associated links instances fixities loc doc decl splice unicode qual | summary = ppTyFamHeader True associated decl unicode qual | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit where docname = unLoc $ fdLName decl header_ = topDeclElem links loc splice [docname] $ ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual instancesBit | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl , not summary = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise = ppInstances instances docname unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs , tfe_pats = HsWB { hswb_cts = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) -------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppAssocType summ links doc (L loc decl) fixities splice unicode qual = ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual -------------------------------------------------------------------------------- -- * TyClDecl helpers -------------------------------------------------------------------------------- -- | Print a type family and its variables ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs) -- | Print a newtype / data binder and its variables ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html ppDataBinderWithVars summ decl = ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- -- | Print an application of a DocName and two lists of HsTypes (kinds, types) ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Unicode -> Qualification -> Html ppAppNameTypes n ks ts unicode qual = ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html ppAppDocNameNames summ n ns = ppTypeApp n [] ns ppDN ppTyName where ppDN notation = ppBinderFixity notation summ . nameOccName . getName ppBinderFixity Infix = ppBinderInfix ppBinderFixity _ = ppBinder -- | General printing of type applications ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html ppTypeApp n [] (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode -> Qualification -> Html ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html +ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc + ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html -ppContextNoArrow [] _ _ = noHtml -ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual +ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ + ppContextNoLocsMaybe (map unLoc cxt) unicode qual ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html -ppContextNoLocs [] _ _ = noHtml -ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual - <+> darrow unicode +ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode qual +ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html +ppContextNoLocsMaybe [] _ _ = Nothing +ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual + ppContext :: HsContext DocName -> Unicode -> Qualification -> Html ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html ppHsContext [] _ _ = noHtml ppHsContext [p] unicode qual = ppCtxType unicode qual p ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ------------------------------------------------------------------------------- -- * Class declarations ------------------------------------------------------------------------------- ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode qual ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 ppVars = hsep . map (ppDocName qual Prefix True) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode qual = if not (any isVanillaLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False ( [ ppAssocType summary links doc at [] splice unicode qual | at <- ats , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ -- ToDo: add associated type defaults [ ppFunSig summary links loc doc names typ [] splice unicode qual | L _ (TypeSig lnames (L _ typ)) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that -- there are different subdocs for different names in a single -- type signature? ) where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual nm = unLoc lname ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Splice -> Unicode -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) splice unicode qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual | otherwise = classheader +++ docSection Nothing qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where classheader | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual nm = tcdName decl hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds -- ToDo: add assocatied typ defaults atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual | at <- ats , let n = unL . fdLName $ unL at doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual | L _ (TypeSig lnames (L _ typ)) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities , n == n' ] names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that -- there are different subdocs for different names in a single -- type signature? minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | Var (L _ n) <- xs] == sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing And [] : _ -> subMinimal $ toHtml "Nothing" m : _ -> subMinimal $ ppMinimal False m _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id instancesBit = ppInstances instances nm unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html ppInstances instances baseName unicode qual = subInstances qual instName (map instDecl instances) where instName = getOccString $ getName baseName instDecl :: DocInstance DocName -> SubDecl instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual <+> ppAppNameTypes n ks ts unicode qual instHead (n, ks, ts, TypeInst rhs) = keyword "type" <+> ppAppNameTypes n ks ts unicode qual <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs instHead (n, ks, ts, DataInst dd) = keyword "data" <+> ppAppNameTypes n ks ts unicode qual <+> ppShortDataDecl False True dd unicode qual lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n ------------------------------------------------------------------------------- -- * Data & newtype declarations ------------------------------------------------------------------------------- -- TODO: print contexts ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html ppShortDataDecl summary dataInst dataDecl unicode qual | [] <- cons = dataHeader | [lcon] <- cons, ResTyH98 <- resTy, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot | ResTyH98 <- resTy = dataHeader +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) | otherwise = (dataHeader <+> keyword "where") +++ shortSubDecls dataInst (map doGADTConstr cons) where dataHeader | dataInst = noHtml | otherwise = ppDataHeader summary dataDecl unicode qual doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl) resTy = (con_res . unLoc . head) cons ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Splice -> Unicode -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl splice unicode qual | summary = ppShortDataDecl summary False dataDecl unicode qual | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit where docname = tcdName dataDecl cons = dd_cons (tcdDataDefn dataDecl) resTy = (con_res . unLoc . head) cons header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual whereBit | null cons = noHtml | otherwise = case resTy of ResTyGADT _ -> keyword "where" _ -> noHtml constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities ] instancesBit = ppInstances instances docname unicode qual ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot where (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) ppShortConstrParts summary dataInst con unicode qual = case con_res con of ResTyH98 -> case con_details con of PrefixCon args -> (header_ unicode qual +++ hsep (ppBinder summary occ : map (ppLParendType unicode qual) args), noHtml, noHtml) RecCon fields -> (header_ unicode qual +++ ppBinder summary occ <+> char '{', doRecordFields fields, char '}') InfixCon arg1 arg2 -> (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, ppBinderInfix summary occ, ppLParendType unicode qual arg2], noHtml, noHtml) ResTyGADT resTy -> case con_details con of -- prefix & infix could use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) -- display GADT records with the new syntax, -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) -- (except each field gets its own line in docs, to match -- non-GADT records) RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+> ppForAll forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) where doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields) doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ ppForAll forall_ ltvs lcontext unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames ltvs lcontext = con_cxt con context = unLoc (con_cxt con) forall_ = con_explicit con mkFunTy a b = noLoc (HsFunTy a b) -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode -> Qualification -> Html ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual <+> darrow unicode +++ toHtml " ") where ppForall = case forall_ of Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " Qualified -> noHtml Implicit -> noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) where decl = case con_res con of ResTyH98 -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppBinder False occ) : map (ppLParendType unicode qual) args) <+> fixity RecCon _ -> header_ +++ ppBinder False occ <+> fixity InfixCon arg1 arg2 -> hsep [header_ +++ ppLParendType unicode qual arg1, ppBinderInfix False occ, ppLParendType unicode qual arg2] <+> fixity ResTyGADT resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> doGADTCon args resTy cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy fieldPart = case con_details con of RecCon fields -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) fields) doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppBinder False occ <+> dcolon unicode <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] <+> fixity fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype, mbDoc, []) where -- don't use cd_fld_doc for same reason we don't use con_doc above mbDoc = lookup name subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) = ppBinder summary (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd , dd_ctxt = ctxt , dd_kindSig = ks } }) unicode qual = -- newtype or data (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context ppLContext ctxt unicode qual <+> -- T a b c ..., or a :+: b ppDataBinderWithVars summary decl <+> case ks of Nothing -> mempty Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -- * Types and contexts -------------------------------------------------------------------------------- ppBang :: HsBang -> Html ppBang HsNoBang = noHtml ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, -- so we just show the strictness annotation tupleParens :: HsTupleSort -> [Html] -> Html tupleParens HsUnboxedTuple = ubxParenList tupleParens _ = parenList -------------------------------------------------------------------------------- -- * Rendering of HsType -------------------------------------------------------------------------------- pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type -- (as opposed to (ctx1, ctx2) => type) pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC -- Used for LH arg of (->) pREC_OP = 3 :: Int -- Used for arg of any infix operator -- (we don't keep their fixities around) pREC_CON = 4 :: Int -- Used for arg of type applicn: -- always parenthesise unless atomic maybeParen :: Int -- Precedence of context -> Int -- Precedence of top-level operator -> Html -> Html -- Wrap in parens if (ctxt >= op) maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p | otherwise = p ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> Located (HsType DocName) -> Html ppLType unicode qual y = ppType unicode qual (unLoc y) ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HsType DocName -> Html ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocName -> Html 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 -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Unicode -> Qualification -> Html ppForAll expl tvs cxt unicode qual - | show_forall = forall_part <+> ppLContext cxt unicode qual - | otherwise = ppLContext cxt unicode qual + = forall_part <+> ppLContext cxt unicode qual + where + forall_part = ppLTyVarBndrs expl tvs unicode qual + +ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Unicode -> Qualification + -> Html +ppLTyVarBndrs expl tvs unicode _qual + | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot + | otherwise = noHtml where show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) 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 ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ 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" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual = maybeParen ctxt_prec pREC_CTX $ ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] 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 = ppLDocName qual Infix op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty) = ppr_mono_lty ctxt_prec 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 -> Unicode -> Qualification -> Html ppr_fun_ty ctxt_prec ty1 ty2 unicode qual = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual p2 = ppr_mono_lty pREC_TOP ty2 unicode qual in maybeParen ctxt_prec pREC_FUN $ hsep [p1, arrow unicode <+> p2] diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 4830639..08892cd 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -1,394 +1,396 @@ {-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Convert -- Copyright : (c) Isaac Dupree 2009, -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable -- -- Conversion between TyThing and HsDecl. This functionality may be moved into -- GHC at some point. ----------------------------------------------------------------------------- module Haddock.Convert where -- Some other functions turned out to be useful for converting -- instance heads, which aren't TyThings, so just export everything. import HsSyn import TcType ( tcSplitSigmaTy ) import TypeRep -import Type(isStrLitTy) +import Type ( isStrLitTy, mkFunTys ) import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name import Var import Class import TyCon import CoAxiom import ConLike import DataCon import PatSyn import FamInstEnv import BasicTypes ( TupleSort(..) ) import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon ) import PrelNames (ipClassName) import Bag ( emptyBag ) import Unique ( getUnique ) import SrcLoc ( Located, noLoc, unLoc ) import Data.List( partition ) import Haddock.Types -- the main function here! yay! tyThingToLHsDecl :: TyThing -> LHsDecl Name tyThingToLHsDecl t = noLoc $ case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. -- foreign-imported functions could be represented with ForD -- instead of SigD if we wanted... -- -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. AnId i -> SigD (synifyIdSig ImplicitizeForAll i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a extractFamilyDecl (FamDecl d) = noLoc d extractFamilyDecl _ = error "tyThingToLHsDecl: impossible associated tycon" atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl] atFamDecls = map extractFamilyDecl atTyClDecls in TyClD $ ClassDecl { 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 = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) : 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: , tcdATs = atFamDecls , tcdATDefs = [] --ignore associated type defaults , tcdDocs = [] --we don't have any docs at this point , tcdFVs = placeHolderNamesTc } | otherwise -> TyClD (synifyTyCon Nothing 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 -> synifyAxiom ax -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps + let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps + qtvs = univ_tvs ++ ex_tvs + ty = mkFunTys arg_tys res_ty in SigD $ PatSynSig (synifyName ps) - (fmap (synifyType WithinType) (patSynTyDetails ps)) - (synifyType WithinType res_ty) + (Implicit, synifyTyVars qtvs) (synifyCtx req_theta) (synifyCtx prov_theta) + (synifyType WithinType ty) synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name , tfe_pats = HsWB { hswb_cts = typats , hswb_kvs = map tyVarName kvs , hswb_tvs = map tyVarName tvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> HsDecl Name synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenSynFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch , tfid_fvs = placeHolderNamesTc })) | Just ax' <- isClosedSynFamilyTyCon_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error = TyClD (synifyTyCon (Just ax) tc) | otherwise = error "synifyAxiom: closed/open family confusion" synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name synifyTyCon coax tc | isFunTyCon tc || isPrimTyCon tc = DataDecl { tcdLName = synifyName tc , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar (getName fakeTyVar) (synifyKindSig realKind) in HsQTvs { hsq_kvs = [] -- No kind polymorphism , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * } , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing , dd_kindSig = Just (synifyKindSig (tyConKind tc)) -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = Nothing } , tcdFVs = placeHolderNamesTc } | isSynFamilyTyCon tc = case synTyConRhs_maybe tc of Just rhs -> let info = case rhs of OpenSynFamilyTyCon -> OpenTypeFamily ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches) _ -> error "synifyTyCon: type/data family confusion" in FamDecl (FamilyDecl { fdInfo = info , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc) , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) }) Nothing -> error "synifyTyCon: impossible open type synonym?" | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of DataFamilyTyCon -> FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing) --always kind '*' _ -> error "synifyTyCon: impossible open data type?" | isSynTyCon tc = case synTyConRhs_maybe tc of Just (SynonymTyCon ty) -> SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc) , tcdRhs = synifyType WithinType ty , tcdFVs = placeHolderNamesTc } _ -> error "synifyTyCon: impossible synTyCon" | otherwise = -- (closed) newtype and data let alg_nd = if isNewTyCon tc then NewType else DataType alg_ctx = synifyCtx (tyConStupidTheta tc) name = case coax of Just a -> synifyName a -- Data families are named according to their -- CoAxioms, not their TyCons _ -> synifyName tc tyvars = synifyTyVars (tyConTyVars tc) kindSig = Just (tyConKind tc) -- The data constructors. -- -- Any data-constructors not exported from the module that *defines* the -- type will not (cannot) be included. -- -- Very simple constructors, Haskell98 with no existentials or anything, -- probably look nicer in non-GADT syntax. In source code, all constructors -- must be declared with the same (GADT vs. not) syntax, and it probably -- is less confusing to follow that principle for the documentation as well. -- -- There is no sensible infix-representation for GADT-syntax constructor -- declarations. They cannot be made in source code, but we could end up -- with some here in the case where some constructors use existentials. -- That seems like an acceptable compromise (they'll just be documented -- in prefix position), since, otherwise, the logic (at best) gets much more -- complicated. (would use dataConIsInfix.) use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc) cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = Nothing defn = HsDataDefn { dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing , dd_kindSig = fmap synifyKindSig kindSig , dd_cons = cons , dd_derivs = alg_deriv } in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn , tcdFVs = placeHolderNamesTc } -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its -- result-type. -- But you might want pass False in simple enough cases, -- if you think it looks better. synifyDataCon :: Bool -> DataCon -> LConDecl Name synifyDataCon use_gadt_syntax dc = noLoc $ let -- dataConIsInfix allegedly tells us whether it was declared with -- infix *syntax*. use_infix_syntax = dataConIsInfix dc use_named_field_syntax = not (null field_tys) name = synifyName dc -- con_qvars means a different thing depending on gadt-syntax (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc qvars = if use_gadt_syntax then synifyTyVars (univ_tvs ++ ex_tvs) else synifyTyVars ex_tvs -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of HsUnpack {} -> HsUserBang (Just True) True HsStrict -> HsUserBang (Just False) True _ -> bang in case src_bang of HsNoBang -> tySyn _ -> noLoc $ HsBangTy bang tySyn -- HsNoBang never appears, it's implied instead. ) arg_tys (dataConStrictMarks dc) field_tys = zipWith (\field synTy -> ConDeclField (synifyName field) synTy Nothing) (dataConFieldLabels dc) linear_tys hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> error "synifyDataCon: contradiction!" (True,False) -> RecCon field_tys (False,False) -> PrefixCon linear_tys (False,True) -> case linear_tys of [a,b] -> InfixCon a b _ -> error "synifyDataCon: infix with non-2 args?" hs_res_ty = if use_gadt_syntax then ResTyGADT (synifyType WithinType res_ty) else ResTyH98 -- finally we get synifyDataCon's result! in ConDecl name Implicit{-we don't know nor care-} qvars ctx hs_arg_tys hs_res_ty Nothing False --we don't want any "deprecated GADT syntax" warnings! synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs , hsq_tvs = map synifyTyVar tvs } where (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 = WithinType -- ^ normal situation. This is the safe one to use if you don't -- quite understand what's going on. | ImplicitizeForAll -- ^ beginning of a function definition, in which, to make it look -- less ugly, those rank-1 foralls are made implicit. | DeleteTopLevelQuantification -- ^ because in class methods the context is added to the type -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@) -- which is rather sensible, -- but we want to restore things to the source-syntax situation where -- the defining class gets to quantify all its functions for free! synifyType :: SynifyTypeState -> Type -> LHsType Name synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. | isTupleTyCon tc, tyConArity tc == length tys = noLoc $ HsTupleTy (case tupleTyConSort tc of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType) tys) -- ditto for lists | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons | tyConName tc == ipClassName , [name, ty] <- tys , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities | tc == eqTyCon , [ty1, ty2] <- tys = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) (noLoc $ HsTyVar (getName tc)) (map (synifyType WithinType) tys) synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsAppTy s1 s2 synifyType _ (FunTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau _ -> let forallPlicitness = case s of WithinType -> Explicit ImplicitizeForAll -> Implicit _ -> error "synifyType: impossible case!!!" sTvs = synifyTyVars tvs sCtx = synifyCtx ctx 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 synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name synifyInstHead (_, preds, cls, types) = ( getName cls , map (unLoc . synifyType WithinType) ks , map (unLoc . synifyType WithinType) ts , ClassInst $ map (unLoc . synifyType WithinType) preds ) where (ks,ts) = break (not . isKind) types -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> InstHead Name synifyFamInst fi opaque = ( fi_fam fi , map (unLoc . synifyType WithinType) ks , map (unLoc . synifyType WithinType) ts , case fi_flavor fi of SynFamilyInst | opaque -> TypeInst Nothing SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c ) where (ks,ts) = break (not . isKind) $ fi_tys fi diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index ad6a1e9..551e6e7 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -1,854 +1,854 @@ {-# LANGUAGE TupleSections, BangPatterns, LambdaCase #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Create -- Copyright : (c) Simon Marlow 2003-2006, -- David Waern 2006-2009, -- Mateusz Kowalczyk 2013 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Interface.Create (createInterface) where import Haddock.Types import Haddock.Options import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe import Data.Monoid import Data.Ord import Control.Applicative import Control.Arrow (second) import Control.DeepSeq import Control.Monad import Data.Function (on) import qualified Data.Foldable as F import qualified Packages import qualified Module import qualified SrcLoc import GHC import HscTypes import Name import Bag import RdrName import TcRnTypes import FastString (concatFS) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do let ms = pm_mod_summary . tm_parsed_module $ tm mi = moduleInfo tm L _ hsm = parsedSource tm !safety = modInfoSafe mi mdl = ms_mod ms dflags = ms_hspp_opts ms !instances = modInfoInstances mi !fam_instances = md_fam_insts md !exportedNames = modInfoExports mi (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. (group_, mayExports, mayDocHeader) <- case renamedSource tm of Nothing -> do liftErrMsg $ tell [ "Warning: Renamed source is not available." ] return (emptyRnGroup, Nothing, Nothing) Just (x, _, y, z) -> return (x, y, z) opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl let opts | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances ++ map getName fam_instances -- Locations of all TH splices splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] maps@(!docMap, !argMap, !subMap, !declMap, _) = mkMaps dflags gre localInsts declsWithDocs let exports0 = fmap (reverse . map unLoc) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 warningMap = mkWarningMap dflags warnings gre exportedNames let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps fixMap splices exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts -- Measure haddock documentation coverage. let prunedExportItems0 = pruneExportItems exportItems !haddockable = 1 + length exportItems -- module + exports !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 !coverage = (haddockable, haddocked) -- Prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. let prunedExportItems' | OptPrune `elem` opts = prunedExportItems0 | otherwise = exportItems !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' let !aliases = mkAliasMap dflags $ tm_renamed_source tm modWarn = moduleWarning dflags gre warnings return $! Interface { ifaceMod = mdl , ifaceOrigFilename = msHsFilePath ms , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing , ifaceOptions = opts , ifaceDocMap = docMap , ifaceArgMap = argMap , ifaceRnDocMap = M.empty , ifaceRnArgMap = M.empty , ifaceExportItems = prunedExportItems , ifaceRnExportItems = [] , ifaceExports = exportedNames , ifaceVisibleExports = visibleNames , ifaceDeclMap = declMap , ifaceSubMap = subMap , ifaceFixMap = fixMap , ifaceModuleAliases = aliases , ifaceInstances = instances , ifaceFamInstances = fam_instances , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName mkAliasMap dflags mRenamedSource = case mRenamedSource of Nothing -> M.empty Just (_,impDecls,_,_) -> M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do alias <- ideclAs impDecl return $ (lookupModuleDyn dflags (fmap Module.fsToPackageKey $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls -- similar to GHC.lookupModule lookupModuleDyn :: DynFlags -> Maybe PackageKey -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = case Packages.lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m [] -> Module.mkModule Module.mainPackageKey mdlName ------------------------------------------------------------------------------- -- Warnings ------------------------------------------------------------------------------- mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap mkWarningMap dflags warnings gre exps = case warnings of NoWarnings -> M.empty WarnAll _ -> M.empty WarnSome ws -> let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ , let n = gre_name elt, n `elem` exps ] in M.fromList $ map (second $ parseWarning dflags gre) ws' moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name) moduleWarning _ _ NoWarnings = Nothing moduleWarning _ _ (WarnSome _) = Nothing moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of DeprecatedTxt msg -> format "Deprecated: " (concatFS msg) WarningTxt msg -> format "Warning: " (concatFS msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs ------------------------------------------------------------------------------- -- Doc options -- -- Haddock options that are embedded in the source file ------------------------------------------------------------------------------- mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] mkDocOpts mbOpts flags mdl = do opts <- case mbOpts of Just opts -> case words $ replace ',' ' ' opts of [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] xs -> liftM catMaybes (mapM parseOption xs) Nothing -> return [] hm <- if Flag_HideModule (moduleString mdl) `elem` flags then return $ OptHide : opts else return opts if Flag_ShowExtensions (moduleString mdl) `elem` flags then return $ OptShowExtensions : hm else return hm parseOption :: String -> ErrMsgM (Maybe DocOption) parseOption "hide" = return (Just OptHide) parseOption "prune" = return (Just OptPrune) parseOption "ignore-exports" = return (Just OptIgnoreExports) parseOption "not-home" = return (Just OptNotHome) parseOption "show-extensions" = return (Just OptShowExtensions) parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing -------------------------------------------------------------------------------- -- Maps -------------------------------------------------------------------------------- type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) -- | 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 -> [Name] -> [(LHsDecl Name, [HsDocString])] -> Maps mkMaps dflags gre instances decls = let (a, b, c, d) = unzip4 $ map mappings decls in (f $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat mappings :: (LHsDecl Name, [HsDocString]) -> ( [(Name, Doc Name)] , [(Name, Map Int (Doc Name))] , [(Name, [Name])] , [(Name, [LHsDecl Name])] ) mappings (ldecl, docStrs) = let L l decl = ldecl declDoc :: [HsDocString] -> Map Int HsDocString -> (Maybe (Doc Name), Map Int (Doc Name)) declDoc strs m = let doc' = processDocStrings dflags gre strs m' = M.map (processDocStringParas dflags gre) m in (doc', m') (doc, args) = declDoc docStrs (typeDocs decl) subs :: [(Name, [HsDocString], Map Int HsDocString)] subs = subordinates instanceMap decl (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs ns = names l decl subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ] in seqList ns `seq` seqList subNs `seq` doc `seq` seqList subDocs `seq` seqList subArgs `seq` (dm, am, sm, cm) instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] names :: SrcSpan -> HsDecl Name -> [Name] names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs _ -> getInstLoc d names _ decl = getMainDeclBinder decl -- Note [2]: ------------ -- 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 ClsInsts) to comments (associated -- with InstDecls). -------------------------------------------------------------------------------- -- Declarations -------------------------------------------------------------------------------- -- | Get all subordinate declarations inside a declaration, and their docs. subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do DataFamInstDecl { dfid_tycon = L l _ , dfid_defn = def } <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def InstD (DataFamInstD d) -> dataSubs (dfid_defn d) TyClD d | isClassDecl d -> classSubs d | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] where classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] dataSubs dd = constrs ++ fields where cons = map unL $ (dd_cons dd) constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons , ConDeclField n _ doc <- flds ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of SigD (TypeSig _ ty) -> docs (unLoc ty) - SigD (PatSynSig _ arg_tys ty req prov) -> - let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ] + SigD (PatSynSig _ _ req prov ty) -> + let allTys = ty : concat [ unLoc req, unLoc prov ] in F.foldMap (docs . unLoc) allTys ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty go n (HsFunTy _ ty) = go (n+1) (unLoc ty) go n (HsDocTy _ (L _ doc)) = M.singleton n doc go _ _ = M.empty -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats docs = mkDecls tcdDocs DocD class_ defs = mkDecls (bagToList . tcdMeths) ValD class_ sigs = mkDecls tcdSigs SigD class_ ats = mkDecls tcdATs (TyClD . FamDecl) class_ -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only mkFixMap :: HsGroup Name -> FixMap mkFixMap group_ = M.fromList [ (n,f) | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ] -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup Name -> [LHsDecl Name] ungroup group_ = mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ mkDecls hs_defds DefD group_ ++ mkDecls hs_fords ForD group_ ++ mkDecls hs_docs DocD group_ ++ mkDecls hs_instds InstD group_ ++ mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs typesigs _ = error "expected ValBindsOut" valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds valbinds _ = error "expected ValBindsOut" -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] -- | Sort by source location sortByLoc :: [Located a] -> [Located a] sortByLoc = sortBy (comparing getLoc) -------------------------------------------------------------------------------- -- Filtering of declarations -- -- We filter out declarations that we don't intend to handle later. -------------------------------------------------------------------------------- -- | Filter out declarations that we don't handle in Haddock filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterDecls = filter (isHandled . unL . fst) where isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (SigD d) = isVanillaLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True isHandled _ = False -- | Go through all class declarations and filter their sub-declarations filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where filterClass (TyClD c) = TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" -------------------------------------------------------------------------------- -- Collect docs -- -- To be able to attach the right Haddock comment to the right declaration, -- we sort the declarations by their SrcLoc and "collect" the docs for each -- declaration. -------------------------------------------------------------------------------- -- | Collect docs and attach them to the right declarations. collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] collectDocs = go Nothing [] where go Nothing _ [] = [] go (Just prev) docs [] = finished prev docs [] go prev docs (L _ (DocD (DocCommentNext str)) : ds) | Nothing <- prev = go Nothing (str:docs) ds | Just decl <- prev = finished decl docs (go Nothing [str] ds) go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds go Nothing docs (d:ds) = go (Just d) docs ds go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) finished decl docs rest = (decl, reverse docs) : rest -- | Build the list of items that will become the documentation, from the -- export list. At this point, the list of ExportItems is in terms of -- original names. -- -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems :: IfaceMap -> Module -- this module -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) -> [LHsDecl Name] -> Maps -> FixMap -> [SrcSpan] -- splice locations -> Maybe [IE Name] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems modMap thisMod warnings gre exportedNames decls maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls Just exports -> liftM concat $ mapM lookupExport exports where lookupExport (IEVar x) = declWith x lookupExport (IEThingAbs t) = declWith t lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ return . ExportGroup lev "" $ processDocString dflags gre docStr lookupExport (IEDoc docStr) = return $ return . ExportDoc $ processDocStringParas dflags gre docStr lookupExport (IEDocNamed str) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= return . \case Nothing -> [] Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = case findDecl t of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) in case () of _ -- temp hack: we filter out separately exported ATs, since we haven't decided how -- to handle them yet. We should really give an warning message also, and filter the -- name out in mkVisibleNames... | t `elem` declATs (unL decl) -> return [] -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames, Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ 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 [] -- normal case | otherwise -> case decl of -- A single signature might refer to many names, but we -- create an export item for a single name only. So we -- modify the signature to contain only that single name. L loc (SigD sig) -> -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig in return [ mkExportDecl t newDecl docs_ ] L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] _ -> return [ mkExportDecl t decl docs_ ] -- Declaration from another package ([], _) -> do mayDecl <- hiDecl dflags t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] Just decl -> -- We try to get the subs and docs -- from the installed .haddock file for that package. case M.lookup (nameModule t) instIfaceMap of Nothing -> do liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name mkExportDecl name decl (doc, subs) = decl' where decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False mdl = nameModule name subs' = filter (isExported . fst) subs sub_names = map fst subs' fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] isExported = (`elem` exportedNames) findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n | m == thisMod, Just ds <- M.lookup n declMap = (ds, lookupDocs n warnings docMap argMap subMap) | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) | otherwise = ([], (noDocForDecl, [])) where m = nameModule n 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 dflags t] return Nothing Just x -> return (Just (tyThingToLHsDecl x)) hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) hiValExportItem dflags name doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) Just decl -> return (ExportDecl decl doc [] [] fixities splice) where fixities = case fixity of Just f -> [(name, f)] Nothing -> [] -- | Lookup docs for a declaration from maps. lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) lookupDocs n warnings docMap argMap subMap = let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in let subs = M.findWithDefault [] n subMap in let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in (doc, subDocs) where lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) -- | Return all export items produced by an exported module. That is, we're -- interested in the exports produced by \"module B\" in such a scenario: -- -- > module A (module B) where -- > import B (...) hiding (...) -- -- There are three different cases to consider: -- -- 1) B is hidden, in which case we return all its exports that are in scope in A. -- 2) B is visible, but not all its exports are in scope in A, in which case we -- only return those that are. -- 3) B is visible and all its exports are in scope, in which case we return -- a single 'ExportModule' item. moduleExports :: Module -- ^ Module A -> ModuleName -- ^ The real name of B, the exported module -> DynFlags -- ^ The flags used when typechecking A -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A -> [LHsDecl Name] -- ^ All the declarations in A -> IfaceMap -- ^ Already created interfaces -> InstIfaceMap -- ^ Interfaces in other packages -> Maps -> FixMap -> [SrcSpan] -- ^ Locations of all TH splices -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls | otherwise = case M.lookup m ifaceMap of Just iface | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) | otherwise -> return [ ExportModule m ] Nothing -> -- We have to try to find it in the installed interfaces -- (external packages). case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ "documentation for exported module: " ++ pretty dflags expMod] return [] where m = mkModule packageKey expMod packageKey = modulePackageKey thisMod -- Note [1]: ------------ -- It is unnecessary to document a subordinate by itself at the top level if -- any of its parents is also documented. Furthermore, if the subordinate is a -- record field or a class method, documenting it under its parent -- indicates its special status. -- -- A user might expect that it should show up separately, so we issue a -- warning. It's a fine opportunity to also tell the user she might want to -- export the subordinate through the parent export item for clarity. -- -- The code removes top-level subordinates also when the parent is exported -- through a 'module' export. I think that is fine. -- -- (For more information, see Trac #69) fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan] -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where -- A type signature can have multiple names, like: -- foo, bar :: Types.. -- -- We go through the list of declarations and expand type signatures, so -- that every type signature has exactly one name! expandSig :: [LHsDecl name] -> [LHsDecl name] expandSig = foldr f [] where f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names f x xs = x : xs mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do return . Just . ExportGroup lev "" $ processDocString dflags gre docStr mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do return . Just . ExportDoc $ processDocStringParas dflags gre docStr mkExportItem (L l (ValD d)) | 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 dflags name doc (l `elem` splices) $ M.lookup name fixMap) | otherwise = return Nothing mkExportItem decl@(L l (InstD d)) | Just name <- M.lookup (getInstLoc d) instMap = let (doc, subs) = lookupDocs name warnings docMap argMap subMap in return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name | otherwise = return Nothing fixities name subs = [ (n,f) | n <- name : map fst subs , Just f <- [M.lookup n fixMap] ] expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) where (doc, subs) = lookupDocs name warnings docMap argMap subMap -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...). extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name extractDecl name mdl decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of TyClD d@ClassDecl {} -> let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, isVanillaLSig sig ] -- TODO: document fixity in case matches of [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) L pos sig = extractClassDecl n tyvar_names s0 in L pos (SigD sig) _ -> error "internal: extractDecl (ClassDecl)" TyClD d@DataDecl {} -> let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n , dfid_pats = HsWB { hswb_cts = tys } , dfid_defn = defn }) -> SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) , ConDeclField { cd_fld_name = L _ n } <- rec , n == name ] in case matches of [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" where getTyVars = hsLTyVarLocNames . tyClDeclTyVars toTypeNoLoc :: Located Name -> LHsType Name toTypeNoLoc = noLoc . HsTyVar . unLoc 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 (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) where lctxt = noLoc . ctxt ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest where matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] data_ty | ResTyGADT ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc where hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] mkVisibleNames (_, _, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns where exportName e@ExportDecl {} = name ++ subs where subs = map fst (expItemSubDocs e) name = case unLoc $ expItemDecl e of InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap decl -> getMainDeclBinder decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] seqList :: [a] -> () seqList [] = () seqList (x : xs) = x `seq` seqList xs -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search where search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing search (DocD (DocCommentNamed name' doc) : rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index dca93cc..aa1a170 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -1,531 +1,529 @@ {-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename -- Copyright : (c) Simon Marlow 2003-2006, -- David Waern 2006-2009 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Interface.Rename (renameInterface) where import Data.Traversable (traverse) import Haddock.GhcUtils import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name import NameSet import Coercion import Control.Applicative import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) import Data.Traversable (mapM) import Prelude hiding (mapM) 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 -- env let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) where fn env name = Map.insert name (ifaceMod iface) env -- rename names in the exported declarations to point to things that -- are closer to, or maybe even exported by, the current module. (renamedExportItems, missingNames1) = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface)) (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) (finalModuleDoc, missingNames4) = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would -- otherwise allways be missing. missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4) -- filter out certain built in type constructors using their string -- representation. TODO: use the Name constants from the GHC API. -- strings = filter (`notElem` ["()", "[]", "(->)"]) -- (map pretty 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 -- modules. unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ tell ["Warning: " ++ moduleString (ifaceMod iface) ++ ": could not find link destinations for:\n"++ unwords (" " : strings) ] return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap, ifaceRnArgMap = rnArgMap, ifaceRnExportItems = renamedExportItems } -------------------------------------------------------------------------------- -- Monad for renaming -- -- The monad does two things for us: it passes around the environment for -- renaming, and it returns a list of names which couldn't be found in -- the environment. -------------------------------------------------------------------------------- newtype RnM a = RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function -> (a,[Name]) } instance Monad RnM where (>>=) = thenRn return = returnRn instance Functor RnM where fmap f x = do a <- x; return (f a) instance Applicative RnM where pure = return (<*>) = ap returnRn :: a -> RnM a returnRn a = RnM (const (a,[])) thenRn :: RnM a -> (a -> RnM b) -> RnM b m `thenRn` k = RnM (\lkp -> case unRn m lkp of (a,out1) -> case unRn (k a) lkp of (b,out2) -> (b,out1++out2)) getLookupRn :: RnM (Name -> (Bool, DocName)) getLookupRn = RnM (\lkp -> (lkp,[])) outRn :: Name -> RnM () outRn name = RnM (const ((),[name])) lookupRn :: Name -> RnM DocName lookupRn name = do lkp <- getLookupRn case lkp name of (False,maps_to) -> do outRn name; return maps_to (True, maps_to) -> return maps_to runRnFM :: LinkEnv -> RnM a -> (a,[Name]) runRnFM env rn = unRn rn lkp where lkp n = case Map.lookup n env of Nothing -> (False, Undocumented n) Just mdl -> (True, Documented n mdl) -------------------------------------------------------------------------------- -- Renaming -------------------------------------------------------------------------------- rename :: Name -> RnM DocName rename = lookupRn renameL :: Located Name -> RnM (Located DocName) renameL = mapM rename renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] renameExportItems = mapM renameExportItem renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) renameDocForDecl (doc, fnArgsDoc) = (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc renameDocumentation :: Documentation Name -> RnM (Documentation DocName) renameDocumentation (Documentation mDoc mWarning) = Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning renameLDocHsSyn :: LHsDocString -> RnM LHsDocString renameLDocHsSyn = return renameDoc :: Doc Name -> RnM (Doc DocName) renameDoc = traverse rename renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy expl tyvars lcontext ltype -> do tyvars' <- renameLTyVarBndrs tyvars lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsForAllTy expl tyvars' lcontext' ltype') HsTyVar n -> return . HsTyVar =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do a' <- renameLType a b' <- renameLType b return (HsAppTy a' b') HsFunTy a b -> do a' <- renameLType a b' <- renameLType b return (HsFunTy a' b') HsListTy ty -> return . HsListTy =<< renameLType ty HsPArrTy ty -> return . HsPArrTy =<< 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 HsOpTy a (w, L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b return (HsOpTy a' (w, L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty HsKindSig ty k -> do ty' <- renameLType ty k' <- renameLKind k return (HsKindSig ty' k') HsDocTy ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc return (HsDocTy ty' doc') HsTyLit x -> return (HsTyLit x) HsWrapTy a b -> HsWrapTy a <$> renameType b HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a HsSpliceTy _ _ -> error "renameType: HsSpliceTy" renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c 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 kind)) = do { n' <- rename n ; kind' <- renameLKind kind ; return (L loc (KindedTyVar n' kind')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do className' <- rename className k' <- mapM renameType k types' <- mapM renameType types rest' <- case rest of ClassInst cs -> ClassInst <$> mapM renameType cs TypeInst ts -> TypeInst <$> traverse renameType ts DataInst dd -> DataInst <$> renameTyClD dd return (className', k', types', rest') renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d renameDecl :: HsDecl Name -> RnM (HsDecl DocName) renameDecl decl = case decl of TyClD d -> do d' <- renameTyClD d return (TyClD d') SigD s -> do s' <- renameSig s return (SigD s') ForD d -> do d' <- renameForD d return (ForD d') InstD d -> do d' <- renameInstD d return (InstD d') _ -> error "renameDecl" renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName)) renameLThing fn (L loc x) = return . L loc =<< fn x renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl return (FamDecl { tcdFam = decl' }) SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLTyVarBndrs tyvars rhs' <- renameLType rhs return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLTyVarBndrs tyvars defn' <- renameDataDefn defn return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname ltyvars' <- renameLTyVarBndrs ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats at_defs' <- mapM renameLTyFamDefltEqn at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) where 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 renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdTyVars = ltyvars, fdKindSig = tckind }) = do info' <- renameFamilyInfo info lname' <- renameL lname ltyvars' <- renameLTyVarBndrs ltyvars tckind' <- renameMaybeLKind tckind return (FamilyDecl { fdInfo = info', fdLName = lname' , fdTyVars = ltyvars', fdKindSig = tckind' }) renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) = do { eqns' <- mapM renameLTyFamInstEqn eqns ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do lcontext' <- renameLContext lcontext k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_res = restype, con_doc = mbldoc }) = do lname' <- renameL lname 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 renameConDeclFieldField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do a' <- renameLType a b' <- renameLType b return (InfixCon a' b') renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName) renameConDeclFieldField (ConDeclField name t doc) = do name' <- renameL name t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return (ConDeclField name' t' doc') renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do lnames' <- mapM renameL lnames ltype' <- renameLType ltype return (TypeSig lnames' ltype') - PatSynSig lname args ltype lreq lprov -> do + PatSynSig lname (flag, qtvs) lreq lprov lty -> do lname' <- renameL lname - args' <- case args of - PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs - InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright - ltype' <- renameLType ltype + qtvs' <- renameLTyVarBndrs qtvs lreq' <- renameLContext lreq lprov' <- renameLContext lprov - return $ PatSynSig lname' args' ltype' lreq' lprov' + lty' <- renameLType lty + return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' FixSig (FixitySig lname fixity) -> do lname' <- renameL lname return $ FixSig (FixitySig lname' fixity) MinimalSig s -> MinimalSig <$> traverse renameL s -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLType ltype return (ForeignImport lname' ltype' co x) renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLType ltype return (ForeignExport lname' ltype' co x) renameInstD :: InstDecl Name -> RnM (InstDecl DocName) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d return (ClsInstD { cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do d' <- renameTyFamInstD d return (TyFamInstD { tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d return (DataFamInstD { dfid_inst = d' }) renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do ltype' <- renameLType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs return (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) = do { eqn' <- renameLTyFamInstEqn eqn ; return (TyFamInstDecl { tfid_eqn = eqn' , tfid_fvs = placeHolderNames }) } renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) = do { tc' <- renameL tc ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = HsWB pats' PlaceHolder PlaceHolder , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) = do { tc' <- renameL tc ; tvs' <- renameLTyVarBndrs tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' , tfe_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) = do { tc' <- renameL tc ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc' , dfid_pats = HsWB pats' PlaceHolder PlaceHolder , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) ExportGroup lev id_ doc -> do doc' <- renameDoc doc return (ExportGroup lev id_ doc') ExportDecl decl doc subs instances fixities splice -> do decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs instances' <- forM instances $ \(inst, idoc) -> do inst' <- renameInstHead inst idoc' <- mapM renameDoc idoc return (inst', idoc') fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) return (ExportDecl decl' doc' subs' instances' fixities' splice) ExportNoDecl x subs -> do x' <- lookupRn x subs' <- mapM lookupRn subs return (ExportNoDecl x' subs') ExportDoc doc -> do doc' <- renameDoc doc return (ExportDoc doc') renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName) renameSub (n,doc) = do n' <- rename n doc' <- renameDocForDecl doc return (n', doc') type instance PostRn DocName NameSet = PlaceHolder type instance PostRn DocName Fixity = PlaceHolder type instance PostRn DocName Bool = PlaceHolder type instance PostRn DocName [Name] = PlaceHolder type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder type instance PostTc DocName Coercion = PlaceHolder