diff options
| author | Niklas Haas <git@nand.wakku.to> | 2014-03-13 08:53:41 +0100 | 
|---|---|---|
| committer | Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> | 2014-03-13 19:18:10 +0000 | 
| commit | eaf0a0b51f452398f3c64882a334f90b920df794 (patch) | |
| tree | e007ca9b2a8748ab9aeb135e813f91b673884f2f /src/Haddock/Backends | |
| parent | 64175d6ade5717b7e0c7fa0a122d16cae6779031 (diff) | |
Display minimal complete definitions for type classes
This corresponds to the new {-# MINIMAL #-} pragma present in GHC 7.8+.
I also cleaned up some of the places in which ExportDecl is used to make
adding fields easier in the future.
Lots of test cases have been updated since they now render with
minimality information.
Diffstat (limited to 'src/Haddock/Backends')
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 6 | ||||
| -rw-r--r-- | src/Haddock/Backends/LaTeX.hs | 6 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 6 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 28 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Layout.hs | 4 | 
5 files changed, 38 insertions, 12 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 6405861d..628e1cd0 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -110,7 +110,10 @@ operator x = x  -- How to print each export  ppExport :: DynFlags -> ExportItem Name -> [String] -ppExport dflags (ExportDecl decl dc subdocs _ _ _) = ppDocumentation dflags (fst dc) ++ f (unL decl) +ppExport dflags ExportDecl { expItemDecl    = L _ decl +                           , expItemMbDoc   = (dc, _) +                           , expItemSubDocs = subdocs +                           } = ppDocumentation dflags dc ++ f decl      where          f (TyClD d@DataDecl{})  = ppData dflags d subdocs          f (TyClD d@SynDecl{})   = ppSynonym dflags d @@ -139,6 +142,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} :              concatMap (ppSig dflags . addContext . unL) (tcdSigs x)      where          addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) +        addContext (MinimalSig sig) = MinimalSig sig          addContext _ = error "expected TypeSig"          f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 44b3fc35..7b72c030 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -177,7 +177,7 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2  exportListItem :: ExportItem DocName -> LaTeX -exportListItem (ExportDecl decl _doc subdocs _insts _fixities _splice) +exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }    = sep (punctuate comma . map ppDocBinder $ declNames decl) <>       case subdocs of         [] -> empty @@ -211,8 +211,8 @@ processExports (e : es) =  isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) -isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t)))) -                        (Documentation Nothing Nothing, argDocs) _ _ _ _) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t))) +                       , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }    | Map.null argDocs = Just (map unLoc lnames, t)  isSimpleSig _ = Nothing diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 5e728108..9628a33d 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -533,7 +533,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual      -- todo: if something has only sub-docs, or fn-args-docs, should      -- it be measured here and thus prevent omitting the synopsis? -    has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _ _ _) = isJust mDoc || isJust mWarning +    has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning      has_doc (ExportNoDecl _ _) = False      has_doc (ExportModule _) = False      has_doc _ = True @@ -578,7 +578,7 @@ miniSynopsis mdl iface unicode qual =  processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName                         -> [Html] -processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts _fixities _splice) = +processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =    ((divTopDecl <<).(declElem <<)) <$> case decl0 of      TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of          (FamDecl decl)    -> [ppTyFamHeader True False decl unicode qual] @@ -648,7 +648,7 @@ numberSectionHeadings = go 1  processExport :: Bool -> LinksInfo -> Bool -> Qualification                -> ExportItem DocName -> Maybe Html -processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _ _ _) = Nothing -- Hide empty instances +processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances  processExport summary _ _ qual (ExportGroup lev id0 doc)    = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc  processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index cd504d8e..39276441 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -28,7 +28,7 @@ import Haddock.GhcUtils  import Haddock.Types  import Haddock.Doc (combineDocumentation) -import           Data.List             ( intersperse ) +import           Data.List             ( intersperse, sort )  import qualified Data.Map as Map  import           Data.Maybe  import           Data.Monoid           ( mempty ) @@ -37,6 +37,7 @@ import           Text.XHtml hiding     ( name, title, p, quote )  import GHC  import GHC.Exts  import Name +import BooleanFormula  ppDecl :: Bool -> LinksInfo -> LHsDecl DocName @@ -406,7 +407,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan  ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs                                            , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc      subdocs splice unicode qual = -  if null sigs && null ats +  if not (any isVanillaLSig sigs) && null ats      then (if summary then id else topDeclElem links loc splice [nm]) hdr      else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")        +++ shortSubDecls @@ -441,11 +442,11 @@ ppClassDecl summary links instances fixities loc d subdocs              splice unicode qual    | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual    | otherwise = classheader +++ docSection qual d -                  +++ atBit +++ methodBit  +++ instancesBit +                  +++ minimalBit +++ atBit +++ methodBit +++ instancesBit    where      classheader -      | null lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -      | otherwise  = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) +      | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) +      | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)      -- Only the fixity relevant to the class header      fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual @@ -472,6 +473,23 @@ ppClassDecl summary links instances fixities loc d subdocs                             -- there are different subdocs for different names in a single                             -- type signature? +    minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of +      -- Miminal complete definition = every method +      And xs : _ | sort [getName n | Var (L _ n) <- xs] == +                   sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] +        -> noHtml + +      -- Minimal complete definition = nothing +      And [] : _ -> subMinimal $ toHtml "Nothing" + +      m : _  -> subMinimal $ ppMinimal False m +      _ -> noHtml + +    ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n +    ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs +    ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs +      where wrap | p = parens | otherwise = id +      instancesBit = ppInstances instances nm unicode qual  ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index 6784fb30..d3d94424 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -33,6 +33,7 @@ module Haddock.Backends.Xhtml.Layout (    subFields,    subInstances,    subMethods, +  subMinimal,    topDeclElem, declElem,  ) where @@ -182,6 +183,9 @@ subInstances qual nm = maybe noHtml wrap . instTable  subMethods :: [Html] -> Html  subMethods = divSubDecls "methods" "Methods" . subBlock +subMinimal :: Html -> Html +subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem +  -- a box for displaying code  declElem :: Html -> Html  | 
