aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
authorAdam Gundry <adam@well-typed.com>2015-10-16 16:26:42 +0100
committerAdam Gundry <adam@well-typed.com>2015-10-16 16:26:42 +0100
commit85b7ed6147c18611b5ef6b606f157086a8203e7d (patch)
tree3b87f61a410388ee377bf2e7d822a6f210fa1665 /haddock-api
parentc7a8a8b32c9075873d666f7d0fc8a99828e17344 (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')
-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
-rw-r--r--haddock-api/src/Haddock/Convert.hs8
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs17
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs8
-rw-r--r--haddock-api/src/Haddock/Types.hs4
-rw-r--r--haddock-api/src/Haddock/Utils.hs5
9 files changed, 45 insertions, 26 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index fe656a4b..55075e20 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -190,8 +190,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 b8558f4f..68149b41 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -24,9 +24,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
@@ -686,12 +687,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
@@ -900,7 +901,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 56b64120..f94daabf 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)]
@@ -741,18 +743,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
@@ -874,7 +876,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
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 3fd783aa..f0fc108b 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -30,6 +30,7 @@ import Haddock.Types
import HsSyn
import Kind ( splitKindFunTys, tyConResKind, isKind )
import Name
+import RdrName ( mkVarUnqual )
import PatSyn
import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
import TcType ( tcSplitSigmaTy )
@@ -293,9 +294,10 @@ synifyDataCon use_gadt_syntax dc =
bang' -> noLoc $ HsBangTy bang' tySyn)
arg_tys (dataConSrcBangs dc)
- field_tys = zipWith (\field synTy -> noLoc $ ConDeclField
- [synifyName field] synTy Nothing)
- (dataConFieldLabels dc) linear_tys
+ field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
+ con_decl_field fl synTy = noLoc $
+ ConDeclField [noLoc $ FieldOcc (mkVarUnqual $ flLabel fl) (flSelector fl)] synTy
+ Nothing
hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
(True,False) -> return $ RecCon (noLoc field_tys)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 5caefa77..aa9a1c32 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -189,7 +189,8 @@ class Parent a where
instance Parent (ConDecl Name) where
children con =
case con_details con of
- RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields)
+ RecCon fields -> map (selectorFieldOcc . unL) $
+ concatMap (cd_fld_names . unL) (unL fields)
_ -> []
instance Parent (TyClDecl Name) where
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 75702b50..8f3b9f9a 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -331,15 +331,16 @@ subordinates instMap decl = case decl of
classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
, name <- getMainDeclBinder d, not (isValD d)
]
+ dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]
dataSubs dd = constrs ++ fields
where
cons = map unL $ (dd_cons dd)
constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
| c <- cons, cname <- con_names c ]
- fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
+ fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map con_details cons
, L _ (ConDeclField ns _ doc) <- (unLoc flds)
- , n <- ns ]
+ , L _ n <- ns ]
-- | Extract function argument docs from inside types.
typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -501,7 +502,7 @@ mkExportItems
lookupExport (IEVar (L _ x)) = declWith x
lookupExport (IEThingAbs (L _ t)) = declWith t
lookupExport (IEThingAll (L _ t)) = declWith t
- lookupExport (IEThingWith (L _ t) _) = declWith t
+ lookupExport (IEThingWith (L _ t) _ _) = declWith t
lookupExport (IEModuleContents (L _ m)) =
moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
lookupExport (IEGroup lev docStr) = return $
@@ -790,7 +791,7 @@ extractDecl name mdl decl
, L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
, ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
, L _ n <- ns
- , n == name
+ , selectorFieldOcc n == name
]
in case matches of
[d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
@@ -821,11 +822,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case con_details con of
- RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
- L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
+ RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
+ L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
_ -> extractRecSel nm mdl t tvs rest
where
- matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ]
+ matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
+ matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
+ , L l n <- ns, selectorFieldOcc n == nm ]
data_ty
| ResTyGADT _ ty <- con_res con = ty
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index b8fac887..033246a8 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -273,7 +273,7 @@ renameLContext (L loc context) = do
return (L loc context')
renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)
-renameWildCardInfo (AnonWildCard _) = pure (AnonWildCard PlaceHolder)
+renameWildCardInfo (AnonWildCard name) = AnonWildCard <$> rename name
renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name
renameInstHead :: InstHead Name -> RnM (InstHead DocName)
@@ -411,11 +411,15 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
renameConDeclFieldField (L l (ConDeclField names t doc)) = do
- names' <- mapM renameL names
+ names' <- mapM renameLFieldOcc names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
return $ L l (ConDeclField names' t' doc')
+renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName)
+renameLFieldOcc (L l (FieldOcc lbl sel)) = do
+ sel' <- rename sel
+ return $ L l (FieldOcc lbl sel')
renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 5737c77c..33ab9592 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -281,7 +281,6 @@ data DocName
-- documentation, as far as Haddock knows.
deriving Eq
-
instance NamedThing DocName where
getName (Documented name _) = name
getName (Undocumented name) = name
@@ -562,8 +561,9 @@ instance Monad ErrMsgGhc where
type instance PostRn DocName NameSet = PlaceHolder
type instance PostRn DocName Fixity = PlaceHolder
type instance PostRn DocName Bool = PlaceHolder
-type instance PostRn DocName Name = PlaceHolder
+type instance PostRn DocName Name = DocName
type instance PostRn DocName [Name] = PlaceHolder
+type instance PostRn DocName DocName = DocName
type instance PostTc DocName Kind = PlaceHolder
type instance PostTc DocName Type = PlaceHolder
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 4fed3a1e..c2e1b09a 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -63,6 +63,7 @@ import Haddock.GhcUtils
import GHC
import Name
+import HsTypes (selectorFieldOcc)
import Control.Monad ( liftM )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
@@ -162,7 +163,9 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
-- it's the best we can do.
InfixCon _ _ -> Just d
where
- field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns
+ field_avail :: LConDeclField Name -> Bool
+ field_avail (L _ (ConDeclField fs _ _))
+ = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs
field_types flds = [ t | ConDeclField _ t _ <- flds ]
keep _ = Nothing