aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Xhtml/Decl.hs
diff options
context:
space:
mode:
authorMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-08-23 10:09:34 +0100
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-08-23 10:09:34 +0100
commit5d41d4396425fc5c2e9b90d3e1e0baa5dc1ac224 (patch)
treedf13708dded1d48172cb51feb05fb41e74565ac8 /src/Haddock/Backends/Xhtml/Decl.hs
parent92e50dba7b099f24cc357de71aaa7fe06bd061b1 (diff)
Move sources under haddock-api/src
Diffstat (limited to 'src/Haddock/Backends/Xhtml/Decl.hs')
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs885
1 files changed, 0 insertions, 885 deletions
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
deleted file mode 100644
index 8884f69f..00000000
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ /dev/null
@@ -1,885 +0,0 @@
-{-# 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 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
- 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)] ->
- 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
- | summary = pref1
- | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual)
- +++ docSection qual doc
- where
- pref1 = hsep [ toHtml "pattern"
- , pp_cxt prov
- , pp_head
- , dcolon unicode
- , pp_cxt req
- , ppType 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
-
- occname = nameOccName . getName $ docname
-
-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 qual doc
- | otherwise = topDeclElem links loc splice docnames pref2 +++
- subArguments qual (do_args 0 sep typ) +++ docSection qual doc
- where
- 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 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 TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
- , tfie_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
-
-
-ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
-ppContextNoArrow [] _ _ = noHtml
-ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
-
-
-ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html
-ppContextNoLocs [] _ _ = noHtml
-ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
- <+> darrow unicode
-
-
-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 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 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 ". "
- 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
- where
- show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
- is_explicit = case expl of {Explicit -> True; Implicit -> False}
- forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
-
-
-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]