From f6f9bca1416f6cee48f2d4731a6c38db92e87300 Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Fri, 17 Mar 2017 14:57:39 -0700 Subject: Print any user-supplied kind signatures on type parameters. This applies to type parameters on data, newtype, type, and class declarations, and also to forall-bound type vars in type signatures. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 37 ++++++++++---------------- 1 file changed, 14 insertions(+), 23 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 2aec5272..ffe42c4f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -171,8 +171,8 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge -- | Pretty-print type variables. -ppTyVars :: [LHsTyVarBndr DocName] -> [Html] -ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs +ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> [Html] +ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs tyvarNames :: LHsQTyVars DocName -> [Name] tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit @@ -199,7 +199,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars splice unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] - ++ ppTyVars (hsQTvExplicit ltyvars)) + ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -353,20 +353,20 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual = -- | Print a type family and its variables ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = - ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (map unLoc $ hsq_explicit tvs) + ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) -- | Print a newtype / data binder and its variables -ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html -ppDataBinderWithVars summ decl = - ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) +ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocName -> Html +ppDataBinderWithVars summ unicode qual decl = + ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl) -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocName] -> Html +ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocName] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = - ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual) + ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where ppDN notation = ppBinderFixity notation summ . nameOccName . getName ppBinderFixity Infix = ppBinderInfix @@ -379,15 +379,6 @@ 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 @@ -445,7 +436,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName 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) + <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual @@ -890,7 +881,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn = -- context ppLContext ctxt unicode qual <+> -- T a b c ..., or a :+: b - ppDataBinderWithVars summary decl + ppDataBinderWithVars summary unicode qual decl <+> case ks of Nothing -> mempty Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x @@ -967,8 +958,8 @@ 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 -ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html -ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot +ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html +ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) @@ -977,7 +968,7 @@ 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 tvs ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ - ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual + ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ -- cgit v1.2.3 From eca0677beaa78f31485055c432bf481dc06007a9 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 30 May 2017 19:01:37 +0200 Subject: Clear fixme comment (#625) --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index ffe42c4f..035c8e9e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -520,9 +520,8 @@ ppClassDecl summary links instances fixities loc d subdocs , 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? + -- N.B. taking just the first name is ok. Signatures with multiple names + -- are expanded so that each name gets its own signature. minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method -- cgit v1.2.3 From 87c551fc668b9251f2647cce8772f205e1cee154 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Fri, 9 Jun 2017 08:26:43 +0200 Subject: Haddock support for bundled pattern synonyms (#627) * Haddock support for bundled pattern synonyms * Add fixities to bundled pattern synonyms * Add bundled pattern synonyms to the synopsis * Store bundled pattern fixities in expItemFixities * Add test for bundled pattern synonyms * Stop threading fixities * Include bundled pattern synonyms for re-exported data types Sadly, fixity information isn't found for re-exported data types * Support for pattern synonyms * Modify tests after #631 * Test some reexport variations * Also lookup bundled pattern synonyms from `InstalledInterface`s * Check isExported for bundled pattern synonyms * Pattern synonym is exported check * Always look for pattern synonyms in the current module Another overlooked cornercase * Account for types named twice in export lists Also introduce a fast function for nubbing on a `Name` and use it throughout the code base. * correct fixities for reexported pattern synonyms * Fuse concatMap and map * Remove obsolete import * Add pattern synonyms to visible exports * Fix test * Remove corner case --- CHANGES.md | 2 + haddock-api/src/Haddock/Backends/LaTeX.hs | 32 +- haddock-api/src/Haddock/Backends/Xhtml.hs | 4 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 56 ++- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 4 + haddock-api/src/Haddock/GhcUtils.hs | 14 +- .../src/Haddock/Interface/AttachInstances.hs | 11 +- haddock-api/src/Haddock/Interface/Create.hs | 183 +++++--- haddock-api/src/Haddock/Interface/Rename.hs | 12 +- haddock-api/src/Haddock/InterfaceFile.hs | 8 +- haddock-api/src/Haddock/Types.hs | 50 ++- html-test/ref/BundledPatterns.html | 474 +++++++++++++++++++++ html-test/ref/BundledPatterns2.html | 472 ++++++++++++++++++++ html-test/src/BundledPatterns.hs | 110 +++++ html-test/src/BundledPatterns2.hs | 10 + 15 files changed, 1329 insertions(+), 113 deletions(-) create mode 100644 html-test/ref/BundledPatterns.html create mode 100644 html-test/ref/BundledPatterns2.html create mode 100644 html-test/src/BundledPatterns.hs create mode 100644 html-test/src/BundledPatterns2.hs (limited to 'haddock-api/src/Haddock/Backends/Xhtml') diff --git a/CHANGES.md b/CHANGES.md index 95e1763a..628b0968 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -4,6 +4,8 @@ * Synopsis is working again (#599) + * Support for bundled pattern synonyms (#494, #551, #626) + ## Changes in version 2.17.4 * Fix 'internal error: links: UnhelpfulSpan' (#554, #565) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 53cfccff..18660b3f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -227,8 +227,8 @@ 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 (ExportDecl decl pats doc subdocs insts fixities _splice) + = ppDecl decl pats doc insts subdocs fixities processExport (ExportNoDecl y []) = ppDocName y processExport (ExportNoDecl y subs) @@ -278,16 +278,17 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c) ppDecl :: LHsDecl DocName + -> [(HsDecl DocName,DocForDecl DocName)] -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> LaTeX -ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of +ppDecl (L loc decl) pats (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 + -> ppDataDecl pats 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 {}) @@ -565,11 +566,11 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of ------------------------------------------------------------------------------- -ppDataDecl :: [DocInstance DocName] -> +ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> LaTeX -ppDataDecl instances subdocs _loc doc dataDecl unicode +ppDataDecl pats instances subdocs _loc doc dataDecl unicode = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) (if null body then Nothing else Just (vcat body)) @@ -579,10 +580,12 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode cons = dd_cons (tcdDataDefn dataDecl) resTy = (unLoc . head) cons - body = catMaybes [constrBit, doc >>= documentationToLaTeX] + body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX] (whereBit, leaders) - | null cons = (empty,[]) + | null cons + , null pats = (empty,[]) + | null cons = (decltt (keyword "where"), repeat empty) | otherwise = case resTy of ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) @@ -594,6 +597,19 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ text "\\end{tabulary}\\par" + patternBit + | null cons = Nothing + | otherwise = Just $ + text "\\haddockbeginconstrs" $$ + vcat [ hsep [ keyword "pattern" + , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames + , dcolon unicode + , ppLType unicode (hsSigType ty) + ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d) + | (SigD (PatSynSig lnames ty),d) <- pats + ] $$ + text "\\end{tabulary}\\par" + instancesBit = ppDocInstances unicode instances diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 34ecc5b8..249389b9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -604,8 +604,8 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) -processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice) - = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual +processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice) + = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual processExport summary _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y processExport summary _ _ qual (ExportNoDecl y subs) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 035c8e9e..716050fa 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -41,11 +41,12 @@ import BooleanFormula import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName - -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] + -> [(HsDecl DocName, DocForDecl 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 +ppDecl summ links (L loc decl) pats (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@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats 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 @@ -613,7 +614,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = , [subFamInstDetails iid pdecl]) where pdata = keyword "data" <+> typ - pdecl = pdata <+> ppShortDataDecl False True dd unicode qual + pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where iid = instanceId origin no orphan ihd typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual @@ -662,20 +663,23 @@ instanceId origin no orphan ihd = concat $ -- TODO: print contexts -ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html -ppShortDataDecl summary dataInst dataDecl unicode qual +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName + -> [(HsDecl DocName,DocForDecl DocName)] + -> Unicode -> Qualification -> Html +ppShortDataDecl summary dataInst dataDecl pats unicode qual - | [] <- cons = dataHeader + | [] <- cons + , [] <- pats = dataHeader - | [lcon] <- cons, isH98, + | [lcon] <- cons, [] <- pats, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | isH98 = dataHeader - +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) + | [] <- pats, isH98 = dataHeader + +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1) | otherwise = (dataHeader <+> keyword "where") - +++ shortSubDecls dataInst (map doGADTConstr cons) + +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1) where dataHeader @@ -689,16 +693,25 @@ ppShortDataDecl summary dataInst dataDecl unicode qual ConDeclH98 {} -> True ConDeclGADT{} -> False + pats1 = [ hsep [ keyword "pattern" + , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames + , dcolon unicode + , ppLType unicode qual (hsSigType typ) + ] + | (SigD (PatSynSig lnames typ),_) <- pats + ] + ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> + [(HsDecl DocName,DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html -ppDataDecl summary links instances fixities subdocs loc doc dataDecl +ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode qual - | summary = ppShortDataDecl summary False dataDecl unicode qual - | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit + | summary = ppShortDataDecl summary False dataDecl pats unicode qual + | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit where docname = tcdName dataDecl @@ -713,7 +726,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual whereBit - | null cons = noHtml + | null cons + , null pats = noHtml + | null cons = keyword "where" | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual @@ -723,6 +738,17 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (getConNames (unLoc c)))) fixities ] + patternBit = subPatterns qual + [ (hsep [ keyword "pattern" + , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames + , dcolon unicode + , ppLType unicode qual (hsSigType typ) + ] <+> ppFixities subfixs qual + ,combineDocumentation (fst d), []) + | (SigD (PatSynSig lnames typ),d) <- pats + , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities + ] + instancesBit = ppInstances links (OriginData docname) instances splice unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 41457f72..6993c7f6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout ( subArguments, subAssociatedTypes, subConstructors, + subPatterns, subEquations, subFields, subInstances, subOrphanInstances, @@ -180,6 +181,9 @@ subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBloc subConstructors :: Qualification -> [SubDecl] -> Html subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual +subPatterns :: Qualification -> [SubDecl] -> Html +subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual + subFields :: Qualification -> [SubDecl] -> Html subFields qual = divSubDecls "fields" "Fields" . subDlist qual diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 4280cd80..02867833 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -21,6 +21,7 @@ import Control.Arrow import Exception import Outputable import Name +import NameSet import Lexeme import Module import HscTypes @@ -135,6 +136,17 @@ declATs _ = [] pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr +nubByName :: (a -> Name) -> [a] -> [a] +nubByName f ns = go emptyNameSet ns + where + go !_ [] = [] + go !s (x:xs) + | y `elemNameSet` s = go s xs + | otherwise = let !s' = extendNameSet s y + in x : go s' xs + where + y = f x + ------------------------------------------------------------------------------- -- * Located ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index d5d74819..7a3182b8 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -21,7 +21,6 @@ import Haddock.GhcUtils import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) -import Data.Function (on) import Data.Maybe ( maybeToList, mapMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -109,13 +108,17 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = return $ e { expItemInstances = insts } e -> return e where - attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities = - nubBy ((==) `on` fst) $ expItemFixities e ++ + attachFixities e@ExportDecl{ expItemDecl = L _ d + , expItemPats = patsyns + } = e { expItemFixities = + nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap] - , n' <- n : subs + , n' <- n : (subs ++ patsyn_names) , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] ] } + where + patsyn_names = concatMap (getMainDeclBinder . fst) patsyns attachFixities e = e -- spanName: attach the location to the name that is the same file as the instance location diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 36b0b7bb..0984894d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -42,7 +42,7 @@ import Control.Arrow (second) import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad -import Data.Function (on) +import Data.Traversable import qualified Packages import qualified Module @@ -81,7 +81,10 @@ createInterface tm flags modMap instIfaceMap = do !fam_instances = md_fam_insts md !exportedNames = modInfoExports mi - (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm + (TcGblEnv { tcg_rdr_env = gre + , tcg_warns = warnings + , tcg_patsyns = patsyns + }, md) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. @@ -101,6 +104,28 @@ createInterface tm flags modMap instIfaceMap = do (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ + + exports0 = fmap (reverse . map unLoc) mayExports + exports + | OptIgnoreExports `elem` opts = Nothing + | otherwise = exports0 + warningMap = mkWarningMap dflags warnings gre exportedNames + + localBundledPatSyns :: Map Name [Name] + localBundledPatSyns = + case exports of + Nothing -> M.empty + Just ies -> + M.map (nubByName id) $ + M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns) + | IEThingWith (L _ ty_name) _ exported _ <- ies + , let bundled_patsyns = + filter is_patsyn (map (ieWrappedName . unLoc) exported) + , not (null bundled_patsyns) + ] + where + is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns)) + fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom sem_mdl) @@ -112,18 +137,12 @@ createInterface tm flags modMap instIfaceMap = do 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)) -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module. exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls - maps fixMap splices exports instIfaceMap dflags + maps localBundledPatSyns fixMap splices exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -147,32 +166,33 @@ createInterface tm flags modMap instIfaceMap = do tokenizedSrc <- mkMaybeTokenizedSrc flags tm return $! Interface { - ifaceMod = mdl - , ifaceIsSig = is_sig - , 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 + ifaceMod = mdl + , ifaceIsSig = is_sig + , 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 + , ifaceBundledPatSynMap = localBundledPatSyns + , ifaceSubMap = subMap + , ifaceFixMap = fixMap + , ifaceModuleAliases = aliases + , ifaceInstances = instances + , ifaceFamInstances = fam_instances , ifaceOrphanInstances = [] -- Filled in `attachInstances` , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` - , ifaceHaddockCoverage = coverage - , ifaceWarningMap = warningMap - , ifaceTokenizedSrc = tokenizedSrc + , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warningMap + , ifaceTokenizedSrc = tokenizedSrc } -- | Given all of the @import M as N@ declarations in a package, @@ -295,8 +315,9 @@ mkMaps :: DynFlags -> [(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) + let + (a, b, c, d) = unzip4 $ map mappings decls + in (f' $ map (nubByName fst) a , f b, f c, f d, instanceMap) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat @@ -362,7 +383,9 @@ mkMaps dflags gre instances decls = -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class. -subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] +subordinates :: InstMap + -> HsDecl Name + -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do DataFamInstDecl { dfid_tycon = L l _ @@ -539,6 +562,7 @@ mkExportItems -> [Name] -- exported names (orig) -> [LHsDecl Name] -- renamed source declarations -> Maps + -> Map Name [Name] -> FixMap -> [SrcSpan] -- splice locations -> Maybe [IE Name] @@ -547,15 +571,21 @@ mkExportItems -> ErrMsgGhc [ExportItem Name] mkExportItems is_sig modMap thisMod semMod warnings gre exportedNames decls - maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = + maps@(docMap, argMap, subMap, declMap, instMap) patSynMap 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 (L _ x)) = declWith $ ieWrappedName x - lookupExport (IEThingAbs (L _ t)) = declWith $ ieWrappedName t - lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t - lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t + lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x + lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t + lookupExport (IEThingAll (L _ t)) = do + let name = ieWrappedName t + pats <- findBundledPatterns name + declWith pats name + lookupExport (IEThingWith (L _ t) _ _ _) = do + let name = ieWrappedName t + pats <- findBundledPatterns name + declWith pats name lookupExport (IEModuleContents (L _ m)) = -- TODO: We could get more accurate reporting here if IEModuleContents -- also recorded the actual names that are exported here. We CAN @@ -574,8 +604,8 @@ mkExportItems Nothing -> [] Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc - declWith :: Name -> ErrMsgGhc [ ExportItem Name ] - declWith t = do + declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ] + declWith pats t = do r <- findDecl t case r of ([L l (ValD _)], (doc, _)) -> do @@ -612,15 +642,15 @@ mkExportItems -- 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_ ] + in return [ mkExportDecl t newDecl pats docs_ ] L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef return [ mkExportDecl t - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] + (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ] - _ -> return [ mkExportDecl t decl docs_ ] + _ -> return [ mkExportDecl t decl pats docs_ ] -- Declaration from another package ([], _) -> do @@ -637,20 +667,24 @@ mkExportItems 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_) ] + return [ mkExportDecl t decl pats (noDocForDecl, subs_) ] Just iface -> - return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl pats (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' + mkExportDecl :: Name -> LHsDecl Name -> [(HsDecl Name, DocForDecl Name)] + -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name + mkExportDecl name decl pats (doc, subs) = decl' where - decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False + decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False subs' = filter (isExported . fst) subs + pats' = [ d | d@(patsyn_decl, _) <- pats + , all isExported (getMainDeclBinder patsyn_decl) ] sub_names = map fst subs' - fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] + pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl] + fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ] exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet @@ -684,6 +718,40 @@ mkExportItems where m = nameModule n + findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl Name, DocForDecl Name)] + findBundledPatterns t = + let + m = nameModule t + + local_bundled_patsyns = + M.findWithDefault [] t patSynMap + + iface_bundled_patsyns + | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap + , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface) + = patsyns + + | Just iface <- M.lookup m instIfaceMap + , Just patsyns <- M.lookup t (instBundledPatSynMap iface) + = patsyns + + | otherwise + = [] + + patsyn_decls = do + for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do + -- call declWith here so we don't have to prepare the pattern synonym for + -- showing ourselves. + export_items <- declWith [] patsyn_name + pure [ (unLoc patsyn_decl, patsyn_doc) + | ExportDecl { + expItemDecl = patsyn_decl + , expItemMbDoc = patsyn_doc + } <- export_items + ] + + in concat <$> patsyn_decls + -- | Given a 'Module' from a 'Name', convert it into a 'Module' that -- we can actually find in the 'IfaceMap'. semToIdMod :: UnitId -> Module -> Module @@ -718,7 +786,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice) + Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice) where fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t fixities = case fixity of @@ -873,12 +941,12 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap 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)) + 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 expInst decl l name = let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) -- | Sometimes the declaration we want to export is not the "main" declaration: @@ -958,8 +1026,9 @@ mkVisibleNames (_, _, _, _, instMap) exports opts | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns where - exportName e@ExportDecl {} = name ++ subs - where subs = map fst (expItemSubDocs e) + exportName e@ExportDecl {} = name ++ subs ++ patsyns + where subs = map fst (expItemSubDocs e) + patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) name = case unLoc $ expItemDecl e of InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap decl -> getMainDeclBinder decl diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b43860fb..5820c61e 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -55,7 +55,7 @@ renameInterface dflags renamingEnv warnings iface = -- combine the missing names and filter out the built-ins, which would -- otherwise always be missing. - missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much + missingNames = nubByName id $ filter isExternalName -- XXX: isExternalName filters out too much (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4 ++ missingNames5) @@ -314,6 +314,11 @@ renameInstHead InstHead {..} = do renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d +renamePats :: [(HsDecl Name,DocForDecl Name)] -> RnM [(HsDecl DocName,DocForDecl DocName)] +renamePats = mapM + (\(d,doc) -> do { d' <- renameDecl d + ; doc' <- renameDocForDecl doc + ; return (d',doc')}) renameDecl :: HsDecl Name -> RnM (HsDecl DocName) renameDecl decl = case decl of @@ -601,15 +606,16 @@ renameExportItem item = case item of ExportGroup lev id_ doc -> do doc' <- renameDoc doc return (ExportGroup lev id_ doc') - ExportDecl decl doc subs instances fixities splice -> do + ExportDecl decl pats doc subs instances fixities splice -> do decl' <- renameLDecl decl + pats' <- renamePats pats doc' <- renameDocForDecl doc subs' <- mapM renameSub subs instances' <- forM instances renameDocInstance fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) - return (ExportDecl decl' doc' subs' instances' fixities' splice) + return (ExportDecl decl' pats' doc' subs' instances' fixities' splice) ExportNoDecl x subs -> do x' <- lookupRn x subs' <- mapM lookupRn subs diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index e5c2face..054c1384 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804) -binaryInterfaceVersion = 30 +binaryInterfaceVersion = 31 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -373,7 +373,7 @@ instance Binary InterfaceFile where instance Binary InstalledInterface where put_ bh (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap fixMap) = do + exps visExps opts subMap patSynMap fixMap) = do put_ bh modu put_ bh is_sig put_ bh info @@ -382,6 +382,7 @@ instance Binary InstalledInterface where put_ bh visExps put_ bh opts put_ bh subMap + put_ bh patSynMap put_ bh fixMap get bh = do @@ -393,10 +394,11 @@ instance Binary InstalledInterface where visExps <- get bh opts <- get bh subMap <- get bh + patSynMap <- get bh fixMap <- get bh return (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap fixMap) + exps visExps opts subMap patSynMap fixMap) instance Binary DocOption where diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 803995cc..bfc8e32b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -103,6 +103,9 @@ data Interface = Interface -- names of subordinate declarations mapped to their parent declarations. , ifaceDeclMap :: !(Map Name [LHsDecl Name]) + -- | Bundled pattern synonym declarations for specific types. + , ifaceBundledPatSynMap :: !(Map Name [Name]) + -- | Documentation of declarations originating from the module (including -- subordinates). , ifaceDocMap :: !(DocMap Name) @@ -158,49 +161,53 @@ type WarningMap = Map Name (Doc Name) data InstalledInterface = InstalledInterface { -- | The module represented by this interface. - instMod :: Module + instMod :: Module -- | Is this a signature? - , instIsSig :: Bool + , instIsSig :: Bool -- | Textual information about the module. - , instInfo :: HaddockModInfo Name + , instInfo :: HaddockModInfo Name -- | Documentation of declarations originating from the module (including -- subordinates). - , instDocMap :: DocMap Name + , instDocMap :: DocMap Name - , instArgMap :: ArgMap Name + , instArgMap :: ArgMap Name -- | All names exported by this module. - , instExports :: [Name] + , instExports :: [Name] -- | All \"visible\" names exported by the module. -- A visible name is a name that will show up in the documentation of the -- module. - , instVisibleExports :: [Name] + , instVisibleExports :: [Name] -- | Haddock options for this module (prune, ignore-exports, etc). - , instOptions :: [DocOption] + , instOptions :: [DocOption] + + , instSubMap :: Map Name [Name] - , instSubMap :: Map Name [Name] - , instFixMap :: Map Name Fixity + , instBundledPatSynMap :: Map Name [Name] + + , instFixMap :: Map Name Fixity } -- | Convert an 'Interface' to an 'InstalledInterface' toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface - { instMod = ifaceMod interface - , instIsSig = ifaceIsSig interface - , instInfo = ifaceInfo interface - , instDocMap = ifaceDocMap interface - , instArgMap = ifaceArgMap interface - , instExports = ifaceExports interface - , instVisibleExports = ifaceVisibleExports interface - , instOptions = ifaceOptions interface - , instSubMap = ifaceSubMap interface - , instFixMap = ifaceFixMap interface + { instMod = ifaceMod interface + , instIsSig = ifaceIsSig interface + , instInfo = ifaceInfo interface + , instDocMap = ifaceDocMap interface + , instArgMap = ifaceArgMap interface + , instExports = ifaceExports interface + , instVisibleExports = ifaceVisibleExports interface + , instOptions = ifaceOptions interface + , instSubMap = ifaceSubMap interface + , instBundledPatSynMap = ifaceBundledPatSynMap interface + , instFixMap = ifaceFixMap interface } @@ -217,6 +224,9 @@ data ExportItem name -- | A declaration. expItemDecl :: !(LHsDecl name) + -- | Bundled patterns for a data type declaration + , expItemPats :: ![(HsDecl name, DocForDecl name)] + -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym). , expItemMbDoc :: !(DocForDecl name) diff --git a/html-test/ref/BundledPatterns.html b/html-test/ref/BundledPatterns.html new file mode 100644 index 00000000..bf6c073c --- /dev/null +++ b/html-test/ref/BundledPatterns.html @@ -0,0 +1,474 @@ +BundledPatterns
Safe HaskellNone

BundledPatterns

Synopsis

Documentation

data Vec :: Nat -> * -> * where #

Fixed size vectors.

  • Lists with their length encoded in their type
  • Vector elements have an ASCENDING subscript starting from 0 and + ending at length - 1.

Constructors

Nil :: Vec 0 a

Bundled Patterns

pattern (:>) :: a -> Vec n a -> Vec (n + 1) a infixr 5

Add an element to the head of a vector.

>>> 3:>4:>5:>Nil
+<3,4,5>
+>>> let x = 3:>4:>5:>Nil
+>>> :t x
+x :: Num a => Vec 3 a
+

Can be used as a pattern:

>>> let f (x :> y :> _) = x + y
+>>> :t f
+f :: Num a => Vec ((n + 1) + 1) a -> a
+>>> f (3:>4:>5:>6:>7:>Nil)
+7
+

Also in conjunctions with (:<):

>>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y
+>>> :t g
+g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a
+>>> g (1:>2:>3:>4:>5:>Nil)
+12
+

data RTree :: Nat -> * -> * where #

Perfect depth binary tree.

  • Only has elements at the leaf of the tree
  • A tree of depth d has 2^d elements.

Bundled Patterns

pattern LR :: a -> RTree 0 a

Leaf of a perfect depth tree

>>> LR 1
+1
+>>> let x = LR 1
+>>> :t x
+x :: Num a => RTree 0 a
+

Can be used as a pattern:

>>> let f (LR a) (LR b) = a + b
+>>> :t f
+f :: Num a => RTree 0 a -> RTree 0 a -> a
+>>> f (LR 1) (LR 2)
+3
+
pattern BR :: RTree d a -> RTree d a -> RTree (d + 1) a

Branch of a perfect depth tree

>>> BR (LR 1) (LR 2)
+<1,2>
+>>> let x = BR (LR 1) (LR 2)
+>>> :t x
+x :: Num a => RTree 1 a
+

Case be used a pattern:

>>> let f (BR (LR a) (LR b)) = LR (a + b)
+>>> :t f
+f :: Num a => RTree 1 a -> RTree 0 a
+>>> f (BR (LR 1) (LR 2))
+3
+
\ No newline at end of file diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html new file mode 100644 index 00000000..3d1d4da0 --- /dev/null +++ b/html-test/ref/BundledPatterns2.html @@ -0,0 +1,472 @@ +BundledPatterns2
Safe HaskellNone

BundledPatterns2

Synopsis

Documentation

data Vec :: Nat -> * -> * where #

Fixed size vectors.

  • Lists with their length encoded in their type
  • Vector elements have an ASCENDING subscript starting from 0 and + ending at length - 1.

Bundled Patterns

pattern Empty :: Vec 0 a
pattern (:>) :: a -> Vec n a -> Vec (n + 1) a infixr 5

Add an element to the head of a vector.

>>> 3:>4:>5:>Nil
+<3,4,5>
+>>> let x = 3:>4:>5:>Nil
+>>> :t x
+x :: Num a => Vec 3 a
+

Can be used as a pattern:

>>> let f (x :> y :> _) = x + y
+>>> :t f
+f :: Num a => Vec ((n + 1) + 1) a -> a
+>>> f (3:>4:>5:>6:>7:>Nil)
+7
+

Also in conjunctions with (:<):

>>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y
+>>> :t g
+g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a
+>>> g (1:>2:>3:>4:>5:>Nil)
+12
+

data RTree :: Nat -> * -> * where #

Perfect depth binary tree.

  • Only has elements at the leaf of the tree
  • A tree of depth d has 2^d elements.

Bundled Patterns

pattern LR :: a -> RTree 0 a

Leaf of a perfect depth tree

>>> LR 1
+1
+>>> let x = LR 1
+>>> :t x
+x :: Num a => RTree 0 a
+

Can be used as a pattern:

>>> let f (LR a) (LR b) = a + b
+>>> :t f
+f :: Num a => RTree 0 a -> RTree 0 a -> a
+>>> f (LR 1) (LR 2)
+3
+
pattern BR :: RTree d a -> RTree d a -> RTree (d + 1) a

Branch of a perfect depth tree

>>> BR (LR 1) (LR 2)
+<1,2>
+>>> let x = BR (LR 1) (LR 2)
+>>> :t x
+x :: Num a => RTree 1 a
+

Case be used a pattern:

>>> let f (BR (LR a) (LR b)) = LR (a + b)
+>>> :t f
+f :: Num a => RTree 1 a -> RTree 0 a
+>>> f (BR (LR 1) (LR 2))
+3
+
\ No newline at end of file diff --git a/html-test/src/BundledPatterns.hs b/html-test/src/BundledPatterns.hs new file mode 100644 index 00000000..443e64fa --- /dev/null +++ b/html-test/src/BundledPatterns.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms, TypeOperators, + ViewPatterns #-} +module BundledPatterns (Vec(Nil,(:>)), RTree (LR,BR)) where + +import GHC.TypeLits +import Prelude hiding (head, tail) +import Unsafe.Coerce + +-- | Fixed size vectors. +-- +-- * Lists with their length encoded in their type +-- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and +-- ending at @'length' - 1@. +data Vec :: Nat -> * -> * where + Nil :: Vec 0 a + Cons :: a -> Vec n a -> Vec (n + 1) a + +infixr 5 `Cons` + +-- | Add an element to the head of a vector. +-- +-- >>> 3:>4:>5:>Nil +-- <3,4,5> +-- >>> let x = 3:>4:>5:>Nil +-- >>> :t x +-- x :: Num a => Vec 3 a +-- +-- Can be used as a pattern: +-- +-- >>> let f (x :> y :> _) = x + y +-- >>> :t f +-- f :: Num a => Vec ((n + 1) + 1) a -> a +-- >>> f (3:>4:>5:>6:>7:>Nil) +-- 7 +-- +-- Also in conjunctions with (':<'): +-- +-- >>> let g (a :> b :> (_ :< y :< x)) = a + b + x + y +-- >>> :t g +-- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a +-- >>> g (1:>2:>3:>4:>5:>Nil) +-- 12 +pattern (:>) :: a -> Vec n a -> Vec (n + 1) a +pattern (:>) x xs <- ((\ys -> (head ys,tail ys)) -> (x,xs)) + where + (:>) x xs = Cons x xs + +infixr 5 :> + +head :: Vec (n + 1) a -> a +head (x `Cons` _) = x + +tail :: Vec (n + 1) a -> Vec n a +tail (_ `Cons` xs) = unsafeCoerce xs + +-- | Perfect depth binary tree. +-- +-- * Only has elements at the leaf of the tree +-- * A tree of depth /d/ has /2^d/ elements. +data RTree :: Nat -> * -> * where + LR_ :: a -> RTree 0 a + BR_ :: RTree d a -> RTree d a -> RTree (d+1) a + +textract :: RTree 0 a -> a +textract (LR_ x) = x +{-# NOINLINE textract #-} + +tsplit :: RTree (d+1) a -> (RTree d a,RTree d a) +tsplit (BR_ l r) = (unsafeCoerce l, unsafeCoerce r) +{-# NOINLINE tsplit #-} + +-- | Leaf of a perfect depth tree +-- +-- >>> LR 1 +-- 1 +-- >>> let x = LR 1 +-- >>> :t x +-- x :: Num a => RTree 0 a +-- +-- Can be used as a pattern: +-- +-- >>> let f (LR a) (LR b) = a + b +-- >>> :t f +-- f :: Num a => RTree 0 a -> RTree 0 a -> a +-- >>> f (LR 1) (LR 2) +-- 3 +pattern LR :: a -> RTree 0 a +pattern LR x <- (textract -> x) + where + LR x = LR_ x + +-- | Branch of a perfect depth tree +-- +-- >>> BR (LR 1) (LR 2) +-- <1,2> +-- >>> let x = BR (LR 1) (LR 2) +-- >>> :t x +-- x :: Num a => RTree 1 a +-- +-- Case be used a pattern: +-- +-- >>> let f (BR (LR a) (LR b)) = LR (a + b) +-- >>> :t f +-- f :: Num a => RTree 1 a -> RTree 0 a +-- >>> f (BR (LR 1) (LR 2)) +-- 3 +pattern BR :: RTree d a -> RTree d a -> RTree (d+1) a +pattern BR l r <- ((\t -> (tsplit t)) -> (l,r)) + where + BR l r = BR_ l r diff --git a/html-test/src/BundledPatterns2.hs b/html-test/src/BundledPatterns2.hs new file mode 100644 index 00000000..5e9a83a7 --- /dev/null +++ b/html-test/src/BundledPatterns2.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms, TypeOperators, + ViewPatterns #-} +module BundledPatterns2 (Vec((:>), Empty), RTree(..)) where + +import GHC.TypeLits + +import BundledPatterns + +pattern Empty :: Vec 0 a +pattern Empty <- Nil -- cgit v1.2.3 From 901b327f46dc4bd70cd310ae2c6339aa9ce572bb Mon Sep 17 00:00:00 2001 From: Bartosz Nitka Date: Sun, 2 Jul 2017 11:12:01 +0100 Subject: Fix haddock: internal error: links: UnhelpfulSpan (#561) * Fix haddock: internal error: links: UnhelpfulSpan This fixes #554 for me. I believe this is another fall out of `wildcard-refactor`, like #549. * Comment to clarify why we take the methods name location --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 ++++-- haddock-api/src/Haddock/Convert.hs | 4 ++-- 2 files changed, 6 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 716050fa..cda0611a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -635,8 +635,10 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification ppInstanceSigs links splice unicode qual sigs = do TypeSig lnames typ <- sigs let names = map unLoc lnames - L loc rtyp = hsSigWcType typ - return $ ppSimpleSig links splice unicode qual loc names rtyp + L _ rtyp = hsSigWcType typ + -- Instance methods signatures are synified and thus don't have a useful + -- SrcSpan value. Use the methods name location instead. + return $ ppSimpleSig links splice unicode qual (getLoc $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 577b1a3c..4aaaed9d 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -29,7 +29,7 @@ import Name import NameSet ( emptyNameSet ) import RdrName ( mkVarUnqual ) import PatSyn -import SrcLoc ( Located, noLoc, unLoc ) +import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan ) import TcType ( tcSplitSigmaTy ) import TyCon import Type @@ -318,7 +318,7 @@ synifyDataCon use_gadt_syntax dc = , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name -synifyName = noLoc . getName +synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) synifyIdSig :: SynifyTypeState -> Id -> Sig Name -- cgit v1.2.3 From 3d3166d75c0012112a49fee4c2f6cbf82de383fa Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Mon, 31 Jul 2017 20:15:32 +0200 Subject: Move `DocMarkup` from haddock-api to haddock-library (#659) * Move `DocMarkup` from haddock-api to haddock-library * Move more markup related functions * Markup module * CHANGELOG --- CHANGES.md | 2 + haddock-api/haddock-api.cabal | 2 +- haddock-api/src/Documentation/Haddock.hs | 6 +- haddock-api/src/Haddock/Backends/Hoogle.hs | 1 + haddock-api/src/Haddock/Backends/LaTeX.hs | 1 + .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 1 + haddock-api/src/Haddock/Types.hs | 32 +---------- haddock-api/src/Haddock/Utils.hs | 67 ---------------------- haddock-library/haddock-library.cabal | 3 +- .../src/Documentation/Haddock/Markup.hs | 59 +++++++++++++++++++ haddock-library/src/Documentation/Haddock/Types.hs | 27 +++++++++ 11 files changed, 100 insertions(+), 101 deletions(-) create mode 100644 haddock-library/src/Documentation/Haddock/Markup.hs (limited to 'haddock-api/src/Haddock/Backends/Xhtml') diff --git a/CHANGES.md b/CHANGES.md index aa8789c0..bf60817a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ * to be released + * Move markup related data types to haddock-library + ## Changes in version 2.18.1 * Synopsis is working again (#599) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index de959955..6cde7266 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -42,7 +42,7 @@ library , Cabal ^>= 2.0.0 , ghc ^>= 8.2 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.4.4 + , haddock-library ^>= 1.4.5 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs index 14605e92..10d6849a 100644 --- a/haddock-api/src/Documentation/Haddock.hs +++ b/haddock-api/src/Documentation/Haddock.hs @@ -39,7 +39,8 @@ module Documentation.Haddock ( DocH(..), Example(..), Hyperlink(..), - DocMarkup(..), + DocMarkup, + DocMarkupH(..), Documentation(..), ArgMap, AliasMap, @@ -69,12 +70,11 @@ module Documentation.Haddock ( withGhc ) where - +import Documentation.Haddock.Markup (markup) import Haddock.InterfaceFile import Haddock.Interface import Haddock.Types import Haddock.Options -import Haddock.Utils import Haddock diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 183b669e..3a9f6e43 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -18,6 +18,7 @@ module Haddock.Backends.Hoogle ( import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) import InstEnv (ClsInst(..)) +import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 18660b3f..1b248d2e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -16,6 +16,7 @@ module Haddock.Backends.LaTeX ( ) where +import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils import Haddock.GhcUtils diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index e36f9528..18c8a0ff 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -20,6 +20,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( ) where import Data.List +import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index bfc8e32b..de599bd8 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -189,7 +189,7 @@ data InstalledInterface = InstalledInterface , instSubMap :: Map Name [Name] , instBundledPatSynMap :: Map Name [Name] - + , instFixMap :: Map Name Fixity } @@ -443,6 +443,8 @@ type LDoc id = Located (Doc id) type Doc id = DocH (ModuleName, OccName) id type MDoc id = MetaDoc (ModuleName, OccName) id +type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a + instance (NFData a, NFData mod) => NFData (DocH mod a) where rnf doc = case doc of @@ -494,34 +496,6 @@ exampleToString :: Example -> String exampleToString (Example expression result) = ">>> " ++ expression ++ "\n" ++ unlines result - -data DocMarkup id a = Markup - { markupEmpty :: a - , markupString :: String -> a - , markupParagraph :: a -> a - , markupAppend :: a -> a -> a - , markupIdentifier :: id -> a - , markupIdentifierUnchecked :: (ModuleName, OccName) -> a - , markupModule :: String -> a - , markupWarning :: a -> a - , markupEmphasis :: a -> a - , markupBold :: a -> a - , markupMonospaced :: a -> a - , markupUnorderedList :: [a] -> a - , markupOrderedList :: [a] -> a - , markupDefList :: [(a,a)] -> a - , markupCodeBlock :: a -> a - , markupHyperlink :: Hyperlink -> a - , markupAName :: String -> a - , markupPic :: Picture -> a - , markupMathInline :: String -> a - , markupMathDisplay :: String -> a - , markupProperty :: String -> a - , markupExample :: [Example] -> a - , markupHeader :: Header a -> a - } - - data HaddockModInfo name = HaddockModInfo { hmi_description :: Maybe (Doc name) , hmi_copyright :: Maybe String diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 404cfcf6..7a9d65a4 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -37,8 +37,6 @@ module Haddock.Utils ( html_xrefs_ref, html_xrefs_ref', -- * Doc markup - markup, - idMarkup, mkMeta, -- * List utilities @@ -448,71 +446,6 @@ spanWith p xs@(a:as) | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) | otherwise = ([],xs) - ------------------------------------------------------------------------------ --- * Put here temporarily ------------------------------------------------------------------------------ - - -markup :: DocMarkup id a -> Doc id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocMathInline mathjax) = markupMathInline m mathjax -markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax -markup m (DocProperty p) = markupProperty m p -markup m (DocExamples e) = markupExample m e -markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) - - -markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) -markupPair m (a,b) = (markup m a, markup m b) - - --- | The identity markup -idMarkup :: DocMarkup a (Doc a) -idMarkup = Markup { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupIdentifierUnchecked = DocIdentifierUnchecked, - markupModule = DocModule, - markupWarning = DocWarning, - markupEmphasis = DocEmphasis, - markupBold = DocBold, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupHyperlink = DocHyperlink, - markupAName = DocAName, - markupPic = DocPic, - markupMathInline = DocMathInline, - markupMathDisplay = DocMathDisplay, - markupProperty = DocProperty, - markupExample = DocExamples, - markupHeader = DocHeader - } - - ----------------------------------------------------------------------------- -- * System tools ----------------------------------------------------------------------------- diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 2e720d7b..44834aa9 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -31,10 +31,11 @@ library ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 exposed-modules: + Documentation.Haddock.Doc + Documentation.Haddock.Markup Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Types - Documentation.Haddock.Doc Documentation.Haddock.Utf8 other-modules: diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs new file mode 100644 index 00000000..b16cf049 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -0,0 +1,59 @@ +module Documentation.Haddock.Markup where + +import Documentation.Haddock.Types + +markup :: DocMarkupH mod id a -> DocH mod id -> a +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier x) = markupIdentifier m x +markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x +markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocBold d) = markupBold m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocHyperlink l) = markupHyperlink m l +markup m (DocAName ref) = markupAName m ref +markup m (DocPic img) = markupPic m img +markup m (DocMathInline mathjax) = markupMathInline m mathjax +markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax +markup m (DocProperty p) = markupProperty m p +markup m (DocExamples e) = markupExample m e +markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) + +markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) +markupPair m (a,b) = (markup m a, markup m b) + +-- | The identity markup +idMarkup :: DocMarkupH mod id (DocH mod id) +idMarkup = Markup { + markupEmpty = DocEmpty, + markupString = DocString, + markupParagraph = DocParagraph, + markupAppend = DocAppend, + markupIdentifier = DocIdentifier, + markupIdentifierUnchecked = DocIdentifierUnchecked, + markupModule = DocModule, + markupWarning = DocWarning, + markupEmphasis = DocEmphasis, + markupBold = DocBold, + markupMonospaced = DocMonospaced, + markupUnorderedList = DocUnorderedList, + markupOrderedList = DocOrderedList, + markupDefList = DocDefList, + markupCodeBlock = DocCodeBlock, + markupHyperlink = DocHyperlink, + markupAName = DocAName, + markupPic = DocPic, + markupMathInline = DocMathInline, + markupMathDisplay = DocMathDisplay, + markupProperty = DocProperty, + markupExample = DocExamples, + markupHeader = DocHeader + } diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 660878ff..1e87edc0 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -80,3 +80,30 @@ data DocH mod id | DocExamples [Example] | DocHeader (Header (DocH mod id)) deriving (Eq, Show, Functor, Foldable, Traversable) + +data DocMarkupH mod id a = Markup + { markupEmpty :: a + , markupString :: String -> a + , markupParagraph :: a -> a + , markupAppend :: a -> a -> a + , markupIdentifier :: id -> a + , markupIdentifierUnchecked :: mod -> a + , markupModule :: String -> a + , markupWarning :: a -> a + , markupEmphasis :: a -> a + , markupBold :: a -> a + , markupMonospaced :: a -> a + , markupUnorderedList :: [a] -> a + , markupOrderedList :: [a] -> a + , markupDefList :: [(a,a)] -> a + , markupCodeBlock :: a -> a + , markupHyperlink :: Hyperlink -> a + , markupAName :: String -> a + , markupPic :: Picture -> a + , markupMathInline :: String -> a + , markupMathDisplay :: String -> a + , markupProperty :: String -> a + , markupExample :: [Example] -> a + , markupHeader :: Header a -> a + } + -- cgit v1.2.3 From 3fddb62913c72f29843335aa796c2e444ded1608 Mon Sep 17 00:00:00 2001 From: Tim Baumann Date: Sun, 6 Aug 2017 11:33:38 +0200 Subject: Fix: Generate pattern signatures for constructors exported as patterns (#663) * Fix pretty-printing of pattern signatures Pattern synonyms can have up to two contexts, both having a different semantic meaning: The first holds the constraints required to perform the matching, the second contains the constraints provided by a successful pattern match. When the first context is empty but the second is not it is necessary to render the first, empty context. * Generate pattern synonym signatures for ctors exported as patterns This fixes #653. * Simplify extractPatternSyn It is not necessary to generate the simplest type signature since it will be simplified when pretty-printed. * Add changelog entries for PR #663 * Fix extractPatternSyn error message --- CHANGES.md | 5 + haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 242 ++++++++++++++----------- haddock-api/src/Haddock/Interface/Create.hs | 34 +++- haddock-api/src/Haddock/Types.hs | 6 + html-test/ref/ConstructorPatternExport.html | 124 +++++++++++++ html-test/ref/PatternSyns.html | 76 ++++++++ html-test/src/ConstructorPatternExport.hs | 26 +++ html-test/src/PatternSyns.hs | 8 +- 8 files changed, 412 insertions(+), 109 deletions(-) create mode 100644 html-test/ref/ConstructorPatternExport.html create mode 100644 html-test/src/ConstructorPatternExport.hs (limited to 'haddock-api/src/Haddock/Backends/Xhtml') diff --git a/CHANGES.md b/CHANGES.md index 5050339d..f96ac325 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,11 @@ * Move markup related data types to haddock-library + * Fix: Show empty constraint contexts in pattern type signatures (#663) + + * Fix: Generate constraint signatures for constructors exported as pattern + synonyms (#663) + ## Changes in version 2.18.1 * Synopsis is working again (#599) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index cda0611a..c78bee2d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -71,9 +71,9 @@ ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual = ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) - splice unicode qual + splice unicode qual HideEmptyContexts where - pp_typ = ppLType unicode qual typ + pp_typ = ppLType unicode qual HideEmptyContexts typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsSigType DocName -> @@ -87,20 +87,20 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode pref1 = hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> - Splice -> Unicode -> Qualification -> Html + Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) - splice unicode qual = + splice unicode qual emptyCtxts = 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 + splice unicode qual emptyCtxts where occnames = map (nameOccName . getName) docnames addFixities html @@ -110,8 +110,8 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) 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 + -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts | summary = pref1 | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ @@ -132,14 +132,14 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) | null (unLoc lctxt) = do_largs n leader ltype | otherwise - = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy lt r) - = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) + = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t - = [(leader <+> ppType unicode qual t, argDoc n, [])] + = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = @@ -197,11 +197,11 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars splice unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) - splice unicode qual + splice unicode qual ShowEmptyToplevelContexts where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppLType unicode qual ltype + full = hdr <+> equals <+> ppPatSigType unicode qual ltype occ = nameOccName . getName $ name fixs | summary = noHtml @@ -220,14 +220,14 @@ ppTyName :: Name -> Html ppTyName = ppName Prefix -ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan -> [DocName] -> HsType DocName -> Html -ppSimpleSig links splice unicode qual loc names typ = +ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice - ppTyp = ppType unicode qual typ + ppTyp = ppType unicode qual emptyCtxts typ occNames = map getOccName names @@ -321,7 +321,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual - <+> equals <+> ppType unicode qual (unLoc rhs) + <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) @@ -377,7 +377,7 @@ ppAppDocNameTyVarBndrs summ unicode qual n vs = 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) + ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) -- | General printing of type applications @@ -398,32 +398,35 @@ ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode - -> Qualification -> Html + -> Qualification -> HideEmptyContexts -> Html ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html -ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ - ppContextNoLocsMaybe (map unLoc cxt) unicode qual +ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ + ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts -ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html -ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ - ppContextNoLocsMaybe cxt unicode qual +ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode qual emptyCtxts -ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html -ppContextNoLocsMaybe [] _ _ = Nothing -ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual +ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html +ppContextNoLocsMaybe [] _ _ emptyCtxts = + case emptyCtxts of + HideEmptyContexts -> Nothing + ShowEmptyToplevelContexts -> Just (toHtml "()") +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 +ppContext :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts -ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html -ppHsContext [] _ _ = noHtml +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) +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt) ------------------------------------------------------------------------------- @@ -436,7 +439,7 @@ ppClassHdr :: Bool -> Located [LHsType 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) + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual @@ -592,7 +595,7 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = case ihdInstType of ClassInst { .. } -> - ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ + ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ , mdoc , [subInstDetails iid ats sigs] ) @@ -607,7 +610,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = where ptype = keyword "type" <+> typ prhs = ptype <+> maybe noHtml - (\t -> equals <+> ppType unicode qual t) rhs + (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs DataInst dd -> ( subInstHead iid pdata , mdoc @@ -636,9 +639,9 @@ ppInstanceSigs links splice unicode qual sigs = do TypeSig lnames typ <- sigs let names = map unLoc lnames L _ rtyp = hsSigWcType typ - -- Instance methods signatures are synified and thus don't have a useful + -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. - return $ ppSimpleSig links splice unicode qual (getLoc $ head $ lnames) names rtyp + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 @@ -698,7 +701,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] | (SigD (PatSynSig lnames typ),_) <- pats ] @@ -744,7 +747,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ (hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] <+> ppFixities subfixs qual ,combineDocumentation (fst d), []) | (SigD (PatSynSig lnames typ),d) <- pats @@ -769,17 +772,17 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{} -> case con_details con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc - : map (ppLParendType unicode qual) args), noHtml, noHtml) + : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml) RecCon (L _ fields) -> (header_ unicode qual +++ ppOcc <+> char '{', doRecordFields fields, char '}') InfixCon arg1 arg2 -> - (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, - ppOccInfix, ppLParendType unicode qual arg2], + (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1, + ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2], noHtml, noHtml) - ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml) where resTy = hsib_body (con_type con) @@ -811,7 +814,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ (if null ctxt then noHtml - else ppContextNoArrow ctxt unicode qual + else ppContextNoArrow ctxt unicode qual HideEmptyContexts <+> darrow unicode +++ toHtml " ") where ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) @@ -827,15 +830,15 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) - : map (ppLParendType unicode qual) args) + : map (ppLParendType unicode qual HideEmptyContexts) args) <+> fixity RecCon _ -> header_ +++ ppOcc <+> fixity InfixCon arg1 arg2 -> - hsep [header_ +++ ppLParendType unicode qual arg1, + hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1, ppOccInfix, - ppLParendType unicode qual arg2] + ppLParendType unicode qual HideEmptyContexts arg2] <+> fixity ConDeclGADT{} -> doGADTCon resTy @@ -852,7 +855,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) doGADTCon :: Located (HsType DocName) -> Html doGADTCon ty = ppOcc <+> dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - <+> ppLType unicode qual ty + <+> ppLType unicode qual HideEmptyContexts ty <+> fixity fixity = ppFixities fixities qual @@ -879,9 +882,12 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, - mbDoc, - []) + ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) + <+> dcolon unicode + <+> ppLType unicode qual HideEmptyContexts ltype + , mbDoc + , [] + ) where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation @@ -891,7 +897,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) - <+> dcolon unicode <+> ppLType unicode qual ltype + <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype -- | Print the LHS of a data\/newtype declaration. @@ -906,7 +912,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn = (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context - ppLContext ctxt unicode qual <+> + ppLContext ctxt unicode qual HideEmptyContexts <+> -- T a b c ..., or a :+: b ppDataBinderWithVars summary unicode qual decl <+> case ks of @@ -958,19 +964,18 @@ 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) +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocName) -> Html +ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) +ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) +ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppCtxType :: Unicode -> Qualification -> HsType DocName -> Html +ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts -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 +ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocName -> Html +ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts +ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts +ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = @@ -983,62 +988,85 @@ 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 +ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts + +ppPatSigType :: Unicode -> Qualification -> LHsType DocName -> Html +ppPatSigType unicode qual typ = + let emptyCtxts = + if hasNonEmptyContext typ && isFirstContextEmpty typ + then ShowEmptyToplevelContexts + else HideEmptyContexts + in ppLType unicode qual emptyCtxts typ + where + hasNonEmptyContext :: LHsType name -> Bool + hasNonEmptyContext t = + case unLoc t of + HsForAllTy _ s -> hasNonEmptyContext s + HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ s -> hasNonEmptyContext s + _ -> False + isFirstContextEmpty :: LHsType name -> Bool + isFirstContextEmpty t = + case unLoc t of + HsForAllTy _ s -> isFirstContextEmpty s + HsQualTy cxt _ -> null (unLoc cxt) + HsFunTy _ s -> isFirstContextEmpty s + _ -> False ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> 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 tvs ty) unicode qual +ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ - ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual + ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ - ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual + ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ +ppr_mono_ty _ (HsTyVar _ (L _ 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 _ (L _ 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 _ (HsSumTy tys) u q = sumParens (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 (L _ 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 _ (HsRecTy {}) _ _ = toHtml "{..}" +ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty +ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e +ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsKindSig ty kind) u q e = + parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind) +ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ = + maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts +ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" +ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy" -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual +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_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) 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] + hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) 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 + ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts where -- `(:)` is valid in type signature only as constructor to promoted list -- and needs to be quoted in code so we explicitly quote it here too. @@ -1047,25 +1075,25 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual +ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts -- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode qual + = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual - = ppr_mono_lty ctxt_prec ty unicode qual +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts + = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' +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 +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts + p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts in maybeParen ctxt_prec pREC_FUN $ hsep [p1, arrow unicode <+> p2] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index b9179d11..89f7f71b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -985,7 +985,9 @@ extractDecl name decl O.$$ O.nest 4 (O.ppr matches)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) - in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + in if isDataConName name + then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) + else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> @@ -1003,6 +1005,36 @@ extractDecl name decl _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" +extractPatternSyn :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name +extractPatternSyn nm t tvs cons = + case filter matches cons of + [] -> error "extractPatternSyn: constructor pattern not found" + con:_ -> extract <$> con + where + matches :: LConDecl Name -> Bool + matches (L _ con) = nm `elem` (unLoc <$> getConNames con) + extract :: ConDecl Name -> Sig Name + extract con = + let args = + case getConDetails con of + PrefixCon args' -> args' + RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields + InfixCon arg1 arg2 -> [arg1, arg2] + typ = longArrow args (data_ty con) + typ' = + case con of + ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) + _ -> typ + typ'' = noLoc (HsQualTy (noLoc []) typ') + in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') + + longArrow :: [LHsType name] -> LHsType name -> LHsType name + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs + + data_ty con + | ConDeclGADT{} <- con = hsib_body $ con_type con + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name extractRecSel _ _ _ [] = error "extractRecSel: selector not found" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index de599bd8..724f59bc 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -579,6 +579,12 @@ makeModuleQual qual aliases mdl = OptFullQual -> FullQual OptNoQual -> NoQual +-- | Whether to hide empty contexts +-- Since pattern synonyms have two contexts with different semantics, it is +-- important to all of them, even if one of them is empty. +data HideEmptyContexts + = HideEmptyContexts + | ShowEmptyToplevelContexts ----------------------------------------------------------------------------- -- * Error handling diff --git a/html-test/ref/ConstructorPatternExport.html b/html-test/ref/ConstructorPatternExport.html new file mode 100644 index 00000000..20f00d0f --- /dev/null +++ b/html-test/ref/ConstructorPatternExport.html @@ -0,0 +1,124 @@ +ConstructorPatternExport
Safe HaskellSafe

ConstructorPatternExport

Documentation

pattern FooCons :: String -> a -> Foo a #

pattern MyRecCons :: Bool -> Int -> MyRec #

pattern (:+) :: String -> a -> MyInfix a #

pattern BlubCons :: () => Show b => b -> Blub #

pattern MyGADTCons :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String) #

\ No newline at end of file diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index 2cf936b3..37596645 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -99,6 +99,28 @@ window.onload = function () {pageLoad();}; >FooType x1))
  • data BlubType = Show x => BlubCtor x
  • pattern Blub :: () => forall x. Show x => x -> BlubType
  • data (a ::

    data BlubType #

    BlubType is existentially quantified

    Constructors

    Show x => BlubCtor x

    pattern Blub :: () => forall x. Show x => x -> BlubType #

    Pattern synonym for Blub x

    data BlubCons b + +data MyGADT :: * -> * where + MyGADTCons :: forall a. Eq a => a -> Int -> MyGADT (Maybe String) + +pattern MyGADTCons' :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String) +pattern MyGADTCons' x y = MyGADTCons x y \ No newline at end of file diff --git a/html-test/src/PatternSyns.hs b/html-test/src/PatternSyns.hs index a8de113c..bf0f7848 100644 --- a/html-test/src/PatternSyns.hs +++ b/html-test/src/PatternSyns.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternSynonyms, PolyKinds, TypeOperators #-} +{-# LANGUAGE ExistentialQuantification, PatternSynonyms, PolyKinds, TypeOperators #-} -- | Testing some pattern synonyms module PatternSyns where @@ -15,6 +15,12 @@ pattern Bar x = FooCtor (Foo x) -- | Pattern synonym for (':<->') pattern x :<-> y = (Foo x, Bar y) +-- | BlubType is existentially quantified +data BlubType = forall x. Show x => BlubCtor x + +-- | Pattern synonym for 'Blub' x +pattern Blub x = BlubCtor x + -- | Doc for ('><') data (a :: *) >< b = Empty -- cgit v1.2.3