-----------------------------------------------------------------------------
-- |
-- 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 Control.Monad ( join )
import qualified Data.Map as Map
import Data.Maybe
import Text.XHtml hiding ( name, title, p, quote )
import BasicTypes ( IPName(..), Boxity(..) )
import GHC
import Name
import Outputable ( ppr, showSDoc, Outputable )
-- TODO: use DeclInfo DocName or something
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of
TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode
TyClD d@(TyData {})
| Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode
| Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d
TyClD d@(TySynonym {})
| Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode
| Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode
SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode
InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
DocName -> HsType DocName -> Bool -> Html
ppFunSig summary links loc doc docname typ unicode =
ppTypeOrFunSig summary links loc docname typ doc
(ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode
where
occname = docNameOcc docname
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->
DocForDecl DocName -> (Html, Html, Html) -> Bool -> Html
ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode
| summary = pref1
| Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection doc
| otherwise = topDeclElem links loc docname pref2 +++
subArguments (do_args 0 sep typ) +++ maybeDocSection 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,
Nothing, [])
: do_largs n (darrow unicode) ltype
do_args n leader (HsForAllTy Implicit _ lctxt ltype)
| not (null (unLoc lctxt))
= (leader <+> ppLContextNoArrow lctxt unicode,
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 lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
do_args n leader t
= (leader <+> ppType unicode t, argDoc n, []) : []
ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
ppTyVars tvs = map ppTyName (tyvarNames tvs)
tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
tyvarNames = map (getName . hsTyVarName . unLoc)
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Html
ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode
= ppFunSig summary links loc doc name typ unicode
ppFor _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Html
ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode
= ppTypeOrFunSig summary links loc name (unLoc ltype) doc
(full, hdr, spaceHtml +++ equals) unicode
where
hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
full = hdr <+> equals <+> ppLType unicode ltype
occ = docNameOcc name
ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Html
ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty
ppTyName :: Name -> Html
ppTyName name
| isNameSym name = parens (ppName name)
| otherwise = ppName name
--------------------------------------------------------------------------------
-- * Type families
--------------------------------------------------------------------------------
ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html
ppTyFamHeader summary associated decl unicode =
(case tcdFlavour decl of
TypeFamily
| associated -> keyword "type"
| otherwise -> keyword "type family"
DataFamily
| associated -> keyword "data"
| otherwise -> keyword "data family"
) <+>
ppTyClBinderWithVars summary decl <+>
case tcdKind decl of
Just kind -> dcolon unicode <+> ppKind kind
Nothing -> noHtml
ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
TyClDecl DocName -> Bool -> Html
ppTyFam summary associated links loc mbDoc decl unicode
| summary = ppTyFamHeader True associated decl unicode
| otherwise = header_ +++ maybeDocSection mbDoc +++ instancesBit
where
docname = tcdName decl
header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode)
instancesBit = ppInstances instances docname unicode
-- TODO: get the instances
instances = []
--------------------------------------------------------------------------------
-- * Indexed data types
--------------------------------------------------------------------------------
ppDataInst :: a
ppDataInst = undefined
--------------------------------------------------------------------------------
-- * Indexed newtypes
--------------------------------------------------------------------------------
-- TODO
-- ppNewTyInst = undefined
--------------------------------------------------------------------------------
-- * Indexed types
--------------------------------------------------------------------------------
ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
TyClDecl DocName -> Bool -> Html
ppTyInst summary associated links loc mbDoc decl unicode
| summary = ppTyInstHeader True associated decl unicode
| otherwise = header_ +++ maybeDocSection mbDoc
where
docname = tcdName decl
header_ = topDeclElem links loc docname (ppTyInstHeader summary associated decl unicode)
ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html
ppTyInstHeader _ _ decl unicode =
keyword "type instance" <+>
ppAppNameTypes (tcdName decl) typeArgs unicode
where
typeArgs = map unLoc . fromJust . tcdTyPats $ decl
--------------------------------------------------------------------------------
-- * Associated Types
--------------------------------------------------------------------------------
ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> Html
ppAssocType summ links doc (L loc decl) unicode =
case decl of
TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode
TySynonym {} -> ppTySyn summ links loc doc decl unicode
_ -> error "declaration type not supported by ppAssocType"
--------------------------------------------------------------------------------
-- * TyClDecl helpers
--------------------------------------------------------------------------------
-- | Print a type family / newtype / data / class binder and its variables
ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html
ppTyClBinderWithVars summ decl =
ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
--------------------------------------------------------------------------------
-- * Type applications
--------------------------------------------------------------------------------
-- | Print an application of a DocName and a list of HsTypes
ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html
ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
-- | Print an application of a DocName and a list of Names
ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
ppAppDocNameNames summ n ns =
ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName
-- | General printing of type applications
ppTypeApp :: DocName -> [a] -> (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 n <+> ppT t2
ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-- * Contexts
-------------------------------------------------------------------------------
ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
ppContextNoArrow :: HsContext DocName -> Bool -> Html
ppContextNoArrow [] _ = noHtml
ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
ppContextNoLocs :: [HsPred DocName] -> Bool -> Html
ppContextNoLocs [] _ = noHtml
ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
ppContext :: HsContext DocName -> Bool -> Html
ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
pp_hs_context :: [HsPred DocName] -> Bool -> Html
pp_hs_context [] _ = noHtml
pp_hs_context [p] unicode = ppPred unicode p
pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt)
ppPred :: Bool -> HsPred DocName -> Html
ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode
ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2
ppPred unicode (HsIParam (IPName n) t)
= toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t
-------------------------------------------------------------------------------
-- * Class declarations
-------------------------------------------------------------------------------
ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName
-> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
-> Bool -> Html
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
<+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else noHtml)
<+> ppAppDocNameNames summ n (tyvarNames $ tvs)
<+> ppFds fds unicode
ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html
ppFds fds unicode =
if null fds then noHtml else
char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
where
fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
hsep (map ppDocName vars2)
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Html
ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode =
if null sigs && null ats
then (if summary then id else topDeclElem links loc nm) hdr
else (if summary then id else topDeclElem links loc nm) (hdr <+> keyword "where")
+++ shortSubDecls
(
[ ppAssocType summary links doc at unicode | at <- ats
, let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
[ ppFunSig summary links loc doc n typ unicode
| L _ (TypeSig (L _ n) (L _ typ)) <- sigs
, let doc = lookupAnySubdoc n subdocs ]
)
where
hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode
nm = unLoc lname
ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
-> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> Html
ppClassDecl summary links instances loc mbDoc subdocs
decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
| summary = ppShortClassDecl summary links decl loc subdocs unicode
| otherwise = classheader +++ maybeDocSection mbDoc
+++ atBit +++ methodBit +++ instancesBit
where
classheader
| null lsigs = topDeclElem links loc nm (hdr unicode)
| otherwise = topDeclElem links loc nm (hdr unicode <+> keyword "where")
nm = unLoc $ tcdLName decl
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode
| at <- ats
, let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode
| L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
, let doc = lookupAnySubdoc n subdocs ]
instancesBit = ppInstances instances nm unicode
ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Html
ppInstances instances baseName unicode
= subInstances instName (map instDecl instances)
where
instName = getOccString $ getName baseName
instDecl :: DocInstance DocName -> SubDecl
instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
instHead ([], n, ts) = ppAppNameTypes n ts unicode
instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode
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
-------------------------------------------------------------------------------
-- TODO: print contexts
ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html
ppShortDataDecl summary _links _loc dataDecl unicode
| [] <- cons = dataHeader
| [lcon] <- cons, ResTyH98 <- resTy,
(cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode
= (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
| ResTyH98 <- resTy = dataHeader
+++ shortSubDecls (zipWith doConstr ('=':repeat '|') cons)
| otherwise = (dataHeader <+> keyword "where")
+++ shortSubDecls (map doGADTConstr cons)
where
dataHeader = ppDataHeader summary dataDecl unicode
doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode
doGADTConstr con = ppShortConstr summary (unLoc con) unicode
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] ->
SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> Html
ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
| summary = ppShortDataDecl summary links loc dataDecl unicode
| otherwise = header_ +++ maybeDocSection mbDoc +++ constrBit +++ instancesBit
where
docname = unLoc . tcdLName $ dataDecl
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode
<+> whereBit)
whereBit
| null cons = noHtml
| otherwise = case resTy of
ResTyGADT _ -> keyword "where"
_ -> noHtml
constrBit = subConstructors
(map (ppSideBySideConstr subdocs unicode) cons)
instancesBit = ppInstances instances docname unicode
ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html
ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot
where
(cHead,cBody,cFoot) = ppShortConstrParts summary con unicode
-- returns three pieces: header, body, footer so that header & footer can be
-- incorporated into the declaration
ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> (Html, Html, Html)
ppShortConstrParts summary con unicode = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
(header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args),
noHtml, noHtml)
RecCon fields ->
(header_ unicode +++ ppBinder summary occ <+> char '{',
doRecordFields fields,
char '}')
InfixCon arg1 arg2 ->
(header_ unicode +++ hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode 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 <+> char '{',
doRecordFields fields,
char '}' <+> arrow unicode <+> ppLType unicode resTy)
InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
where
doRecordFields fields = shortSubDecls (map (ppShortField summary unicode) fields)
doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
ppForAll forall ltvs lcontext unicode,
ppLType unicode (foldr mkFunTy resTy args) ]
header_ = ppConstrHdr forall tyVars context
occ = docNameOcc . 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
#if __GLASGOW_HASKELL__ == 612
ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html
#else
ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Html
#endif
ppConstrHdr forall tvs ctxt unicode
= (if null tvs then noHtml else ppForall)
+++
(if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ")
where
ppForall = case forall of
Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
Implicit -> noHtml
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> SubDecl
ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart)
where
decl = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
hsep ((header_ unicode +++ ppBinder False occ)
: map (ppLParendType unicode) args)
RecCon _ -> header_ unicode +++ ppBinder False occ
InfixCon arg1 arg2 ->
hsep [header_ unicode+++ppLParendType unicode arg1,
ppBinder False occ,
ppLParendType unicode arg2]
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
(map (ppSideBySideField subdocs unicode) fields)
doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
doGADTCon args resTy =
ppBinder False occ <+> dcolon unicode
<+> hsep [ppForAll forall ltvs (con_cxt con) unicode,
ppLType unicode (foldr mkFunTy resTy args) ]
header_ = ppConstrHdr forall tyVars context
occ = docNameOcc . 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.
-- 'join' is in Maybe.
mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
mkFunTy a b = noLoc (HsFunTy a b)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> SubDecl
ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
(ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype,
mbDoc,
[])
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
mbDoc = join $ fmap fst $ lookup name subdocs
ppShortField :: Bool -> Bool -> ConDeclField DocName -> Html
ppShortField summary unicode (ConDeclField (L _ name) ltype _)
= ppBinder summary (docNameOcc name)
<+> dcolon unicode <+> ppLType unicode ltype
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Html
ppDataHeader summary decl unicode
| not (isDataDecl decl) = error "ppDataHeader: illegal argument"
| otherwise =
-- newtype or data
(if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
-- context
ppLContext (tcdCtxt decl) unicode <+>
-- T a b c ..., or a :+: b
ppTyClBinderWithVars summary decl
--------------------------------------------------------------------------------
-- * Types and contexts
--------------------------------------------------------------------------------
ppKind :: Outputable a => a -> Html
ppKind k = toHtml $ showSDoc (ppr k)
ppBang :: HsBang -> Html
ppBang HsNoBang = noHtml
ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,
-- so we just show the strictness annotation
tupleParens :: Boxity -> [Html] -> Html
tupleParens Boxed = parenList
tupleParens Unboxed = ubxParenList
--------------------------------------------------------------------------------
-- * Rendering of HsType
--------------------------------------------------------------------------------
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
-> 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 :: Bool -> Located (HsType DocName) -> Html
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 -> Html
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
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
#if __GLASGOW_HASKELL__ == 612
ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)]
#else
ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]
#endif
-> Located (HsContext DocName) -> Bool -> Html
ppForAll expl tvs cxt unicode
| show_forall = forall_part <+> ppLContext cxt unicode
| otherwise = ppLContext cxt unicode
where
show_forall = not (null 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 -> Bool -> Html
ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html
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 <+> ppKind 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 _ (HsPredTy p) u = parens (ppPred u p)
ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only
ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
#if __GLASGOW_HASKELL__ == 612
ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
#else
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
#endif
ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
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 quote (ppLDocName op) else ppLDocName op
occName = docNameOcc . 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_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html
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 $
hsep [p1, arrow unicode <+> p2]