aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
authorAdam Gundry <adam@well-typed.com>2015-10-16 16:26:42 +0100
committerMatthew Pickering <matthewtpickering@gmail.com>2015-12-14 15:20:48 +0000
commit821b1dcfe62bf75711661348ac80a64cc60a0b6a (patch)
treef98f58895974c528e52ac27c156589d7a1b2ad90 /haddock-api/src/Haddock/Backends
parent319acdd0c70d21c517aa09b3e35f87e9bc01ad8c (diff)
Roughly fix up haddock for DuplicateRecordFields changes
This compiles, but will probably need more work to produce good documentation when the DuplicateRecordFields extension is used.
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs11
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs11
3 files changed, 16 insertions, 10 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index f6ad9808..42887834 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -245,8 +245,8 @@ ppCtor dflags dat subdocs con
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
- [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++
- [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+ [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++
+ [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 75ad51ab..eae450a4 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -25,9 +25,10 @@ import qualified Pretty
import GHC
import OccName
import Name ( nameOccName )
-import RdrName ( rdrNameOcc )
+import RdrName ( rdrNameOcc, mkRdrUnqual )
import FastString ( unpackFS, unpackLitString, zString )
import Outputable ( panic)
+import PrelNames ( mkUnboundName )
import qualified Data.Map as Map
import System.Directory
@@ -688,12 +689,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
- decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names))
+ decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc 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
- mbDoc = lookup (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
+ mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
-- {-
-- ppHsFullConstr :: HsConDecl -> LaTeX
@@ -902,7 +903,9 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode
= maybeParen ctxt_prec pREC_FUN $
hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]
where
- anonWC = HsWildCardTy (AnonWildCard PlaceHolder)
+ anonWC :: HsType DocName
+ anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
+ underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
ctxt'
| Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
| otherwise = ctxt
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index bc16bdcd..89b822d6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -38,6 +38,8 @@ import GHC
import GHC.Exts
import Name
import BooleanFormula
+import RdrName ( rdrNameOcc, mkRdrUnqual )
+import PrelNames ( mkUnboundName )
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
-> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
@@ -848,18 +850,18 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocName -> SubDecl
ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
- (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
+ (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual 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
- mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
ppShortField summary unicode qual (ConDeclField names ltype _)
- = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names))
+ = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode qual ltype
@@ -981,7 +983,8 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual
= maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual
<+> ppr_mono_lty pREC_TOP ty unicode qual
where
- anonWC = HsWildCardTy (AnonWildCard PlaceHolder)
+ anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
+ underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
ctxt'
| Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
| otherwise = ctxt